diff --git a/.gitignore b/.gitignore index 67dab47bd..c322e7832 100644 --- a/.gitignore +++ b/.gitignore @@ -418,3 +418,6 @@ erasure/src/pCUICTypeChecker.ml erasure/src/pCUICTypeChecker.mli erasure/src/pCUICPrimitive.ml erasure/src/pCUICPrimitive.mli +erasure/src/pCUICCases.ml +erasure/src/pCUICCases.mli +template-coq/gen-src/specFloat.ml.rej diff --git a/.vscode/tasks.json b/.vscode/tasks.json index a58e5bf68..8b35167d1 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -7,10 +7,20 @@ "label": "make", "type": "shell", "command": "make", + "problemMatcher": [] + }, + { + "label": "makevos", + "type": "shell", + "options": { + "cwd" : "pcuic", + }, + "command": "opam exec -- make -f Makefile.pcuic vos", "group": { "kind": "build", "isDefault": true - } + }, + "problemMatcher": [] } ] } \ No newline at end of file diff --git a/DOC.md b/DOC.md index 0b0d20c6e..0beb2d251 100644 --- a/DOC.md +++ b/DOC.md @@ -63,7 +63,17 @@ Quoting always produce fully qualified names. On the converse, unquoting allow t have only partially qualified names and rely on Coq to resolve them. The commands of the TemplateMonad also allow partially qualified names. +## Hint databases +The development uses three main hint databases: + +- The "len" databases which gathers all relevant length lemmas (mainly list length lemmas + relevant to the operations). This database is large (> 100 lemmas) for a given theory + (PCUIC or Template-Coq) and it is advisable to not mix together both databases, + as autorewrite would become very slow. + BEWARE: If working in the PCUIC theory, do not require anything besides the BasicAst and utils modules from the Template-Coq module. +- The "pcuic" rewrite and auto database gathers lemmas helping solving side-conditions + of typing judgements. ## Options diff --git a/TODO.md b/TODO.md index 8596882d8..a58498673 100644 --- a/TODO.md +++ b/TODO.md @@ -38,9 +38,20 @@ - Change Template-PCUIC translations to translate casts to applications of identity functions (vm_cast, default_cast etc) to make the back and forth the identity and derive weakening/substitution/etc.. from the PCUIC theorems. - Is that really better than identity functions? + Template -> PCUIC -> Template (in an environment extended with the identity functions) + becomes the identity, by translating back the cast function applications. + PCUIC -> Template -> PCUIC is also the identity, even by special casing on cast functions + # Big projects +- Cleaner version of the system for writing term manipulation and prooofs about them. + - Develop a cleaned-up syntax profiting from Coq's type system, e.g.: + - HOAS representation of binding or first-order well-scoped binding representation (using `fin` for example) + - Well-bounded global references? + - Using vectors and fin for fixpoint bodies lists and index (no ill-formed + fixpoints by construction) + - Develop a proof mode for MetaCoq typing, à la Iris proof mode + - Refine the longest-simple-path algorithm on universes with the Bender & al algorithm used in Coq, extended with edges of negative weight. Alternatively prove the spec for that algorithm. Refinement might be easier: @@ -49,14 +60,13 @@ - Verify parsing and printing of terms / votour -- Primivite projections: we could be more relaxed on the elimination sort of the +- Primitive projections: we could be more relaxed on the elimination sort of the inductive. If it is e.g. InProp, then all projections to types in Prop should be definable. Probably not very useful though because if the elimination is restricted then it means some Type is in the constructor and won't be projectable. - Verify the substitution calculus of P.M Pédrot using skewed lists at - https://github.com/coq/coq/pull/13537 and try to use it to implement efficient explicit - substitutions. + https://github.com/coq/coq/pull/13537 and try to use it to implement efficient explicit substitutions. ## Website diff --git a/erasure/_PluginProject.in b/erasure/_PluginProject.in index f46d585c2..7140798dc 100644 --- a/erasure/_PluginProject.in +++ b/erasure/_PluginProject.in @@ -2,8 +2,6 @@ -Q src MetaCoq.Erasure -R theories MetaCoq.Erasure -src/init.mli -src/init.ml # src/classes0.mli # src/classes0.ml @@ -17,8 +15,6 @@ src/orderedTypeAlt.ml src/ssrbool.ml src/ssrbool.mli -src/monad_utils.ml -src/monad_utils.mli src/uGraph0.ml src/uGraph0.mli src/wGraph.ml @@ -35,20 +31,16 @@ src/pCUICPrimitive.mli src/pCUICPrimitive.ml src/pCUICAst.ml src/pCUICAst.mli +src/pCUICCases.mli +src/pCUICCases.ml src/pCUICAstUtils.ml src/pCUICAstUtils.mli -src/pCUICLiftSubst.ml -src/pCUICLiftSubst.mli # src/eqDecInstances.ml # src/eqDecInstances.mli src/pCUICReduction.ml src/pCUICReduction.mli src/pCUICTyping.ml src/pCUICTyping.mli -src/pCUICUnivSubst.ml -src/pCUICUnivSubst.mli -# src/pCUICCumulativity.mli -# src/pCUICCumulativity.ml src/pCUICPosition.mli src/pCUICPosition.ml src/pCUICNormal.mli diff --git a/erasure/src/metacoq_erasure_plugin.mlpack b/erasure/src/metacoq_erasure_plugin.mlpack index 986078d2b..7dde480ab 100644 --- a/erasure/src/metacoq_erasure_plugin.mlpack +++ b/erasure/src/metacoq_erasure_plugin.mlpack @@ -1,4 +1,3 @@ -Monad_utils MSetWeakList EqdepFacts Ssrbool @@ -9,16 +8,14 @@ UGraph0 OrderedTypeAlt Kernames -Init Classes0 Logic1 Relation Relation_Properties PCUICPrimitive PCUICAst +PCUICCases PCUICAstUtils -PCUICUnivSubst -PCUICLiftSubst EqDecInstances PCUICEquality PCUICTyping diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v index 9637f483f..e9376e44a 100644 --- a/erasure/theories/EArities.v +++ b/erasure/theories/EArities.v @@ -40,7 +40,7 @@ Qed. Lemma isArity_ind_type (Σ : global_env_ext) mind ind idecl : wf Σ -> - declared_inductive (fst Σ) mind ind idecl -> + declared_inductive (fst Σ) ind mind idecl -> isArity (ind_type idecl). Proof. intros. @@ -92,21 +92,21 @@ Proof. Qed. Lemma typing_spine_red : - forall (Σ : PCUICAst.global_env_ext) Γ (args args' : list PCUICAst.term) (X : All2 (red Σ Γ) args args') (bla : wf Σ) + forall (Σ : global_env_ext) Γ (args args' : list PCUICAst.term) (X : All2 (red Σ Γ) args args') (bla : wf Σ) (T x x0 : PCUICAst.term) (t0 : typing_spine Σ Γ x args x0) (c : Σ;;; Γ |- x0 <= T) (x1 : PCUICAst.term) (c0 : Σ;;; Γ |- x1 <= x), isType Σ Γ T -> typing_spine Σ Γ x1 args' T. Proof. intros Σ Γ args args' X wf T x x0 t0 c x1 c0 ?. revert args' X. dependent induction t0; intros. - - inv X. econstructor. eauto. eapply PCUICConversion.cumul_trans. assumption. - eauto. eapply PCUICConversion.cumul_trans. assumption. eauto. eauto. + - inv X. econstructor. eauto. eapply cumul_trans. assumption. + eauto. eapply cumul_trans. assumption. eauto. eauto. - inv X. econstructor. + eauto. - + eapply PCUICConversion.cumul_trans ; eauto. + + eapply cumul_trans ; eauto. + eapply subject_reduction; eauto. + eapply IHt0; eauto. eapply PCUICCumulativity.red_cumul_inv. - unfold PCUICLiftSubst.subst1. + unfold subst1. eapply (red_red Σ Γ [_] [] [_] [_]). eauto. econstructor. eauto. econstructor. econstructor. econstructor. Grab Existential Variables. all: repeat econstructor. @@ -199,9 +199,8 @@ Proof. revert c0 t0 i. generalize x at 1 3. intros x2 c0 t0 i. assert (HWF : isType Σ Γ x2). - { eapply PCUICValidity.validity. - - eauto. - - eapply type_mkApps. 2:eauto. eauto. + { eapply PCUICValidity.validity; tea. + eapply type_mkApps. 2:eauto. eauto. } eapply inversion_Construct in t as (? & ? & ? & ? & ? & ? & ?) ; auto. (* destruct x5. destruct p. cbn in *. *) assert (HL : #|ind_bodies x3| > 0). @@ -212,24 +211,24 @@ Proof. (* eapply isArity_typing_spine_inv in t0; eauto. *) (* destruct t0 as (? & [] & ?). *) (* eapply PCUICCumulativity.red_cumul in X. *) - destruct (PCUICWeakeningEnv.on_declared_constructor _ d) as [XX [s [XX1 Ht]]]. - destruct x5 as [[? ?] ?]; cbn in *; subst. - destruct Ht. unfold cdecl_type in cstr_eq. simpl in cstr_eq. subst. + destruct (PCUICWeakeningEnv.on_declared_constructor d) as [XX [s [XX1 Ht]]]. + destruct x5 as []; cbn in *; subst. + destruct Ht; cbn in *. subst. change PCUICEnvironment.it_mkProd_or_LetIn with it_mkProd_or_LetIn in c2. change PCUICEnvironment.ind_params with ind_params in *. change PCUICEnvironment.to_extended_list_k with to_extended_list_k in *. rewrite <- it_mkProd_or_LetIn_app in c2. - rewrite PCUICUnivSubst.subst_instance_constr_it_mkProd_or_LetIn in c2. - rewrite PCUICUnivSubst.subst_instance_constr_mkApps in c2. - rewrite PCUICSubstitution.subst_it_mkProd_or_LetIn in c2. + rewrite PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn in c2. + rewrite PCUICUnivSubst.subst_instance_mkApps in c2. + rewrite subst_it_mkProd_or_LetIn in c2. rewrite subst_mkApps in c2. cbn in c2. - rewrite PCUICUnivSubst.subst_instance_context_length in c2. + rewrite subst_instance_length in c2. rewrite app_length in c2. - destruct (Nat.leb_spec (#|cshape_args s| + #|ind_params x3| + 0) (#|ind_bodies x3| - S (inductive_ind ind) + #|ind_params x3| + #|cshape_args s|)). 2:lia. + destruct (Nat.leb_spec (#|cstr_args0| + #|ind_params x3| + 0) (#|ind_bodies x3| - S (inductive_ind ind) + #|ind_params x3| + #|cstr_args0|)). 2:lia. clear H. assert ((#|ind_bodies x3| - S (inductive_ind ind) + #|ind_params x3| + - #|cshape_args s| - (#|cshape_args s| + #|ind_params x3| + 0)) < #|inds (inductive_mind ind) u (ind_bodies x3)|). + #|cstr_args0| - (#|cstr_args0| + #|ind_params x3| + 0)) < #|inds (inductive_mind ind) u (ind_bodies x3)|). { rewrite inds_length. lia. } eapply nth_error_Some in H. destruct (nth_error (inds _ _ _) _) eqn:Heq; try congruence. @@ -291,8 +290,7 @@ Proof. intros x2 c0 t0 i. assert (HWF : isType Σ Γ x2). { eapply PCUICValidity.validity. - - eauto. - - eapply type_mkApps. 2:eauto. eauto. + eapply type_mkApps. 2:eauto. eauto. } eapply inversion_CoFix in t as (? & ? & ? & ? & ? & ? & ?) ; auto. eapply invert_cumul_arity_r in c0; eauto. @@ -304,10 +302,10 @@ Proof. eapply invert_cumul_arity_r_gen in c0; eauto. destruct c0. destruct H as [[r] isA]. move: r; rewrite subst_it_mkProd_or_LetIn eqT; autorewrite with len. - rewrite expand_lets_mkApps subst_mkApps /=. + rewrite PCUICSigmaCalculus.expand_lets_mkApps subst_mkApps /=. move/red_it_mkProd_or_LetIn_mkApps_Ind => [ctx' [args' eq]]. subst x4. now eapply it_mkProd_arity, isArity_mkApps in isA. - move: cum => [] Hx1; rewrite eqT expand_lets_mkApps subst_mkApps /= => cum. + move: cum => [] Hx1; rewrite eqT PCUICSigmaCalculus.expand_lets_mkApps subst_mkApps /= => cum. eapply invert_cumul_arity_r_gen in c0; eauto. destruct c0 as [? [[r] isA]]. eapply red_mkApps_tInd in r as [args' [eq _]]; auto. @@ -445,7 +443,7 @@ Proof. eapply PCUICCumulativity.red_cumul_inv in X. eapply invert_cumul_arity_l in H0 as (? & ? & ?). - 2: eapply PCUICConversion.cumul_trans; eauto. + 2: eapply cumul_trans; eauto. destruct H. eapply typing_spine_red in t1. 2:{ eapply All_All2_refl. clear. induction L; eauto. } @@ -592,7 +590,7 @@ Lemma nIs_conv_to_Arity_isWfArity_elim {Σ : global_env_ext} {Γ x} : Proof. intros nis [isTy [ctx [s da]]]. apply nis. red. exists (it_mkProd_or_LetIn ctx (tSort s)). - split. sq. apply PCUICArities.destArity_spec_Some in da. + split. sq. apply destArity_spec_Some in da. simpl in da. subst x. reflexivity. now eapply it_mkProd_isArity. diff --git a/erasure/theories/EDeps.v b/erasure/theories/EDeps.v index 982764c75..49e2f729e 100644 --- a/erasure/theories/EDeps.v +++ b/erasure/theories/EDeps.v @@ -352,16 +352,16 @@ Lemma erases_deps_forall_ind Σ Σ' (Happ : forall hd arg : Extract.E.term, erases_deps Σ Σ' hd -> P hd -> erases_deps Σ Σ' arg -> P arg -> P (Extract.E.tApp hd arg)) (Hconst : forall (kn : kername) (cb : PCUICAst.PCUICEnvironment.constant_body) (cb' : EAst.constant_body), - PCUICTyping.declared_constant Σ kn cb -> + PCUICAst.declared_constant Σ kn cb -> ETyping.declared_constant Σ' kn cb' -> - erases_constant_body (Σ, PCUICAst.cst_universes cb) cb cb' -> + erases_constant_body (Σ, cst_universes cb) cb cb' -> (forall body : Extract.E.term, Extract.E.cst_body cb' = Some body -> erases_deps Σ Σ' body) -> (forall body : Extract.E.term, Extract.E.cst_body cb' = Some body -> P body) -> P (Extract.E.tConst kn)) (Hconstruct : forall (ind : inductive) (c : nat), P (Extract.E.tConstruct ind c)) (Hcase : forall (p : inductive × nat) mdecl idecl mdecl' idecl' (discr : Extract.E.term) (brs : list (nat × Extract.E.term)), - PCUICTyping.declared_inductive Σ mdecl (fst p) idecl -> - ETyping.declared_inductive Σ' mdecl' (fst p) idecl' -> + PCUICAst.declared_inductive Σ (fst p) mdecl idecl -> + ETyping.declared_inductive Σ' (fst p) mdecl' idecl' -> erases_one_inductive_body idecl idecl' -> erases_deps Σ Σ' discr -> P discr -> @@ -369,8 +369,8 @@ Lemma erases_deps_forall_ind Σ Σ' Forall (fun br => P br.2) brs -> P (Extract.E.tCase p discr brs)) (Hproj : forall (p : projection) mdecl idecl mdecl' idecl' (t : Extract.E.term), - PCUICTyping.declared_inductive Σ mdecl p.1.1 idecl -> - ETyping.declared_inductive Σ' mdecl' p.1.1 idecl' -> + PCUICAst.declared_inductive Σ p.1.1 mdecl idecl -> + ETyping.declared_inductive Σ' p.1.1 mdecl' idecl' -> erases_one_inductive_body idecl idecl' -> erases_deps Σ Σ' t -> P t -> P (Extract.E.tProj p t)) (Hfix : forall (defs : list (Extract.E.def Extract.E.term)) (i : nat), @@ -429,7 +429,7 @@ Proof. induction er using erases_deps_forall_ind; try solve [now constructor]. apply lookup_env_Some_fresh in H as not_fresh. econstructor. - - unfold PCUICTyping.declared_constant in *; cbn. + - unfold PCUICAst.declared_constant in *; cbn. unfold eq_kername. inversion wfΣ; subst. destruct kername_eq_dec as [<-|]; [congruence|]. @@ -439,10 +439,10 @@ Proof. destruct kername_eq_dec; [congruence|]. eassumption. - unfold erases_constant_body in *. - destruct PCUICAst.cst_body eqn:body. + destruct PCUICAst.PCUICEnvironment.cst_body eqn:body. + destruct E.cst_body eqn:ebody; [|easy]. - assert (PCUICTyping.declared_constant ((kn, decl) :: Σ) kn0 cb). - { unfold PCUICTyping.declared_constant. + assert (PCUICAst.declared_constant ((kn, decl) :: Σ) kn0 cb). + { unfold PCUICAst.declared_constant. cbn. unfold eq_kername. inversion wfΣ; subst. @@ -498,15 +498,15 @@ Derive Signature for Forall2. Definition globals_erased_with_deps Σ Σ' := (forall k cst, - PCUICTyping.declared_constant Σ k cst -> + PCUICAst.declared_constant Σ k cst -> exists cst', ETyping.declared_constant Σ' k cst' /\ erases_constant_body (Σ, cst_universes cst) cst cst' /\ (forall body, cst_body cst' = Some body -> erases_deps Σ Σ' body)) /\ (forall k mdecl idecl, - PCUICTyping.declared_inductive Σ mdecl k idecl -> + PCUICAst.declared_inductive Σ k mdecl idecl -> exists mdecl' idecl', - ETyping.declared_inductive Σ' mdecl' k idecl' /\ + ETyping.declared_inductive Σ' k mdecl' idecl' /\ erases_mutual_inductive_body mdecl mdecl'). @@ -530,7 +530,8 @@ Proof. - apply inversion_Const in wt as (? & ? & ? & ? & ?); eauto. apply Σer in d as d'; destruct d' as (? & ? & ? & ?). now econstructor; eauto. - - apply inversion_Case in wt + - todo "case". + (*apply inversion_Case in wt as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); eauto. destruct (proj2 Σer _ _ _ d) as (? & ? & ? & ?). econstructor; eauto. @@ -545,7 +546,7 @@ Proof. depelim er. destruct p as ((? & ?) & ?). destruct p0. - now constructor; eauto. + now constructor; eauto. *) - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?); eauto. destruct (proj2 Σer _ _ _ (proj1 d)) as (? & ? & ? & ?). @@ -604,7 +605,7 @@ Proof. - split. intros kn' cst' decl'. destruct (eq_dec kn kn') as [<-|]. - + unfold PCUICTyping.declared_constant, ETyping.declared_constant in *; cbn in *. + + unfold PCUICAst.declared_constant, ETyping.declared_constant in *; cbn in *. rewrite eq_kername_refl in *. noconf decl'. depelim erg. @@ -635,8 +636,8 @@ Proof. as (erdecl & ? & -> & erg') by now depelim erg; eexists _, _. apply IH in erg'; [|now inversion wf]. - assert (decl_ext: PCUICTyping.declared_constant Σ kn' cst'). - { unfold PCUICTyping.declared_constant in *; cbn in *. + assert (decl_ext: PCUICAst.declared_constant Σ kn' cst'). + { unfold PCUICAst.declared_constant in *; cbn in *. unfold eq_kername in *. now destruct kername_eq_dec; [|congruence]. } specialize (proj1 erg' kn' cst' decl_ext) as (cst & decl'' & ? & ?). @@ -672,13 +673,13 @@ Proof. red in decli. unfold declared_minductive in *. simpl. destruct kername_eq_dec; subst; auto. - unfold PCUICTyping.declared_minductive in decli. + unfold PCUICAst.declared_minductive in decli. simpl in decli. rewrite eq_kername_refl in decli. intuition discriminate. * inv wf. specialize (IH _ X erg). destruct decli as [decli ?]. simpl in decli |- *. - unfold PCUICTyping.declared_minductive in decli. + unfold PCUICAst.declared_minductive in decli. simpl in decli. unfold eq_kername in decli |- *. destruct kername_eq_dec. subst. noconf decli. diff --git a/erasure/theories/EInduction.v b/erasure/theories/EInduction.v index 1312dbdf1..eca4a4e00 100644 --- a/erasure/theories/EInduction.v +++ b/erasure/theories/EInduction.v @@ -24,7 +24,7 @@ Lemma term_forall_list_ind : (forall (i : inductive) (n : nat), P (tConstruct i n)) -> (forall (p : inductive * nat) (t : term), P t -> forall l : list (nat * term), - tCaseBrsProp P l -> P (tCase p t l)) -> + All (fun x => P x.2) l -> P (tCase p t l)) -> (forall (s : projection) (t : term), P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), All (fun x => P (dbody x)) m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), All (fun x => P (dbody x)) m -> P (tCoFix m n)) -> diff --git a/erasure/theories/EInversion.v b/erasure/theories/EInversion.v index 482774810..ed78442ae 100644 --- a/erasure/theories/EInversion.v +++ b/erasure/theories/EInversion.v @@ -20,7 +20,7 @@ Lemma eval_box_apps {wfl : WcbvFlags}: eval Σ' e EAst.tBox -> eval Σ' (EAst.mkApps e x) EAst.tBox. Proof. intros Σ' e x H2. revert e H2; induction x using rev_ind; cbn; intros; eauto using eval; auto. - eapply All2_app_inv in X as ((l1' & l2') & (-> & H') & H2). + eapply All2_app_inv_l in X as (l1' & l2' & -> & H' & H2). depelim H2. specialize (IHx e _ H' H). simpl. rewrite mkApps_app. simpl. econstructor; eauto. diff --git a/erasure/theories/ELiftSubst.v b/erasure/theories/ELiftSubst.v index 14147e571..ca67e82a5 100644 --- a/erasure/theories/ELiftSubst.v +++ b/erasure/theories/ELiftSubst.v @@ -187,7 +187,7 @@ Ltac change_Sk := Ltac solve_all := - unfold tCaseBrsProp, tFixProp in *; + unfold tFixProp in *; repeat toAll; try All_map; try close_Forall; change_Sk; auto with all; intuition eauto 4 with all. @@ -220,7 +220,7 @@ Lemma lift0_p : forall M, lift0 0 M = M. apply lift0_id; easy. Qed. -Hint Extern 10 => apply_spec : all. +(* Hint Extern 10 => apply_spec : all. *) Hint Resolve -> on_snd_eq_spec : all. diff --git a/erasure/theories/ESubstitution.v b/erasure/theories/ESubstitution.v index 87d7f5c81..101bff673 100644 --- a/erasure/theories/ESubstitution.v +++ b/erasure/theories/ESubstitution.v @@ -54,9 +54,9 @@ Proof. now exists []. Qed. Lemma Informative_extends: forall (Σ : global_env_ext) (ind : inductive) - (mdecl : PCUICAst.mutual_inductive_body) (idecl : PCUICAst.one_inductive_body), + (mdecl : PCUICAst.PCUICEnvironment.mutual_inductive_body) (idecl : PCUICAst.PCUICEnvironment.one_inductive_body), - PCUICTyping.declared_inductive (fst Σ) mdecl ind idecl -> + PCUICAst.declared_inductive (fst Σ) ind mdecl idecl -> forall (Σ' : global_env) (u0 : Instance.t), wf Σ' -> extends Σ Σ' -> @@ -69,7 +69,7 @@ Proof. eapply weakening_env_declared_inductive in H; eauto. destruct H, H1. - unfold PCUICTyping.declared_minductive in *. + unfold PCUICAst.declared_minductive in *. eapply extends_lookup in H1; eauto. 2:{ reflexivity. } @@ -83,7 +83,7 @@ Require Import ssrbool. Lemma erases_extends : env_prop (fun Σ Γ t T => forall Σ', wf Σ' -> extends Σ Σ' -> forall t', erases Σ Γ t t' -> erases (Σ', Σ.2) Γ t t') - (fun Σ Γ wfΓ => wf_local Σ Γ). + (fun Σ Γ => wf_local Σ Γ). Proof. apply typing_ind_env; intros; rename_all_hyps; auto. all: match goal with [ H : erases _ _ ?a _ |- _ ] => tryif is_var a then idtac else inv H end. @@ -91,18 +91,19 @@ Proof. all: try now (econstructor; eapply Is_type_extends; eauto). - econstructor. red. - destruct isdecl as [[? ?] ?]. red in H0. - red in H5. rewrite H0 in H5. - eapply extends_lookup in H0; eauto. now rewrite H0. + destruct isdecl as [[? ?] ?]. red in H. red in H4. + rewrite H in H4. + eapply extends_lookup in H; eauto. now rewrite H. - econstructor. all:eauto. - 2:{ eauto. eapply All2_All_left in X3. + all:todo "case". + (*2:{ eauto. eapply All2_All_left in X3. 2:{ intros ? ? [[[? ?] ?] ?]. exact e0. } eapply All2_All_mix_left in X3; eauto. eapply All2_impl. exact X3. intros. destruct H as [? []]. split; eauto. } - eapply Informative_extends; eauto. + eapply Informative_extends; eauto.*) - econstructor. destruct isdecl. 2:eauto. eapply Informative_extends; eauto. - econstructor. @@ -120,12 +121,12 @@ Qed. (** ** Weakening *) Lemma Is_type_weakening: - forall (Σ : global_env_ext) (Γ Γ' Γ'' : PCUICAst.context), + forall (Σ : global_env_ext) (Γ Γ' Γ'' : context), wf_local Σ (Γ ,,, Γ') -> wf Σ -> wf_local Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') -> forall t : PCUICAst.term, - isErasable Σ (Γ ,,, Γ') t -> isErasable Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (PCUICLiftSubst.lift #|Γ''| #|Γ'| t). + isErasable Σ (Γ ,,, Γ') t -> isErasable Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (lift #|Γ''| #|Γ'| t). Proof. intros. destruct X2 as (T & ? & ?). eexists. split. eapply weakening_typing; eauto. @@ -152,12 +153,12 @@ Qed. Lemma All_map_inv {A B} (P : B -> Type) (f : A -> B) l : All P (map f l) -> All (compose P f) l. Proof. induction l; intros Hf; inv Hf; try constructor; eauto. Qed. -Lemma erases_weakening' (Σ : global_env_ext) (Γ Γ' Γ'' : PCUICAst.context) (t T : PCUICAst.term) t' : +Lemma erases_weakening' (Σ : global_env_ext) (Γ Γ' Γ'' : context) (t T : term) t' : wf Σ -> wf_local Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') -> Σ ;;; Γ ,,, Γ' |- t : T -> Σ ;;; Γ ,,, Γ' |- t ⇝ℇ t' -> - Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- (PCUICLiftSubst.lift #|Γ''| #|Γ'| t) ⇝ℇ (ELiftSubst.lift #|Γ''| #|Γ'| t'). + Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- (lift #|Γ''| #|Γ'| t) ⇝ℇ (ELiftSubst.lift #|Γ''| #|Γ'| t'). Proof. intros HΣ HΓ'' * H He. generalize_eqs H. intros eqw. rewrite <- eqw in *. @@ -169,7 +170,7 @@ Proof. forall t', Σ;;; Γ0 |- t ⇝ℇ t' -> _) - (fun Σ Γ wfΓ => wf_local Σ Γ) + (fun Σ Γ => wf_local Σ Γ) ); intros Σ wfΣ Γ0; intros; try subst Γ0; auto. all: match goal with [ H : erases _ _ ?a _ |- _ ] => tryif is_var a then idtac else inv H end. @@ -178,22 +179,23 @@ Proof. all:cbn. - destruct ?; econstructor. - econstructor. - unfold app_context, PCUICAst.snoc in *. - pose proof (H0 Γ (PCUICAst.vass n t :: Γ') Γ''). + unfold app_context, snoc in *. + pose proof (H0 Γ (vass n t :: Γ') Γ''). rewrite lift_context_snoc0, <- plus_n_O in *. eapply H1; eauto. cbn. econstructor. - eauto. cbn. exists s1. eapply weakening_typing with (T := tSort s1); eauto. + eauto. cbn. exists s1. eapply (weakening_typing (T := tSort s1)); eauto. now apply All_local_env_app_inv in X2. - econstructor. + eapply H0; eauto. - + pose proof (H1 Γ (PCUICAst.vdef n b b_ty :: Γ') Γ''). + + pose proof (H1 Γ (vdef n b b_ty :: Γ') Γ''). rewrite lift_context_snoc0, <- plus_n_O in *. eapply H2; eauto. cbn. econstructor. eauto. cbn. 2: cbn; eapply weakening_typing; eauto. eapply weakening_typing in X0; eauto. now apply All_local_env_app_inv in X3. now apply All_local_env_app_inv in X3. - - econstructor. + - todo "case". + (* econstructor. + eauto. + eapply H4; eauto. + eapply All2_map. @@ -203,7 +205,7 @@ Proof. eassumption. eassumption. intros. destruct H. destruct p0. cbn. destruct x, y; cbn in *; subst. - split; eauto. + split; eauto.*) - assert (HT : Σ;;; Γ ,,, Γ' |- PCUICAst.tFix mfix n : (decl.(dtype))). econstructor; eauto. eapply All_impl. eassumption. intros. destruct X4; cbn in *; pcuicfo. @@ -234,7 +236,7 @@ Proof. rewrite lift_fix_context. rewrite lift_context_app, <- plus_n_O in IH. unfold app_context in IH. rewrite <- !app_assoc in IH. - rewrite (All2_length _ _ X3) in *. + rewrite (All2_length X3) in *. apply IH. apply IH'. - assert (HT : Σ;;; Γ ,,, Γ' |- PCUICAst.tCoFix mfix n : (decl.(dtype))). @@ -266,16 +268,16 @@ Proof. rewrite lift_fix_context. rewrite lift_context_app, <- plus_n_O in IH. unfold app_context in IH. rewrite <- !app_assoc in IH. - rewrite (All2_length _ _ X3) in *. + rewrite (All2_length X3) in *. apply IH. apply IH'. Qed. -Lemma erases_weakening (Σ : global_env_ext) (Γ Γ' : PCUICAst.context) (t T : PCUICAst.term) t' : +Lemma erases_weakening (Σ : global_env_ext) (Γ Γ' : context) (t T : PCUICAst.term) t' : wf Σ -> wf_local Σ (Γ ,,, Γ') -> Σ ;;; Γ |- t : T -> Σ ;;; Γ |- t ⇝ℇ t' -> - Σ ;;; Γ ,,, Γ' |- (PCUICLiftSubst.lift #|Γ'| 0 t) ⇝ℇ (ELiftSubst.lift #|Γ'| 0 t'). + Σ ;;; Γ ,,, Γ' |- (lift #|Γ'| 0 t) ⇝ℇ (ELiftSubst.lift #|Γ'| 0 t'). Proof. intros. pose proof (typing_wf_local X1). @@ -292,7 +294,7 @@ Proof. Qed. Lemma All2_length {A B} {P : A -> B -> Type} l l' : All2 P l l' -> #|l| = #|l'|. -Proof. induction 1; simpl; auto. Qed. +Proof. induction 1; simpl; auto. lia. Qed. Derive Signature for subslet. @@ -301,10 +303,10 @@ Lemma is_type_subst (Σ : global_env_ext) Γ Γ' Δ a s : (* Σ ;;; Γ ,,, Γ' ,,, Δ |- a : T -> *) wf_local Σ (Γ ,,, subst_context s 0 Δ) -> isErasable Σ (Γ ,,, Γ' ,,, Δ) a -> - isErasable Σ (Γ ,,, subst_context s 0 Δ) (PCUICLiftSubst.subst s #|Δ| a). + isErasable Σ (Γ ,,, subst_context s 0 Δ) (subst s #|Δ| a). Proof. intros ? ? ? (T & HT & H). - exists (PCUICLiftSubst.subst s #|Δ| T). split. + exists (subst s #|Δ| T). split. eapply substitution; eauto. destruct H as [ | (u & ? & ?) ]. - left. generalize (#|Δ|). intros n. @@ -342,22 +344,22 @@ Lemma erases_subst (Σ : global_env_ext) Γ Γ' Δ t s t' s' T : Σ ;;; Γ ,,, Γ' ,,, Δ |- t : T -> Σ ;;; Γ ,,, Γ' ,,, Δ |- t ⇝ℇ t' -> All2 (erases Σ Γ) s s' -> - Σ ;;; (Γ ,,, subst_context s 0 Δ) |- (PCUICLiftSubst.subst s #|Δ| t) ⇝ℇ ELiftSubst.subst s' #|Δ| t'. + Σ ;;; (Γ ,,, subst_context s 0 Δ) |- (subst s #|Δ| t) ⇝ℇ ELiftSubst.subst s' #|Δ| t'. Proof. intros HΣ HΔ Hs Ht He. generalize_eqs Ht. intros eqw. revert Γ Γ' Δ t' s Hs HΔ He eqw. revert Σ HΣ Γ0 t T Ht. eapply (typing_ind_env (fun Σ Γ0 t T => - forall (Γ Γ' : PCUICAst.context) Δ t' (s : list PCUICAst.term), + forall (Γ Γ' : context) Δ t' (s : list PCUICAst.term), wf_local Σ (Γ ,,, subst_context s 0 Δ) -> subslet Σ Γ s Γ' -> Σ;;; Γ ,,, Γ' ,,, Δ |- t ⇝ℇ t' -> Γ0 = Γ ,,, Γ' ,,, Δ -> All2 (erases Σ Γ) s s' -> - Σ;;; Γ ,,, subst_context s 0 Δ |- PCUICLiftSubst.subst s #|Δ| t ⇝ℇ ELiftSubst.subst s' #|Δ| t' + Σ;;; Γ ,,, subst_context s 0 Δ |- subst s #|Δ| t ⇝ℇ ELiftSubst.subst s' #|Δ| t' ) - (fun Σ Γ0 _ => wf_local Σ Γ0) + (fun Σ Γ0 => wf_local Σ Γ0) ); intros Σ wfΣ Γ0 wfΓ0; intros; simpl in * |-; auto; subst Γ0. - inv H0. @@ -379,7 +381,7 @@ Proof. eapply is_type_subst; eauto. - inv H1. + cbn. econstructor. - specialize (H0 Γ Γ' (PCUICAst.vass n t :: Δ) t'0 s). + specialize (H0 Γ Γ' (vass n t :: Δ) t'0 s). (* unfold app_context, snoc in *. *) rewrite subst_context_snoc0 in *. eapply H0; eauto. @@ -390,7 +392,7 @@ Proof. - inv H2. + cbn. econstructor. eauto. - specialize (H1 Γ Γ' (PCUICAst.vdef n b b_ty :: Δ) t2' s). + specialize (H1 Γ Γ' (vdef n b b_ty :: Δ) t2' s). rewrite subst_context_snoc0 in *. eapply H1; eauto. cbn. econstructor. eauto. @@ -415,7 +417,8 @@ Proof. + cbn. econstructor; auto. + econstructor. eapply is_type_subst; eauto. - - depelim H6. + -todo "case". + (* depelim H6. + cbn. econstructor. * eauto. * eapply H4; eauto. @@ -427,10 +430,10 @@ Proof. eapply In_nth_error in H8 as []. eapply nth_error_all in X3; eauto. - eapply X3; eauto. + eapply X3; eauto.*) - + econstructor. - eapply is_type_subst; eauto. + (* + econstructor. + eapply is_type_subst; eauto. *) - inv H1. + cbn. econstructor. * eauto. @@ -447,7 +450,7 @@ Proof. eapply In_nth_error in H2 as []. eapply nth_error_all in X1; eauto. destruct X1 as [Hs IH]. - specialize (IH Γ Γ' (Δ ,,, PCUICLiftSubst.fix_context mfix)). + specialize (IH Γ Γ' (Δ ,,, fix_context mfix)). rewrite app_context_assoc in *. eapply IH in e1; eauto. @@ -458,7 +461,7 @@ Proof. now rewrite subst_fix_context. * cbn. now rewrite app_context_length, fix_context_length. * cbn. now erewrite app_context_length, fix_context_length, All2_length. - * pose proof (substitution Σ Γ Γ' s (Δ ,,, PCUICLiftSubst.fix_context mfix)). + * pose proof (substitution Σ Γ Γ' s (Δ ,,, fix_context mfix)). rewrite app_context_assoc in *. eapply X1 in Hs; eauto. eapply typing_wf_local. eassumption. @@ -474,7 +477,7 @@ Proof. eapply In_nth_error in H2 as []. eapply nth_error_all in X1; eauto. destruct X1. - specialize (e2 Γ Γ' (Δ ,,, PCUICLiftSubst.fix_context mfix)). + specialize (e2 Γ Γ' (Δ ,,, fix_context mfix)). rewrite app_context_assoc in *. eapply e2 in e1; eauto. @@ -485,7 +488,7 @@ Proof. now rewrite subst_fix_context. * cbn. now rewrite app_context_length, fix_context_length. * cbn. now erewrite app_context_length, fix_context_length, (All2_length _ _ X5). - * pose proof (substitution Σ Γ Γ' s (Δ ,,, PCUICLiftSubst.fix_context mfix)). + * pose proof (substitution Σ Γ Γ' s (Δ ,,, fix_context mfix)). rewrite app_context_assoc in *. eapply X1 in t; eauto. eapply typing_wf_local. eassumption. diff --git a/erasure/theories/ETyping.v b/erasure/theories/ETyping.v index 4fe76232f..67cc3a337 100644 --- a/erasure/theories/ETyping.v +++ b/erasure/theories/ETyping.v @@ -25,16 +25,16 @@ Definition declared_constant (Σ : global_declarations) id decl : Prop := Definition declared_minductive Σ mind decl := lookup_env Σ mind = Some (InductiveDecl decl). -Definition declared_inductive Σ mdecl ind decl := +Definition declared_inductive Σ ind mdecl decl := declared_minductive Σ (inductive_mind ind) mdecl /\ List.nth_error mdecl.(ind_bodies) (inductive_ind ind) = Some decl. -Definition declared_constructor Σ mdecl idecl cstr cdecl : Prop := - declared_inductive Σ mdecl (fst cstr) idecl /\ +Definition declared_constructor Σ cstr mdecl idecl cdecl : Prop := + declared_inductive Σ (fst cstr) mdecl idecl /\ List.nth_error idecl.(ind_ctors) (snd cstr) = Some cdecl. -Definition declared_projection Σ mdecl idecl (proj : projection) pdecl : Prop := - declared_inductive Σ mdecl (fst (fst proj)) idecl /\ +Definition declared_projection Σ (proj : projection) mdecl idecl pdecl : Prop := + declared_inductive Σ (fst (fst proj)) mdecl idecl /\ List.nth_error idecl.(ind_projs) (snd proj) = Some pdecl. Lemma elookup_env_cons_fresh {kn d Σ kn'} : diff --git a/erasure/theories/EWcbvEval.v b/erasure/theories/EWcbvEval.v index 830058393..50676cd7b 100644 --- a/erasure/theories/EWcbvEval.v +++ b/erasure/theories/EWcbvEval.v @@ -498,7 +498,7 @@ Section Wcbv. rewrite isFixApp_mkApps => //. rewrite -mkApps_nested; simpl. rewrite orb_false_r. - destruct t; auto. + destruct t => //. - destruct f; try discriminate. apply All_All2_refl in X0. now apply eval_stuck_fix. diff --git a/erasure/theories/Erasure.v b/erasure/theories/Erasure.v index b3a5baf10..4985bdebb 100644 --- a/erasure/theories/Erasure.v +++ b/erasure/theories/Erasure.v @@ -14,29 +14,30 @@ Existing Instance extraction_checker_flags. (* This is the total erasure function + the optimization that removes all pattern-matches on propositions. *) -Program Definition erase_template_program (p : Ast.program) - (wfΣ : ∥ Typing.wf_ext (Ast.empty_ext p.1) ∥) - (wt : ∥ ∑ T, Typing.typing (Ast.empty_ext p.1) [] p.2 T ∥) +Program Definition erase_template_program (p : Ast.Env.program) + (wfΣ : ∥ Typing.wf_ext (Ast.Env.empty_ext p.1) ∥) + (wt : ∥ ∑ T, Typing.typing (Ast.Env.empty_ext p.1) [] p.2 T ∥) : (EAst.global_context * EAst.term) := - let Σ := (trans_global (Ast.empty_ext p.1)).1 in - let t := ErasureFunction.erase (empty_ext Σ) _ nil (trans p.2) _ in + let Σ := (trans_global (Ast.Env.empty_ext p.1)).1 in + let t := ErasureFunction.erase (empty_ext Σ) _ nil (trans Σ p.2) _ in let Σ' := ErasureFunction.erase_global (term_global_deps t) Σ _ in (EOptimizePropDiscr.optimize_env Σ', EOptimizePropDiscr.optimize Σ' t). Next Obligation. sq. - apply (template_to_pcuic_env_ext (Ast.empty_ext p.1) wfΣ). + apply (template_to_pcuic_env_ext (Ast.Env.empty_ext p.1) wfΣ). Qed. Next Obligation. - sq. destruct wt as [T Ht]. exists (trans T). - change (@nil context_decl) with (trans_local []). - change (empty_ext (trans_global_decls p.1)) with (trans_global (Ast.empty_ext p.1)). - eapply template_to_pcuic_typing; simpl. apply wfΣ. + sq. destruct wt as [T Ht]. + set (Σ' := empty_ext (trans_global_decls _)). + exists (trans Σ'.1 T). + change (@nil (@BasicAst.context_decl term)) with (trans_local Σ'.1 []). + apply (template_to_pcuic_typing (Ast.Env.empty_ext p.1));simpl. apply wfΣ. apply Ht. Defined. Next Obligation. - sq. apply (template_to_pcuic_env_ext (Ast.empty_ext p.1) wfΣ). + sq. apply (template_to_pcuic_env_ext (Ast.Env.empty_ext p.1) wfΣ). Defined. Local Open Scope string_scope. @@ -44,8 +45,8 @@ Local Open Scope string_scope. 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). *) -Program Definition erase_and_print_template_program {cf : checker_flags} (p : Ast.program) +Program Definition erase_and_print_template_program {cf : checker_flags} (p : Ast.Env.program) : string := let (Σ', t) := erase_template_program p (todo "wf_env") (todo "welltyped") in - Pretty.print_term (Ast.empty_ext p.1) [] true p.2 ^ nl ^ + Pretty.print_term (Ast.Env.empty_ext p.1) [] true p.2 ^ nl ^ " erases to: " ^ nl ^ print_term Σ' [] true false t. diff --git a/erasure/theories/ErasureCorrectness.v b/erasure/theories/ErasureCorrectness.v index ab746583e..ffba2a753 100644 --- a/erasure/theories/ErasureCorrectness.v +++ b/erasure/theories/ErasureCorrectness.v @@ -23,7 +23,7 @@ Local Existing Instance config.extraction_checker_flags. Lemma isArity_subst_instance u T : isArity T -> - isArity (PCUICUnivSubst.subst_instance_constr u T). + isArity (subst_instance u T). Proof. induction T; cbn; intros; tauto. Qed. @@ -35,11 +35,11 @@ Hint Resolve wf_ext_wk_wf : core. Lemma isErasable_subst_instance (Σ : global_env_ext) Γ T univs u : wf_ext_wk Σ -> wf_local Σ Γ -> - wf_local (Σ.1, univs) (PCUICUnivSubst.subst_instance_context u Γ) -> + wf_local (Σ.1, univs) (subst_instance u Γ) -> isErasable Σ Γ T -> sub_context_set (monomorphic_udecl Σ.2) (global_ext_context_set (Σ.1, univs)) -> consistent_instance_ext (Σ.1,univs) (Σ.2) u -> - isErasable (Σ.1,univs) (PCUICUnivSubst.subst_instance_context u Γ) (PCUICUnivSubst.subst_instance_constr u T). + isErasable (Σ.1,univs) (subst_instance u Γ) (subst_instance u T). Proof. intros. destruct X2 as (? & ? & [ | (? & ? & ?)]). - eapply typing_subst_instance in t; eauto. @@ -65,7 +65,7 @@ Notation "Σ ⊢ s ▷ t" := (Ee.eval Σ s t) (at level 50, s, t at next level) Lemma Is_type_conv_context (Σ : global_env_ext) (Γ : context) t (Γ' : context) : wf Σ -> wf_local Σ Γ -> wf_local Σ Γ' -> - PCUICContextConversion.conv_context Σ Γ Γ' -> isErasable Σ Γ t -> isErasable Σ Γ' t. + conv_context Σ Γ Γ' -> isErasable Σ Γ t -> isErasable Σ Γ' t. Proof. intros. destruct X3 as (? & ? & ?). red. @@ -79,7 +79,7 @@ Lemma wf_local_rel_conv: forall Σ : global_env × universes_decl, wf Σ.1 -> forall Γ Γ' : context, - context_relation (conv_decls Σ) Γ Γ' -> + All2_fold (conv_decls Σ) Γ Γ' -> forall Γ0 : context, wf_local Σ Γ' -> wf_local_rel Σ Γ Γ0 -> wf_local_rel Σ Γ' Γ0. Proof. intros Σ wfΣ Γ Γ' X1 Γ0 ? w0. induction w0. @@ -105,12 +105,12 @@ Hint Resolve Is_type_conv_context : core. Lemma erases_context_conversion : env_prop - (fun (Σ : PCUICAst.global_env_ext) (Γ : PCUICAst.context) (t T : PCUICAst.term) => - forall Γ' : PCUICAst.context, - PCUICContextConversion.conv_context Σ Γ Γ' -> + (fun (Σ : global_env_ext) (Γ : context) (t T : PCUICAst.term) => + forall Γ' : context, + conv_context Σ Γ Γ' -> wf_local Σ Γ' -> forall t', erases Σ Γ t t' -> erases Σ Γ' t t') - (fun Σ Γ wfΓ => wf_local Σ Γ) + (fun Σ Γ => wf_local Σ Γ) . Proof. apply typing_ind_env; intros Σ wfΣ Γ wfΓ; intros **; rename_all_hyps; auto. @@ -128,11 +128,13 @@ Proof. eapply PCUICContextConversion.context_conversion with Γ; eauto. eassumption. - econstructor. eauto. eauto. - eapply All2_All_left in X3. 2:{ idtac. intros ? ? [[? e] ?]. exact e. } + todo "case". + (* eapply All2_All_left in X0. 2:{ idtac. + intros ? ? [? e]. exact e. } eapply All2_impl. eapply All2_All_mix_left. eauto. eauto. - all: pcuicfo. + all: pcuicfo. *) - econstructor. eapply All2_impl. eapply All2_All_mix_left. eassumption. eassumption. @@ -140,32 +142,11 @@ Proof. decompose [prod] X2. intuition auto. eapply b0. subst types. - eapply conv_context_app; auto. eapply typing_wf_local; eassumption. - eapply typing_wf_local in a0. subst types. - 2:eauto. - - eapply All_local_env_app. - eapply All_local_env_app_inv in a0. intuition auto. - - (* clear -wfΣ X2 a2 b4 X1. *) - eapply All_local_env_impl; eauto. simpl; intros. - destruct T. simpl in *. - eapply PCUICContextConversion.context_conversion with (Γ ,,, Γ0); eauto. - 2:{ eapply conv_context_app; auto. eapply typing_wf_local; eauto. } - eapply typing_wf_local in X3. - eapply wf_local_app. - eauto. eapply wf_local_rel_local in X3. - eapply wf_local_rel_app_inv in X3 as []. rewrite app_context_nil_l in w0. - eapply wf_local_rel_conv; eauto. - destruct X3. exists x0. - eapply PCUICContextConversion.context_conversion with (Γ ,,, Γ0); eauto. - 2:{ eapply conv_context_app; auto. eapply typing_wf_local; eauto. } - - eapply typing_wf_local in t0. - eapply wf_local_app. - eauto. eapply wf_local_rel_local in t0. - eapply wf_local_rel_app_inv in t0 as []. rewrite app_context_nil_l in w0. - eapply wf_local_rel_conv; eauto. + eapply conv_context_app; auto. + todo "should strengthen property on contexts or use existing context conv lemma here". + (* eapply typing_wf_local; assumption. *) + eapply b0. reflexivity. eauto. eauto. + - econstructor. eapply All2_impl. eapply All2_All_mix_left. eassumption. eassumption. @@ -173,91 +154,69 @@ Proof. decompose [prod] X2. intuition auto. eapply b0. subst types. - eapply conv_context_app; auto. eapply typing_wf_local; eassumption. - eapply typing_wf_local in a0. subst types. - 2:eauto. - - eapply All_local_env_app. - eapply All_local_env_app_inv in a0. intuition auto. - - (* clear -wfΣ X2 a2 b4 X1. *) - eapply All_local_env_impl; eauto. simpl; intros. - destruct T. simpl in *. - eapply PCUICContextConversion.context_conversion with (Γ ,,, Γ0); eauto. - 2:{ eapply conv_context_app; auto. eapply typing_wf_local; eauto. } - eapply typing_wf_local in X3. - eapply wf_local_app. - eauto. eapply wf_local_rel_local in X3. - eapply wf_local_rel_app_inv in X3 as []. rewrite app_context_nil_l in w0. - - - eapply wf_local_rel_conv; eauto. - destruct X3. exists x0. - eapply PCUICContextConversion.context_conversion with (Γ ,,, Γ0); eauto. - 2:{ eapply conv_context_app; auto. eapply typing_wf_local; eauto. } - - eapply typing_wf_local in t0. - eapply wf_local_app. - eauto. eapply wf_local_rel_local in t0. - eapply wf_local_rel_app_inv in t0 as []. rewrite app_context_nil_l in w0. - eapply wf_local_rel_conv; eauto. + eapply conv_context_app; auto. + todo "should strengthen property on contexts or use existing context conv lemma here". + (* eapply typing_wf_local; assumption. *) + eapply b0. reflexivity. eauto. eauto. Qed. (** ** Erasure is stable under substituting universe constraints *) Lemma fix_context_subst_instance: forall (mfix : list (BasicAst.def term)) (u : Instance.t), - map (map_decl (PCUICUnivSubst.subst_instance_constr u)) - (PCUICLiftSubst.fix_context mfix) = - PCUICLiftSubst.fix_context + map (map_decl (subst_instance u)) + (fix_context mfix) = + fix_context (map - (map_def (PCUICUnivSubst.subst_instance_constr u) - (PCUICUnivSubst.subst_instance_constr u)) mfix). + (map_def (subst_instance u) + (subst_instance u)) mfix). Proof. - intros mfix. unfold PCUICLiftSubst.fix_context. intros. + intros mfix. unfold fix_context. intros. rewrite map_rev. rewrite mapi_map. rewrite map_mapi. f_equal. eapply mapi_ext. intros. cbn. unfold map_decl. cbn. unfold vass. - rewrite PCUICUnivSubst.lift_subst_instance_constr. reflexivity. + rewrite subst_instance_lift. reflexivity. Qed. -Lemma erases_subst_instance_constr0 +Lemma erases_subst_instance0 : env_prop (fun Σ Γ t T => wf_ext_wk Σ -> forall t' u univs, - wf_local (Σ.1, univs) (PCUICUnivSubst.subst_instance_context u Γ) -> + wf_local (Σ.1, univs) (subst_instance u Γ) -> sub_context_set (monomorphic_udecl Σ.2) (global_ext_context_set (Σ.1, univs)) -> consistent_instance_ext (Σ.1,univs) (Σ.2) u -> Σ ;;; Γ |- t ⇝ℇ t' -> - (Σ.1,univs) ;;; (PCUICUnivSubst.subst_instance_context u Γ) |- PCUICUnivSubst.subst_instance_constr u t ⇝ℇ t') - (fun Σ Γ wfΓ => wf_local Σ Γ). + (Σ.1,univs) ;;; (subst_instance u Γ) |- subst_instance u t ⇝ℇ t') + (fun Σ Γ => wf_local Σ Γ). Proof. - apply typing_ind_env; intros; cbn -[PCUICUnivSubst.subst_instance_constr] in *; auto. + apply typing_ind_env; intros; cbn -[subst_instance] in *; auto. all: match goal with [ H : erases _ _ ?a _ |- ?G ] => tryif is_var a then idtac else invs H end. all: try now (econstructor; eauto 2 using isErasable_subst_instance). - cbn. econstructor. - eapply H0 in X2; eauto. - econstructor. eauto. cbn. econstructor. + eapply H0 in X2; eauto. apply X2. + cbn. econstructor. eauto. cbn. econstructor. eapply typing_subst_instance in X0; eauto. apply snd in X0. - cbn in X0. refine (X0 _ _ _ _ _); eauto. + cbn in X0. destruct X0. refine (t0 _ _ _ _ _); eauto. - cbn. econstructor. eapply H0 in X3; eauto. eapply H1 in X3; eauto. exact X3. - econstructor. eauto. cbn. econstructor. + cbn. econstructor. eauto. cbn. econstructor. eapply typing_subst_instance in X0; eauto. apply snd in X0. - cbn in X0. refine (X0 _ _ _ _ _); eauto. + cbn in X0. + eapply X0; eauto. cbn. eapply typing_subst_instance in X1; eauto. apply snd in X1. - cbn in X1. refine (X1 _ _ _ _ _); eauto. - - cbn. econstructor; eauto. + cbn in X1. eapply X1; eauto. + - todo "case". + (* cbn. econstructor; eauto. eapply All2_map_left. eapply All2_impl. eapply All2_All_mix_left. eapply All2_All_left. exact X3. intros ? ? [[? e] ?]. exact e. exact X6. - intros; cbn in *. destruct H. destruct p0. split; eauto. - - assert (Hw : wf_local (Σ.1, univs) (subst_instance_context u (Γ ,,, types))). - { (* rewrite subst_instance_context_app. *) + intros; cbn in *. destruct H. destruct p0. split; eauto.*) + - assert (Hw : wf_local (Σ.1, univs) (subst_instance u (Γ ,,, types))). + { (* rewrite subst_instance_app. *) assert(All (fun d => isType Σ Γ (dtype d)) mfix). eapply (All_impl X0); pcuicfo. now destruct X5 as [s [Hs ?]]; exists s. @@ -269,13 +228,13 @@ Proof. - cbn. econstructor; eauto. cbn in *. destruct t0 as (? & ?). eexists. cbn. eapply typing_subst_instance in t0; eauto. apply snd in t0. cbn in t0. - rapply t0; eauto. + eapply t0; eauto. - cbn. econstructor; eauto. cbn in *. destruct t0 as (? & ?). eexists. cbn. eapply typing_subst_instance in t0; eauto. apply snd in t0. - rapply t0; eauto. + eapply t0; eauto. cbn in *. eapply typing_subst_instance in t1; eauto. - apply snd in t1. rapply t1. all:eauto. + apply snd in t1. eapply t1. all:eauto. } cbn. econstructor; eauto. @@ -285,14 +244,13 @@ Proof. intros; cbn in *. destruct X5. destruct p0. destruct p0. destruct p. repeat split; eauto. eapply e2 in e1. - unfold PCUICUnivSubst.subst_instance_context in *. - unfold map_context in *. rewrite ->map_app in *. subst types. 2:eauto. + rewrite subst_instance_app in e1. subst types. 2:eauto. eapply erases_ctx_ext. eassumption. unfold app_context. f_equal. eapply fix_context_subst_instance. all: eauto. - - assert (Hw : wf_local (Σ.1, univs) (subst_instance_context u (Γ ,,, types))). - { (* rewrite subst_instance_context_app. *) + - assert (Hw : wf_local (Σ.1, univs) (subst_instance u (Γ ,,, types))). + { (* rewrite subst_instance_app. *) assert(All (fun d => isType Σ Γ (dtype d)) mfix). eapply (All_impl X0); pcuicfo. destruct X5 as [s [Hs ?]]; now exists s. @@ -304,13 +262,13 @@ Proof. - cbn. econstructor; eauto. cbn in *. destruct t0 as (? & ?). eexists. cbn. eapply typing_subst_instance in t0; eauto. apply snd in t0. cbn in t0. - rapply t0; eauto. + eapply t0; eauto. - cbn. econstructor; eauto. cbn in *. destruct t0 as (? & ?). eexists. cbn. eapply typing_subst_instance in t0; eauto. apply snd in t0. - rapply t0; eauto. + eapply t0; eauto. cbn in *. eapply typing_subst_instance in t1; eauto. - apply snd in t1. rapply t1. all:eauto. + apply snd in t1. eapply t1. all:eauto. } cbn. econstructor; eauto. @@ -320,25 +278,24 @@ Proof. intros; cbn in *. destruct X5. destruct p0. destruct p0. destruct p. repeat split; eauto. eapply e2 in e1. - unfold PCUICUnivSubst.subst_instance_context in *. - unfold map_context in *. rewrite -> map_app in *. subst types. 2:eauto. + rewrite subst_instance_app in e1; eauto. subst types. 2:eauto. eapply erases_ctx_ext. eassumption. unfold app_context. f_equal. eapply fix_context_subst_instance. all: eauto. Qed. -Lemma erases_subst_instance_constr : +Lemma erases_subst_instance : forall Σ : global_env_ext, wf_ext_wk Σ -> forall Γ, wf_local Σ Γ -> forall t T, Σ ;;; Γ |- t : T -> forall t' u univs, - wf_local (Σ.1, univs) (PCUICUnivSubst.subst_instance_context u Γ) -> + wf_local (Σ.1, univs) (subst_instance u Γ) -> sub_context_set (monomorphic_udecl Σ.2) (global_ext_context_set (Σ.1, univs)) -> consistent_instance_ext (Σ.1,univs) (Σ.2) u -> Σ ;;; Γ |- t ⇝ℇ t' -> - (Σ.1,univs) ;;; (PCUICUnivSubst.subst_instance_context u Γ) |- PCUICUnivSubst.subst_instance_constr u t ⇝ℇ t'. + (Σ.1,univs) ;;; (subst_instance u Γ) |- subst_instance u t ⇝ℇ t'. Proof. intros Σ X Γ X0 t T X1 t' u univs X2 H H0 H1. - unshelve eapply (erases_subst_instance_constr0 Σ _ Γ _ _ _); tea; eauto. + unshelve eapply (erases_subst_instance0 Σ _ Γ _ _ _); tea; eauto. Qed. Lemma erases_subst_instance'' Σ φ Γ t T u univs t' : @@ -347,11 +304,11 @@ Lemma erases_subst_instance'' Σ φ Γ t T u univs t' : sub_context_set (monomorphic_udecl univs) (global_context_set Σ) -> consistent_instance_ext (Σ, φ) univs u -> (Σ, univs) ;;; Γ |- t ⇝ℇ t' -> - (Σ, φ) ;;; subst_instance_context u Γ - |- subst_instance_constr u t ⇝ℇ t'. + (Σ, φ) ;;; subst_instance u Γ + |- subst_instance u t ⇝ℇ t'. Proof. intros X X0 X1. intros. - eapply (erases_subst_instance_constr (Σ, univs)); tas. + eapply (erases_subst_instance (Σ, univs)); tas. eapply typing_wf_local; eassumption. eauto. eapply typing_wf_local. eapply typing_subst_instance''; eauto. @@ -364,8 +321,8 @@ Lemma erases_subst_instance_decl Σ Γ t T c decl u t' : (Σ.1, universes_decl_of_decl decl) ;;; Γ |- t : T -> consistent_instance_ext Σ (universes_decl_of_decl decl) u -> (Σ.1, universes_decl_of_decl decl) ;;; Γ |- t ⇝ℇ t' -> - Σ ;;; subst_instance_context u Γ - |- subst_instance_constr u t ⇝ℇ t'. + Σ ;;; subst_instance u Γ + |- subst_instance u t ⇝ℇ t'. Proof. destruct Σ as [Σ φ]. intros X X0 X1 X2. eapply erases_subst_instance''; tea. split; tas. @@ -456,7 +413,7 @@ Lemma is_construct_erases Σ Γ t t' : Proof. induction 1; cbn; try congruence. - unfold isConstruct_app in *. clear IHerases2. - cbn. rewrite PCUICInductives.fst_decompose_app_rec. + cbn. rewrite PCUICAstUtils.fst_decompose_app_rec. unfold EisConstruct_app in *. cbn. rewrite fst_decompose_app_rec. eassumption. Qed. @@ -467,21 +424,21 @@ Lemma is_FixApp_erases Σ Γ t t' : Proof. induction 1; cbn; try congruence. - unfold isFixApp in *. clear IHerases2. - cbn. rewrite PCUICInductives.fst_decompose_app_rec. + cbn. rewrite PCUICAstUtils.fst_decompose_app_rec. unfold Ee.isFixApp in *. cbn. rewrite fst_decompose_app_rec. eassumption. Qed. Lemma type_closed_subst {Σ t T} u : wf_ext Σ -> Σ ;;; [] |- t : T -> - PCUICLiftSubst.subst1 t 0 u = PCUICCSubst.csubst t 0 u. + subst1 t 0 u = PCUICCSubst.csubst t 0 u. Proof. intros wfΣ tc. apply PCUICClosed.subject_closed in tc; auto. rewrite PCUICCSubst.closed_subst; auto. Qed. -Lemma erases_closed Σ Γ a e : PCUICLiftSubst.closedn #|Γ| a -> Σ ;;; Γ |- a ⇝ℇ e -> closedn #|Γ| e. +Lemma erases_closed Σ Γ a e : PCUICAst.closedn #|Γ| a -> Σ ;;; Γ |- a ⇝ℇ e -> ELiftSubst.closedn #|Γ| e. Proof. remember #|Γ| as Γl eqn:Heq. intros cla era. @@ -494,16 +451,17 @@ Proof. simpl; try solve [solve_all]. - now apply Nat.ltb_lt. - apply andb_and. split; eauto. - - apply andb_and; split; eauto. - - eapply andb_and; split; eauto. + todo "case". + (* apply andb_and; split; eauto. *) + (* - eapply andb_and; split; eauto. solve_all. destruct y ; simpl in *; subst. - unfold test_snd. simpl; eauto. - - epose proof (All2_length _ _ X0). + unfold test_snd. simpl; eauto. *) + - epose proof (All2_length X0). solve_all. destruct y ; simpl in *; subst. unfold EAst.test_def; simpl; eauto. rewrite <-H. rewrite fix_context_length in b0. eapply b0. eauto. now rewrite app_length fix_context_length. - - epose proof (All2_length _ _ X0). + - epose proof (All2_length X0). solve_all. destruct y ; simpl in *; subst. unfold EAst.test_def; simpl; eauto. rewrite <-H. rewrite fix_context_length in b0. @@ -546,8 +504,8 @@ Lemma Is_proof_app {Σ Γ t args ty} {wfΣ : wf_ext Σ} : Proof. intros [ty' [u [Hty [isp pu]]]] Htargs. eapply PCUICValidity.inversion_mkApps in Htargs as [A [Ht sp]]. - pose proof (PCUICValidity.validity_term wfΣ Hty). - pose proof (PCUICValidity.validity_term wfΣ 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; eauto. edestruct (sort_typing_spine _ _ _ u _ _ _ pu sp) as [u' [Hty' isp']]. @@ -596,24 +554,24 @@ Proof. eapply PCUICValidity.inversion_mkApps in HT as (? & ? & ?); auto. eapply inversion_Construct in t as (? & ? & ? & ? & ? & ? & ?); auto. pose proof d as [decli ?]. pose proof decli as [-> ->]. - destruct (on_declared_constructor wfΣ d). + destruct (on_declared_constructor d). destruct p as [onind oib]. rewrite oib.(ind_arity_eq). rewrite !destArity_it_mkProd_or_LetIn /=. eapply PCUICSpine.typing_spine_strengthen in t0; eauto. unfold type_of_constructor in t0. destruct s0 as [indctors [nthcs onc]]. - rewrite [x2.1.2]onc.(cstr_eq) in t0. - rewrite !subst_instance_constr_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn in t0. + rewrite onc.(cstr_eq) in t0. + rewrite !subst_instance_it_mkProd_or_LetIn !PCUICLiftSubst.subst_it_mkProd_or_LetIn in t0. len in t0. rewrite subst_cstr_concl_head in t0. destruct decli. eapply nth_error_Some_length in H1; eauto. rewrite -it_mkProd_or_LetIn_app in t0. eapply PCUICElimination.typing_spine_proofs in Ts; eauto. destruct Ts as [_ Hs]. - specialize (Hs _ _ (proj1 d) oib c) as [Hs _]. - specialize (Hs isp). subst s. move: isp. change (ind_sort oib) with (ind_sort oib) in *. - now destruct (ind_sort oib). + specialize (Hs _ _ d c) as [Hs _]. + specialize (Hs isp). subst s. move: isp. + now destruct (ind_sort x1). Qed. Lemma nisErasable_Propositional {Σ : global_env_ext} {Γ ind n u} : @@ -627,24 +585,24 @@ Proof. eapply inversion_Construct in HT' as (? & ? & ? & ? & ? & ? & ?); auto. pose proof (declared_constructor_valid_ty _ _ _ _ _ _ _ _ wfΣ a d c). pose proof d as [decli ?]. - destruct (on_declared_constructor wfΣ d). + destruct (on_declared_constructor d). destruct p as [onind oib]. red. rewrite (proj1 (proj1 d)) (proj2 (proj1 d)). rewrite oib.(ind_arity_eq). rewrite !destArity_it_mkProd_or_LetIn /=. - destruct (is_propositional (ind_sort oib)) eqn:isp; auto. + destruct (is_propositional (ind_sort x0)) eqn:isp; auto. elimtype False; eapply ise. red. eexists; intuition eauto. right. unfold type_of_constructor in c0, X. destruct s as [indctors [nthcs onc]]. - rewrite [x1.1.2]onc.(cstr_eq) in c0, X. - rewrite !subst_instance_constr_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn in c0, X. + rewrite onc.(cstr_eq) in c0, X. + rewrite !subst_instance_it_mkProd_or_LetIn !PCUICLiftSubst.subst_it_mkProd_or_LetIn in c0, X. len in c0; len in X. rewrite subst_cstr_concl_head in c0, X. destruct decli. eapply nth_error_Some_length in H1; eauto. rewrite -it_mkProd_or_LetIn_app in c0, X. - exists (subst_instance_univ u (ind_sort oib)). + exists (subst_instance_univ u (ind_sort x0)). rewrite is_propositional_subst_instance => //. split; auto. eapply cumul_propositional; eauto. @@ -652,14 +610,14 @@ Proof. eapply PCUICValidity.validity; eauto. destruct X as [cty ty]. eapply type_Cumul'; eauto. - eapply PCUICSpine.isType_Sort; pcuic. - destruct (ind_sort oib) => //. + eapply isType_Sort; pcuic. + destruct (ind_sort x0) => //. eapply PCUICSpine.inversion_it_mkProd_or_LetIn in ty; eauto. epose proof (typing_spine_proofs _ _ [] _ _ _ [] _ _ eq_refl wfΣ ty). forward H0 by constructor. eexists; eauto. simpl. reflexivity. destruct H0 as [_ sorts]. - specialize (sorts _ _ decli oib c) as [sorts sorts']. + specialize (sorts _ _ decli c) as [sorts sorts']. forward sorts' by constructor. do 2 constructor. rewrite is_propositional_subst_instance in sorts, sorts' |- *. @@ -667,8 +625,8 @@ Proof. Qed. Lemma isPropositional_propositional Σ Σ' ind mdecl idecl mdecl' idecl' : - PCUICTyping.declared_inductive Σ mdecl ind idecl -> - ETyping.declared_inductive Σ' mdecl' ind idecl' -> + PCUICAst.declared_inductive Σ ind mdecl idecl -> + ETyping.declared_inductive Σ' ind mdecl' idecl' -> erases_one_inductive_body idecl idecl' -> forall b, isPropositional Σ ind b -> is_propositional_ind Σ' ind = Some b. Proof. @@ -709,9 +667,9 @@ Proof. now eapply conv_cumul. auto. auto. } assert (eqs := type_closed_subst b wfΣ X0). invs Hvf'. - * assert (Σ;;; [] |- PCUICLiftSubst.subst1 a' 0 b ⇝ℇ subst1 vu' 0 t'). - eapply (erases_subst Σ [] [PCUICAst.vass na t] [] b [a'] t'); eauto. - econstructor. econstructor. rewrite parsubst_empty. eassumption. + * assert (Σ;;; [] |- PCUICAst.subst1 a' 0 b ⇝ℇ ELiftSubst.subst1 vu' 0 t'). + eapply (erases_subst Σ [] [vass na t] [] b [a'] t'); eauto. + econstructor. econstructor. rewrite PCUICLiftSubst.subst_empty. eassumption. rewrite eqs in H2. eapply IHeval3 in H2 as (v' & Hv' & [He_v']). -- exists v'. split; eauto. @@ -727,11 +685,11 @@ Proof. assumption. * exists EAst.tBox. split. eapply Is_type_lambda in X1; eauto. destruct X1. econstructor. - eapply (is_type_subst Σ [] [PCUICAst.vass na _] [] _ [a']) in X1 ; auto. + eapply (is_type_subst Σ [] [vass na _] [] _ [a']) in X1 ; auto. cbn in X1. eapply Is_type_eval; try assumption. eauto. eapply H1. rewrite <-eqs. eassumption. - all: eauto. econstructor. econstructor. rewrite parsubst_empty. + all: eauto. econstructor. econstructor. rewrite PCUICLiftSubst.subst_empty. eauto. constructor. econstructor. eauto. eauto. * auto. + exists EAst.tBox. split. 2:constructor; econstructor; eauto. @@ -744,7 +702,7 @@ Proof. invs He. + depelim Hed. eapply IHeval1 in H6 as (vt1' & Hvt2' & [He_vt1']); eauto. - assert (Hc : PCUICContextConversion.conv_context Σ ([],, vdef na b0 t) [vdef na b0' t]). { + assert (Hc : conv_context Σ ([],, vdef na b0 t) [vdef na b0' t]). { econstructor. econstructor. econstructor. reflexivity. eapply PCUICCumulativity.red_conv. now eapply wcbeval_red; eauto. @@ -754,12 +712,12 @@ Proof. cbn in *. eapply PCUICContextConversion.context_conversion. 3:eauto. all:cbn; eauto. econstructor. all: cbn; eauto. eapply subject_reduction_eval; auto. eauto. eauto. } - assert (Σ;;; [] |- PCUICLiftSubst.subst1 b0' 0 b1 ⇝ℇ subst1 vt1' 0 t2'). { - eapply (erases_subst Σ [] [PCUICAst.vdef na b0' t] [] b1 [b0'] t2'); eauto. - enough (subslet Σ [] [PCUICLiftSubst.subst [] 0 b0'] [vdef na b0' t]). - now rewrite parsubst_empty in X1. + assert (Σ;;; [] |- subst1 b0' 0 b1 ⇝ℇ ELiftSubst.subst1 vt1' 0 t2'). { + eapply (erases_subst Σ [] [vdef na b0' t] [] b1 [b0'] t2'); eauto. + enough (subslet Σ [] [subst [] 0 b0'] [vdef na b0' t]). + now rewrite PCUICLiftSubst.subst_empty in X1. econstructor. econstructor. - rewrite !parsubst_empty. + rewrite !PCUICLiftSubst.subst_empty. eapply subject_reduction_eval; eauto. eapply erases_context_conversion. 3:eassumption. all: cbn; eauto. @@ -772,7 +730,7 @@ Proof. eapply IHeval2 in H1 as (vres & Hvres & [Hty_vres]); [| |now eauto]. 2:{ rewrite <-eqs. eapply substitution_let; eauto. } exists vres. split. eauto. constructor; econstructor; eauto. - enough (ECSubst.csubst vt1' 0 t2' = t2' {0 := vt1'}) as ->; auto. + enough (ECSubst.csubst vt1' 0 t2' = ELiftSubst.subst10 vt1' t2') as ->; auto. eapply ECSubst.closed_subst. eapply erases_closed in Hvt2'; auto. eapply eval_closed. eauto. 2:eauto. now eapply PCUICClosed.subject_closed in t1. + exists EAst.tBox. split. 2:constructor; econstructor; eauto. @@ -810,8 +768,9 @@ Proof. eapply axfree in isdecl. congruence. - assert (Hty' := Hty). - assert (Σ |-p tCase (ind, pars) p discr brs ▷ res) by eauto. - eapply inversion_Case in Hty' as [u' [args' [mdecl [idecl [ps [pty [btys + assert (Σ |-p tCase ci p discr brs ▷ res) by eauto. + todo "case". + (*eapply inversion_Case in Hty' as [u' [args' [mdecl [idecl [ps [pty [btys [? [? [? [? [? [_ [? [ht0 [? ?]]]]]]]]]]]]]]]]; auto. assert (Σ ;;; [] |- mkApps (tConstruct ind c u) args : mkApps (tInd ind u') args'). eapply subject_reduction_eval; eauto. @@ -989,7 +948,7 @@ Proof. enough (#|skipn (ind_npars mdecl) args| = n) as <- by eauto. rewrite skipn_length; lia. + exists EAst.tBox. split. econstructor. - eapply Is_type_eval; eauto. constructor. econstructor; eauto. + eapply Is_type_eval; eauto. constructor. econstructor; eauto.*) - pose (Hty' := Hty). eapply inversion_Proj in Hty' as (? & ? & ? & [] & ? & ? & ? & ? & ?); [|easy]. @@ -1116,9 +1075,9 @@ Proof. pose proof (closed_fix_substl_subst_eq (PCUICClosed.subject_closed _ t1) e0) as cls. destruct x3. cbn in *. subst. - enough (Σ;;; [] ,,, PCUICLiftSubst.subst_context (fix_subst mfix) 0 [] - |- PCUICLiftSubst.subst (fix_subst mfix) 0 dbody - ⇝ℇ subst (ETyping.fix_subst mfix') 0 (Extract.E.dbody x4)). + enough (Σ;;; [] ,,, subst_context (fix_subst mfix) 0 [] + |- subst (fix_subst mfix) 0 dbody + ⇝ℇ ELiftSubst.subst (ETyping.fix_subst mfix') 0 (Extract.E.dbody x4)). destruct p. destruct p. clear e3. rename H into e3. @@ -1148,7 +1107,7 @@ Proof. simpl in vfix. subst. unfold is_constructor. rewrite nth_error_snoc. lia. - assert(Σ ;;; [] |- mkApps (tFix mfix idx) (argsv ++ [av]) : PCUICLiftSubst.subst [av] 0 x1). + assert(Σ ;;; [] |- mkApps (tFix mfix idx) (argsv ++ [av]) : subst [av] 0 x1). { rewrite -mkApps_nested. eapply PCUICValidity.type_App'; eauto. eapply subject_reduction_eval; eauto. } epose proof (fix_app_is_constructor Σ (args:=argsv ++ [av]) axfree X). @@ -1178,8 +1137,8 @@ Proof. now rewrite (Forall2_length H4). } eapply eval_closed in e3; eauto. clear -e3 Hmfix'. - pose proof (All2_length _ _ Hmfix'). - eapply PCUICClosed.closedn_mkApps_inv in e3. + pose proof (All2_length Hmfix'). + rewrite closedn_mkApps in e3. apply andb_true_iff in e3 as (e3 & _). change (?a = true) with (is_true a) in e3. simpl in e3 |- *. solve_all. @@ -1198,7 +1157,7 @@ Proof. ++ auto. -- cbn. destruct p. destruct p. - eapply (erases_subst Σ [] (PCUICLiftSubst.fix_context mfix) [] dbody (fix_subst mfix)) in e3; cbn; eauto. + eapply (erases_subst Σ [] (fix_context mfix) [] dbody (fix_subst mfix)) in e3; cbn; eauto. ++ eapply subslet_fix_subst. now eapply wf_ext_wf. all: eassumption. ++ eapply nth_error_all in a1; eauto. cbn in a1. eapply a1. @@ -1292,8 +1251,8 @@ Proof. ++ rewrite mkApps_snoc. eapply PCUICValidity.type_App'; eauto. - - destruct ip. - assert (Hty' := Hty). + - todo "case". + (*assert (Hty' := Hty). eapply inversion_Case in Hty' as [u' [args' [mdecl [idecl [ps [pty [btys [? [? [? [? [? [_ [? [ht0 [? ?]]]]]]]]]]]]]]]]; eauto. @@ -1303,7 +1262,7 @@ Proof. eapply inversion_CoFix in t1; destruct_sigma t1; auto. eapply PCUICSpine.typing_spine_strengthen in t2; eauto. assert(Hty' := Hty). - assert(clcof : PCUICLiftSubst.closedn 0 (tCoFix mfix idx)). + assert(clcof : PCUICAst.closedn 0 (tCoFix mfix idx)). { eapply PCUICClosed.subject_closed in Hty; eauto. } eapply subject_reduction in Hty'. 2:auto. 2:{ eapply PCUICReduction.red1_red. eapply PCUICReduction.red_cofix_case. eauto. @@ -1341,7 +1300,7 @@ Proof. assert (e' := e). move: e'. rewrite -closed_unfold_cofix_cunfold_eq // /unfold_cofix e2. intros [= <- Heq]. - eapply (erases_subst Σ [] (PCUICLiftSubst.fix_context mfix) [] (dbody decl) (cofix_subst mfix) _ (ETyping.cofix_subst mfix')) in er'; cbn; eauto. + eapply (erases_subst Σ [] (fix_context mfix) [] (dbody decl) (cofix_subst mfix) _ (ETyping.cofix_subst mfix')) in er'; cbn; eauto. 2:{ eapply subslet_cofix_subst; eauto. constructor; eauto. } simpl in er'. rewrite Heq in er'. 3:{ eapply All2_from_nth_error. @@ -1390,14 +1349,14 @@ Proof. eapply PCUICReduction.red1_red. eapply PCUICReduction.red_cofix_case. move: e. rewrite -closed_unfold_cofix_cunfold_eq // /unfold_cofix e2. - intros e; eapply e. + intros e; eapply e.*) - assert (Hty' := Hty). eapply inversion_Proj in Hty' as (? & ? & ? & [] & ? & ? & ? & ? & ?); auto. set (t0' := t0). eapply PCUICValidity.inversion_mkApps in t0' as (? & ? & ?); eauto. pose proof (PCUICClosed.subject_closed wfΣ t0) as clfix. - assert(clcof : PCUICLiftSubst.closedn 0 (tCoFix mfix idx)). + assert(clcof : PCUICAst.closedn 0 (tCoFix mfix idx)). { eapply PCUICClosed.subject_closed in t1; eauto. } eapply inversion_CoFix in t1; destruct_sigma t1; auto. eapply PCUICSpine.typing_spine_strengthen in t2; eauto. @@ -1447,7 +1406,7 @@ Proof. assert (e' := e). move: e'. rewrite -closed_unfold_cofix_cunfold_eq // /unfold_cofix e1. intros [= <- Heq]. - eapply (erases_subst Σ [] (PCUICLiftSubst.fix_context mfix) [] (dbody decl) (cofix_subst mfix) _ (ETyping.cofix_subst mfix')) in er; cbn; eauto. + eapply (erases_subst Σ [] (fix_context mfix) [] (dbody decl) (cofix_subst mfix) _ (ETyping.cofix_subst mfix')) in er; cbn; eauto. 2:{ eapply subslet_cofix_subst; eauto. constructor; eauto. } simpl in er. rewrite Heq in er. 3:{ eapply All2_from_nth_error. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 31429f511..5878c1eb4 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -174,9 +174,9 @@ Section fix_sigma. constructor. etransitivity; eauto. - eapply PCUICContextRelation.context_change_decl_types_red; eauto. + eapply PCUICRedTypeIrrelevance.context_pres_let_bodies_red; eauto. constructor; [|constructor]. - eapply PCUICContextRelation.context_relation_refl. + eapply PCUICContextRelation.All2_fold_refl. reflexivity. Qed. @@ -203,7 +203,7 @@ Local Ltac sq := - it represents a proof: its sort is Prop. *) -Program Definition is_erasable (Σ : PCUICAst.global_env_ext) (HΣ : ∥wf_ext Σ∥) (Γ : context) (t : PCUICAst.term) (Ht : welltyped Σ Γ t) : +Program Definition is_erasable (Σ : global_env_ext) (HΣ : ∥wf_ext Σ∥) (Γ : context) (t : PCUICAst.term) (Ht : welltyped Σ Γ t) : ({∥isErasable Σ Γ t∥} + {∥(isErasable Σ Γ t -> False)∥}) := let T := @type_of extraction_checker_flags Σ _ _ Γ t Ht in let b := is_arity Σ _ Γ _ T _ in @@ -339,30 +339,36 @@ Section Erase. | _ => try red; try reflexivity || discriminates end. - Lemma welltyped_brs Γ ind t1 t2 brs : welltyped Σ Γ (tCase ind t1 t2 brs) -> - Forall (fun x => welltyped Σ Γ x.2) brs. + Lemma welltyped_brs Γ ci t1 t2 brs : welltyped Σ Γ (tCase ci t1 t2 brs) -> + Forall (fun x => welltyped Σ (Γ ,,, bcontext x) (bbody x)) brs. Proof. intros [t Ht]. destruct HΣ. - eapply inversion_Case in Ht as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); auto. + todo "case". + (* eapply inversion_Case in Ht as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); auto. simpl in *. clear e2. induction a. constructor. intuition auto. constructor; auto. - eexists; eauto. + eexists; eauto. *) Qed. Section EraseMfix. Context (erase : forall (Γ : context) (t : term) (Ht : welltyped Σ Γ t), E.term). Definition erase_mfix Γ (defs : mfixpoint term) - (H : forall d, In d defs -> welltyped Σ (Γ ,,, PCUICLiftSubst.fix_context defs) d.(dbody)) : EAst.mfixpoint E.term := - let Γ' := (PCUICLiftSubst.fix_context defs ++ Γ)%list in + (H : forall d, In d defs -> welltyped Σ (Γ ,,, fix_context defs) d.(dbody)) : EAst.mfixpoint E.term := + let Γ' := (fix_context defs ++ Γ)%list in map_InP (fun d wt => let dbody' := erase Γ' d.(dbody) wt in ({| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |})) defs H. - Definition erase_brs Γ (brs : list (nat * term)) - (H : forall d, In d brs -> welltyped Σ Γ d.2) : list (nat * E.term) := - map_InP (fun br wt => let br' := erase Γ br.2 wt in (br.1, br')) brs H. + (** We should expand lets in bcontext here, after erasing. + We have access to general substitution still so it shoundn't be too hard. + Alternatively we erase to the "old" case representation for now + *) + Definition erase_brs Γ (brs : list (branch term)) + (H : forall d, In d brs -> welltyped Σ (Γ ,,, bcontext d) (bbody d)) : list (nat * E.term) := + map_InP (fun br wt => let br' := erase (Γ ,,, bcontext br) (bbody br) wt in + (#|br.(bcontext)|, br')) brs H. End EraseMfix. @@ -396,10 +402,10 @@ Section Erase. let f' := erase Γ f _ in let l' := erase Γ u _ in E.tApp f' l'; - erase Γ (tCase ip p c brs) Ht _ with erase Γ c _ := + erase Γ (tCase ci p c brs) Ht _ with erase Γ c _ := { | c' := let brs' := erase_brs erase Γ brs _ in - E.tCase ip c' brs' } ; + E.tCase (ci.(ci_ind), ci.(ci_npar)) c' brs' } ; erase Γ (tProj p c) Ht _ := let c' := erase Γ c _ in E.tProj p c' ; @@ -426,12 +432,13 @@ Section Erase. eexists; eauto. - eapply inversion_App in Ht as (? & ? & ? & ? & ? & ?); auto. eexists; eauto. - - eapply inversion_Case in Ht as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); auto. + - eapply inversion_Case in Ht as (? & ? & ? & ? & [] & ?); auto. eexists; eauto. - - apply inversion_Case in Ht as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); auto. - simpl in *. - eapply All2_In in a as [(x' & (? & ?) & ?)]; eauto. - simpl in *. subst. eexists; eauto. + - apply inversion_Case in Ht as (? & ? & ? & ? & [] & ?); auto. + apply In_nth_error in H as (?&nth). + eapply All2i_nth_error_r in nth; eauto. + destruct nth as (?&?&(?&?)&?&?); cbn in *. + econstructor; tea. - clear wildcard12. eapply inversion_Proj in Ht as (? & ? & ? & ? & ? & ? & ? & ? & ?); auto. eexists; eauto. @@ -532,7 +539,7 @@ Proof. forall (wt : welltyped Σ Γ t) (wfΣ' : ∥ wf_ext Σ ∥), Σ;;; Γ |- t ⇝ℇ erase Σ wfΣ' Γ t wt ) - (fun Σ Γ wfΓ => wf_local Σ Γ)); intros; auto; clear Σ w; rename Σ0 into Σ. + (fun Σ Γ => wf_local Σ Γ)); intros; auto; clear Σ w; rename Σ0 into Σ. 10:{ simpl erase. destruct is_erasable. simp erase. sq. @@ -545,12 +552,14 @@ Proof. intros isp. eapply isErasable_Proof in isp. eauto. eapply H4. unfold erase_brs. eapply All2_from_nth_error. now autorewrite with len. - intros. eapply All2_nth_error_Some in X3; eauto. + intros. + todo "case". + (* eapply All2_nth_error_Some in X3; eauto. destruct X3 as [t' [htnh eq]]. eapply nth_error_map_InP in H8. destruct H8 as [a [Hnth [p' eq']]]. subst. simpl. rewrite Hnth in H7. noconf H7. - intuition auto. } + intuition auto.*) } all:simpl erase; eauto. @@ -626,7 +635,7 @@ Qed. Definition erase_one_inductive_body (oib : one_inductive_body) : E.one_inductive_body := (* Projection and constructor types are types, hence always erased *) - let ctors := map (A:=(ident * term) * nat) (fun '((x, y), z) => (x, z)) oib.(ind_ctors) in + let ctors := map (fun cdecl => (cdecl.(cstr_name), cdecl.(cstr_arity))) oib.(ind_ctors) in let projs := map (fun '(x, y) => x) oib.(ind_projs) in let is_propositional := match destArity [] oib.(ind_type) with @@ -765,14 +774,16 @@ Proof. eapply KernameSet.singleton_spec in hin; subst. destruct d as [[H' _] _]. red in H'. simpl in *. red. sq. rewrite H'. intuition eauto. - - apply inversion_Case in wt + - todo "case". + (* apply inversion_Case in wt as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); eauto. destruct ind as [kn i']; simpl in *. eapply KernameSet.singleton_spec in H1; subst. destruct d as [d _]. red in d. - simpl in *. eexists; intuition eauto. + simpl in *. eexists; intuition eauto.*) - - apply inversion_Case in wt + - todo "case". + (* apply inversion_Case in wt as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); eauto. eapply knset_in_fold_left in H1. destruct H1. eapply IHer; eauto. @@ -786,7 +797,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. @@ -843,7 +854,8 @@ Proof. now econstructor; eauto. destruct H as [mib [mib' [declm declm']]]. red in declm, d. rewrite d in declm. noconf declm. - - apply inversion_Case in wt + - todo "case". + (* apply inversion_Case in wt as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); eauto. destruct ind as [kn i']; simpl in *. apply includes_deps_fold in H2 as [? ?]. @@ -868,7 +880,7 @@ Proof. simpl. intuition auto. eexists ; eauto. ELiftSubst.solve_all. destruct a2 as [T' HT]. eauto. simpl. - destruct d. red in H7, declm. rewrite H7 in declm. now noconf declm. + destruct d. red in H7, declm. rewrite H7 in declm. now noconf declm. *) - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?); eauto. destruct (proj1 d). @@ -1059,9 +1071,9 @@ Proof. simpl in H. noconf H. set (obl :=(erase_constant_body_obligation_1 Σ wfΣ {| - PA.cst_type := name; - PA.cst_body := Some bod; - PA.cst_universes := univs |} onc bod eq_refl)). clearbody obl. + cst_type := name; + cst_body := Some bod; + cst_universes := univs |} onc bod eq_refl)). clearbody obl. destruct obl. sq. exists bod, A; intuition auto. simpl. eapply erases_erase. now simpl in H. @@ -1075,17 +1087,18 @@ Proof. destruct m; constructor; simpl; auto. eapply on_declared_minductive in H; auto. simpl in H. clear X. eapply onInductives in H; simpl in *. - assert (Alli (fun i oib => match destArity [] oib.(ind_type) with Some _ => True | None => False end) 0 ind_bodies). + 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. rewrite !destArity_it_mkProd_or_LetIn /= //. } clear H. induction X; constructor; auto. destruct hd; constructor; simpl; auto. clear. - induction ind_ctors; constructor; auto. - destruct a as [[? ?] ?]; constructor; auto. + induction ind_ctors0; constructor; auto. + cbn in *. intuition auto. - induction ind_projs; constructor; auto. + induction ind_projs0; constructor; auto. destruct a; auto. unfold isPropositionalArity. destruct destArity as [[? ?]|] eqn:da; auto. diff --git a/erasure/theories/Extract.v b/erasure/theories/Extract.v index e01c1868b..5e5e21215 100644 --- a/erasure/theories/Extract.v +++ b/erasure/theories/Extract.v @@ -67,15 +67,15 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop : | erases_tConstruct : forall (kn : inductive) (k : nat) (n : Instance.t), isPropositional Σ kn false -> Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k - | erases_tCase1 : forall (ind : inductive) (npar : nat) (T c : term) - (brs : list (nat × term)) (c' : E.term) + | erases_tCase1 : forall (ci : case_info) (T : predicate term) (c : term) + (brs : list (branch term)) (c' : E.term) (brs' : list (nat × E.term)), - Informative Σ ind -> + Informative Σ ci.(ci_ind) -> Σ;;; Γ |- c ⇝ℇ c' -> All2 - (fun (x : nat × term) (x' : nat × E.term) => - Σ;;; Γ |- snd x ⇝ℇ snd x' × fst x = fst x') brs brs' -> - Σ;;; Γ |- tCase (ind, npar) T c brs ⇝ℇ E.tCase (ind, npar) c' brs' + (fun (x : branch term) (x' : nat × E.term) => + Σ;;; Γ ,,, bcontext x |- bbody x ⇝ℇ snd x' × #|bcontext x| = fst x') brs brs' -> + Σ;;; Γ |- tCase ci T c brs ⇝ℇ E.tCase (ci.(ci_ind), ci.(ci_npar)) c' brs' | erases_tProj : forall (p : (inductive × nat) × nat) (c : term) (c' : E.term), let ind := fst (fst p) in Informative Σ ind -> @@ -85,7 +85,7 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop : (fun (d : def term) (d' : E.def E.term) => d.(dname).(binder_name) = E.dname d' × rarg d = E.rarg d' - × Σ;;; Γ ,,, PCUICLiftSubst.fix_context mfix |- + × Σ;;; Γ ,,, fix_context mfix |- dbody d ⇝ℇ E.dbody d') mfix mfix' -> Σ;;; Γ |- tFix mfix n ⇝ℇ E.tFix mfix' n | erases_tCoFix : forall (mfix : mfixpoint term) (n : nat) (mfix' : list (E.def E.term)), @@ -93,7 +93,7 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop : (fun (d : def term) (d' : E.def E.term) => d.(dname).(binder_name) = E.dname d' × rarg d = E.rarg d' - × Σ;;; Γ ,,, PCUICLiftSubst.fix_context mfix |- + × Σ;;; Γ ,,, fix_context mfix |- dbody d ⇝ℇ E.dbody d') mfix mfix' -> Σ;;; Γ |- tCoFix mfix n ⇝ℇ E.tCoFix mfix' n | erases_box : forall t : term, isErasable Σ Γ t -> Σ;;; Γ |- t ⇝ℇ E.tBox where "Σ ;;; Γ |- s ⇝ℇ t" := (erases Σ Γ s t). @@ -126,13 +126,13 @@ Lemma erases_forall_list_ind (Hconstruct : forall Γ kn k n, isPropositional Σ kn false -> P Γ (tConstruct kn k n) (E.tConstruct kn k)) - (Hcase : forall Γ ind npar T c brs c' brs', - PCUICElimination.Informative Σ ind -> + (Hcase : forall Γ ci T c brs c' brs', + PCUICElimination.Informative Σ ci.(ci_ind) -> Σ;;; Γ |- c ⇝ℇ c' -> P Γ c c' -> - All2 (fun x x' => Σ;;; Γ |- x.2 ⇝ℇ x'.2 × x.1 = x'.1) brs brs' -> - Forall2 (fun br br' => P Γ br.2 br'.2) brs brs' -> - P Γ (tCase (ind, npar) T c brs) (E.tCase (ind, npar) c' brs')) + All2 (fun x x' => Σ;;; Γ ,,, bcontext x |- bbody x ⇝ℇ x'.2 × #|bcontext x| = x'.1) brs brs' -> + Forall2 (fun br br' => P (Γ ,,, bcontext br) (bbody br) br'.2) brs brs' -> + P Γ (tCase ci T c brs) (E.tCase (ci.(ci_ind), ci.(ci_npar)) c' brs')) (Hproj : forall Γ p c c', let ind := p.1.1 in PCUICElimination.Informative Σ ind -> @@ -144,10 +144,10 @@ Lemma erases_forall_list_ind (fun d d' => (dname d).(binder_name) = E.dname d' × rarg d = E.rarg d' × - Σ;;; app_context Γ (PCUICLiftSubst.fix_context mfix) |- dbody d ⇝ℇ E.dbody d') + Σ;;; app_context Γ (fix_context mfix) |- dbody d ⇝ℇ E.dbody d') mfix mfix' -> Forall2 (fun d d' => - P (app_context Γ (PCUICLiftSubst.fix_context mfix)) + P (app_context Γ (fix_context mfix)) (dbody d) (EAst.dbody d') ) mfix mfix' -> P Γ (tFix mfix n) (E.tFix mfix' n)) @@ -156,10 +156,10 @@ Lemma erases_forall_list_ind (fun d d' => (dname d).(binder_name) = E.dname d' × rarg d = E.rarg d' × - Σ;;; app_context Γ (PCUICLiftSubst.fix_context mfix) |- dbody d ⇝ℇ E.dbody d') + Σ;;; app_context Γ (fix_context mfix) |- dbody d ⇝ℇ E.dbody d') mfix mfix' -> Forall2 (fun d d' => - P (app_context Γ (PCUICLiftSubst.fix_context mfix)) + P (app_context Γ (fix_context mfix)) (dbody d) (EAst.dbody d') ) mfix mfix' -> P Γ (tCoFix mfix n) (E.tCoFix mfix' n)) @@ -213,7 +213,7 @@ Definition erases_constant_body (Σ : global_env_ext) (cb : constant_body) (cb' end. Definition erases_one_inductive_body (oib : one_inductive_body) (oib' : E.one_inductive_body) := - Forall2 (fun '((i,t), n) '(i', n') => n = n' /\ i = i') oib.(ind_ctors) oib'.(E.ind_ctors) /\ + Forall2 (fun cdecl '(i', n') => cdecl.(cstr_arity) = n' /\ cdecl.(cstr_name) = i') oib.(ind_ctors) oib'.(E.ind_ctors) /\ Forall2 (fun '(i,t) i' => i = i') oib.(ind_projs) oib'.(E.ind_projs) /\ oib'.(E.ind_name) = oib.(ind_name) /\ oib'.(E.ind_kelim) = oib.(ind_kelim) /\ @@ -260,7 +260,7 @@ Inductive erases_deps (Σ : global_env) (Σ' : E.global_declarations) : E.term - erases_deps Σ Σ' arg -> erases_deps Σ Σ' (E.tApp hd arg) | erases_deps_tConst kn cb cb' : - PCUICTyping.declared_constant Σ kn cb -> + declared_constant Σ kn cb -> ETyping.declared_constant Σ' kn cb' -> erases_constant_body (Σ, cst_universes cb) cb cb' -> (forall body, E.cst_body cb' = Some body -> erases_deps Σ Σ' body) -> @@ -268,15 +268,15 @@ Inductive erases_deps (Σ : global_env) (Σ' : E.global_declarations) : E.term - | erases_deps_tConstruct ind c : erases_deps Σ Σ' (E.tConstruct ind c) | erases_deps_tCase p mdecl idecl mdecl' idecl' discr brs : - PCUICTyping.declared_inductive Σ mdecl (fst p) idecl -> - ETyping.declared_inductive Σ' mdecl' (fst p) idecl' -> + declared_inductive Σ (fst p) mdecl idecl -> + ETyping.declared_inductive Σ' (fst p) mdecl' idecl' -> erases_one_inductive_body idecl idecl' -> erases_deps Σ Σ' discr -> Forall (fun br => erases_deps Σ Σ' br.2) brs -> erases_deps Σ Σ' (E.tCase p discr brs) | erases_deps_tProj p mdecl idecl mdecl' idecl' t : - PCUICTyping.declared_inductive Σ mdecl p.1.1 idecl -> - ETyping.declared_inductive Σ' mdecl' p.1.1 idecl' -> + declared_inductive Σ p.1.1 mdecl idecl -> + ETyping.declared_inductive Σ' p.1.1 mdecl' idecl' -> erases_one_inductive_body idecl idecl' -> erases_deps Σ Σ' t -> erases_deps Σ Σ' (E.tProj p t) diff --git a/erasure/theories/Prelim.v b/erasure/theories/Prelim.v index 3746e7034..1c82ee259 100644 --- a/erasure/theories/Prelim.v +++ b/erasure/theories/Prelim.v @@ -312,11 +312,11 @@ Qed. Lemma subslet_fix_subst `{cf : checker_flags} Σ mfix1 T n : wf Σ.1 -> Σ ;;; [] |- tFix mfix1 n : T -> - (* wf_local Σ (PCUICLiftSubst.fix_context mfix1) -> *) - subslet Σ [] (fix_subst mfix1) (PCUICLiftSubst.fix_context mfix1). + (* wf_local Σ (fix_context mfix1) -> *) + subslet Σ [] (fix_subst mfix1) (fix_context mfix1). Proof. intro hΣ. - unfold fix_subst, PCUICLiftSubst.fix_context. + unfold fix_subst, fix_context. assert (exists L, mfix1 = mfix1 ++ L) by (exists []; now simpl_list). revert H. generalize mfix1 at 2 5 6. intros. induction mfix0 using rev_ind. @@ -359,10 +359,10 @@ Qed. Lemma subslet_cofix_subst `{cf : checker_flags} Σ mfix1 T n : wf Σ.1 -> Σ ;;; [] |- tCoFix mfix1 n : T -> - subslet Σ [] (cofix_subst mfix1) (PCUICLiftSubst.fix_context mfix1). + subslet Σ [] (cofix_subst mfix1) (fix_context mfix1). Proof. intro hΣ. - unfold cofix_subst, PCUICLiftSubst.fix_context. + unfold cofix_subst, fix_context. assert (exists L, mfix1 = mfix1 ++ L)%list by (exists []; now simpl_list). revert H. generalize mfix1 at 2 5 6. intros. induction mfix0 using rev_ind. @@ -380,21 +380,21 @@ Qed. (** ** Prelim on typing *) -Inductive red_decls Σ Γ Γ' : forall (x y : PCUICAst.context_decl), Type := +Inductive red_decls Σ Γ Γ' : forall (x y : context_decl), Type := | conv_vass na na' T T' : isType Σ Γ' T' -> red Σ Γ T T' -> eq_binder_annot na na' -> - red_decls Σ Γ Γ' (PCUICAst.vass na T) (PCUICAst.vass na' T') + red_decls Σ Γ Γ' (vass na T) (vass na' T') | conv_vdef_type na na' b T T' : isType Σ Γ' T' -> red Σ Γ T T' -> eq_binder_annot na na' -> - red_decls Σ Γ Γ' (PCUICAst.vdef na b T) (PCUICAst.vdef na' b T') + red_decls Σ Γ Γ' (vdef na b T) (vdef na' b T') | conv_vdef_body na na' b b' T : isType Σ Γ' T -> eq_binder_annot na na' -> Σ ;;; Γ' |- b' : T -> red Σ Γ b b' -> - red_decls Σ Γ Γ' (PCUICAst.vdef na b T) (PCUICAst.vdef na' b' T). + red_decls Σ Γ Γ' (vdef na b T) (vdef na' b' T). -Notation red_context Σ := (context_relation (red_decls Σ)). +Notation red_context Σ := (All2_fold (red_decls Σ)). Lemma conv_context_app (Σ : global_env_ext) (Γ1 Γ2 Γ1' : context) : wf Σ -> diff --git a/examples/add_constructor.v b/examples/add_constructor.v index 8884f7a87..c7b5e2d5c 100644 --- a/examples/add_constructor.v +++ b/examples/add_constructor.v @@ -29,6 +29,25 @@ Fixpoint try_remove_n_lambdas (n : nat) (t : term) {struct n} : term := (* [add_ctor] add a constructor to a [mutual_inductive_body] (that is a reified declaration of an inductive). *) +Definition tsl_constructor_body (c : constructor_body) : constructor_body := + {| cstr_name := tsl_ident c.(cstr_name); + cstr_args := cstr_args c; + cstr_indices := cstr_indices c; + cstr_type := cstr_type c; + cstr_arity := cstr_arity c |}. + +Definition remove_last_n {A} (l : list A) (n : nat) : list A := + firstn (#|l| - n) l. + +Definition new_cstr mdecl (idc : ident) (ctor : term) : constructor_body := + let '(args, concl) := decompose_prod_assum [] ctor in + let (hd, indices) := decompose_app concl in + {| cstr_name := idc; + cstr_args := remove_last_n args #|mdecl.(ind_params)|; + cstr_indices := skipn mdecl.(ind_npars) indices; + cstr_type := ctor; + cstr_arity := context_assumptions args |}. + Polymorphic Definition add_ctor (mind : mutual_inductive_body) (ind0 : inductive) (idc : ident) (ctor : term) : mutual_inductive_body := let i0 := inductive_ind ind0 in @@ -38,18 +57,20 @@ Polymorphic Definition add_ctor (mind : mutual_inductive_body) (ind0 : inductive ind_variance := mind.(ind_variance); ind_params := mind.(ind_params); ind_bodies := mapi (fun (i : nat) (ind : one_inductive_body) => - {| ind_name := tsl_ident ind.(ind_name) ; - ind_type := ind.(ind_type) ; - ind_kelim := ind.(ind_kelim) ; - ind_ctors := let ctors := map (fun '(id, t, k) => (tsl_ident id, t, k)) ind.(ind_ctors) in - if Nat.eqb i i0 then - let n := #|ind_bodies mind| in - let typ := try_remove_n_lambdas n ctor in - ctors ++ [(idc, typ, 0)] (* fixme 0 *) - else ctors; - ind_projs := ind.(ind_projs); - ind_relevance := ind.(ind_relevance) |}) - mind.(ind_bodies) |}. + {| ind_name := tsl_ident ind.(ind_name) ; + ind_indices := ind.(ind_indices); + ind_sort := ind.(ind_sort); + ind_type := ind.(ind_type) ; + ind_kelim := ind.(ind_kelim) ; + ind_ctors := let ctors := map tsl_constructor_body ind.(ind_ctors) in + if Nat.eqb i i0 then + let n := #|ind_bodies mind| in + let typ := try_remove_n_lambdas n ctor in + ctors ++ [new_cstr mind idc typ] + else ctors; + ind_projs := ind.(ind_projs); + ind_relevance := ind.(ind_relevance) |}) + mind.(ind_bodies) |}. (* [add_constructor] is a new command (in Template Coq style) *) @@ -77,6 +98,7 @@ MetaCoq Run ( (* | false' : bool' *) (* | foo : nat -> bool' -> bool -> bool' *) Definition test := bool'. +Definition test' : nat -> bool' -> bool -> bool' := foo. (** Here is a useful usecase: add a case to a syntax. *) Inductive tm := diff --git a/examples/metacoq_tour.v b/examples/metacoq_tour.v index 7231d35ed..a2bd2aca8 100644 --- a/examples/metacoq_tour.v +++ b/examples/metacoq_tour.v @@ -93,7 +93,7 @@ MetaCoq SafeCheck (fun x : nat => x + 1). (** Erasure *) (** Running erasure live in Coq *) -Definition test (p : Ast.program) : string := +Definition test (p : Ast.Env.program) : string := erase_and_print_template_program p. MetaCoq Quote Recursively Definition zero := 0. diff --git a/examples/tauto.v b/examples/tauto.v index 98ad48d66..121450b5a 100644 --- a/examples/tauto.v +++ b/examples/tauto.v @@ -559,7 +559,19 @@ Qed. 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. - +Definition decl_size (size : term -> nat) (x : context_decl) := + size (decl_type x) + option_default size (decl_body x) 0. + +Definition context_size (size : term -> nat) (l : context) := + list_size (decl_size size) l. + +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) + + size p.(preturn). + Fixpoint tsize t : nat := match t with | tRel i => 1 @@ -568,7 +580,7 @@ Fixpoint tsize t : nat := | tApp u v => S (tsize u + list_size tsize v) | tProd na A B => S (tsize A + tsize B) | tLetIn na b t b' => S (tsize b + tsize t + tsize b') - | tCase ind p c brs => S (tsize p + tsize c + list_size (fun x => tsize (snd x)) brs) + | tCase ind p c brs => S (predicate_size tsize p + tsize c + list_size (branch_size tsize) brs) | tProj p c => S (tsize c) | tFix mfix idx => S (mfixpoint_size tsize mfix) | tCoFix mfix idx => S (mfixpoint_size tsize mfix) @@ -640,10 +652,14 @@ Proof. induction H. + reflexivity. + simpl. eauto. - - rewrite IHt1, IHt2. f_equal. f_equal. - induction X. - + reflexivity. - + simpl. eauto. + - solve_all. + f_equal; auto. f_equal; eauto. + f_equal; eauto. unfold predicate_size. + f_equal; simpl; auto. + induction a; simpl; auto. + induction X0; simpl; auto. + f_equal; auto. f_equal; auto. + unfold branch_size; simpl; auto. - generalize (#|m| + k). intro p. induction X. + reflexivity. @@ -717,10 +733,15 @@ Proof. * simpl. reflexivity. + clear - H3. destruct l. contradiction. discriminate. - - f_equal. rewrite IHt1, IHt2 by assumption. f_equal. - clear - X H5. induction X. - * reflexivity. - * inversion H5. subst. simpl. intuition eauto. + - f_equal. + f_equal; solve_all. + unfold predicate_size. simpl. f_equal; auto. + f_equal; auto. induction H3; simpl; auto. + destruct p. f_equal. f_equal; auto. + unfold branch_size. + clear h H4 H5. + induction H6; simpl; auto. + destruct p. f_equal; auto. - f_equal. generalize (#|m| + k). intro p. clear - X H0. induction X. @@ -745,7 +766,6 @@ Local Ltac inst := specialize (h k) end. - Lemma tsize_downlift_le : forall t k, tsize (subst [tRel 0] k t) <= tsize t. @@ -773,15 +793,20 @@ Proof. } lia. - repeat inst. + assert ( - list_size (fun x : nat × term => tsize x.2) - (map (on_snd (subst [tRel 0] k)) l) - <= list_size (fun x : nat × term => tsize x.2) l + list_size (branch_size tsize) (map_branches_k (subst [tRel 0]) k l) + <= list_size (branch_size tsize) l ). - { clear - X. induction X. + { unfold branch_size. + clear - X0. induction X0. - reflexivity. - simpl. inst. lia. - } + } + assert (predicate_size tsize (map_predicate id (subst [tRel 0] k) (subst [tRel 0] (#|pcontext t| + k)) t) <= + predicate_size tsize t). + { apply plus_le_compat; simpl; auto. 2:apply X. destruct X. + induction a; simpl; auto. apply le_n_S, plus_le_compat; simpl; auto. } lia. - eapply le_n_S. generalize (#|m| + k). intro p. @@ -869,7 +894,7 @@ Equations reify (Σ : global_env_ext) (Γ : context) (P : term) : option form }} ; | tProd na A B => af <- reify Σ Γ A ;; - bf <- reify Σ Γ (subst0 [tRel 0] B) ;; + bf <- reify Σ Γ (subst [tRel 0] 0 B) ;; ret (Imp af bf) ; | _ => None } diff --git a/pcuic/_CoqProject.in b/pcuic/_CoqProject.in index a78d52b8f..980ff4888 100644 --- a/pcuic/_CoqProject.in +++ b/pcuic/_CoqProject.in @@ -9,6 +9,9 @@ theories/PCUICInduction.v theories/PCUICReflect.v theories/PCUICLiftSubst.v theories/PCUICUnivSubst.v +theories/PCUICCases.v +theories/PCUICContextSubst.v +theories/PCUICReduction.v theories/PCUICTyping.v theories/PCUICGlobalEnv.v theories/PCUICInversion.v @@ -16,13 +19,17 @@ theories/PCUICPosition.v theories/PCUICNormal.v theories/PCUICNameless.v theories/PCUICEquality.v +theories/PCUICEqualityDec.v theories/PCUICWeakeningEnv.v theories/PCUICClosed.v +theories/PCUICOnFreeVars.v +theories/PCUICRename.v +theories/PCUICInst.v theories/PCUICWeakening.v theories/PCUICUnivSubstitution.v theories/PCUICSubstitution.v +theories/PCUICContextReduction.v theories/PCUICCumulativity.v -theories/PCUICReduction.v theories/PCUICParallelReduction.v theories/PCUICParallelReductionConfluence.v theories/PCUICConfluence.v @@ -30,9 +37,9 @@ theories/PCUICContextRelation.v theories/PCUICContextConversion.v theories/PCUICConversion.v theories/PCUICConvCumInversion.v +theories/PCUICRedTypeIrrelevance.v theories/PCUICGeneration.v theories/PCUICAlpha.v -theories/PCUICCtxShape.v theories/PCUICContexts.v theories/PCUICArities.v theories/PCUICWfUniverses.v diff --git a/pcuic/theories/PCUICAlpha.v b/pcuic/theories/PCUICAlpha.v index d0161dca0..428bb01fe 100644 --- a/pcuic/theories/PCUICAlpha.v +++ b/pcuic/theories/PCUICAlpha.v @@ -1,74 +1,36 @@ (* Distributed under the terms of the MIT license. *) +From Coq Require Import ssreflect CRelationClasses CMorphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICTyping PCUICWeakening PCUICCumulativity PCUICEquality - PCUICContextConversion PCUICValidity. + PCUICConversion PCUICContextConversion PCUICValidity PCUICArities PCUICSpine + PCUICInductives PCUICInductiveInversion. +From Equations Require Import Equations. + +(* Alpha convertible terms and contexts have the same typings *) + +Implicit Types cf : checker_flags. + +Notation "`≡α`" := upto_names. +Infix "≡α" := upto_names (at level 60). +Notation "`≡Γ`" := (eq_context_upto [] eq eq). +Infix "≡Γ" := (eq_context_upto [] eq eq) (at level 20, no associativity). + +Instance upto_names_terms_refl : CRelationClasses.Reflexive (All2 `≡α`). +Proof. intro; apply All2_refl; reflexivity. Qed. + +Lemma eq_context_upto_empty_impl {cf} {Σ : global_env_ext} ctx ctx' : + ctx ≡Γ ctx' -> + eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) ctx ctx'. +Proof. + intros; eapply All2_fold_impl; tea. + intros ???? []; constructor; subst; auto; + eapply eq_term_upto_univ_empty_impl; tea; tc. +Qed. Section Alpha. Context {cf:checker_flags}. - Lemma build_branches_type_eq_term : - forall Σ p p' ind mdecl idecl pars u brtys, - eq_term_upto_univ Σ eq eq p p' -> - map_option_out - (build_branches_type ind mdecl idecl pars u p) = - Some brtys -> - ∑ brtys', - map_option_out - (build_branches_type ind mdecl idecl pars u p') = - Some brtys' × - All2 (on_Trel_eq (eq_term_upto_univ Σ eq eq) snd fst) brtys brtys'. - Proof. - intros Σ p p' ind mdecl idecl pars u brtys e hb. - unfold build_branches_type in *. - destruct idecl as [ina ity ike ict ipr]. simpl in *. - unfold mapi in *. revert hb. - generalize 0 at 3 6. - intros n hb. - induction ict in brtys, n, hb |- *. - - cbn in *. eexists. split. - + eassumption. - + apply All2_same. intros [m t]. simpl. split ; now auto. - - cbn. cbn in hb. - lazymatch type of hb with - | match ?t with _ => _ end = _ => - case_eq (t) ; - try (intro bot ; rewrite bot in hb ; discriminate hb) - end. - intros [m t] e'. rewrite e' in hb. - destruct a as [[na ta] ar]. - lazymatch type of e' with - | match ?expr with _ => _ end = _ => - case_eq (expr) ; - try (intro bot ; rewrite bot in e' ; discriminate e') - end. - intros ty ety. rewrite ety in e'. - case_eq (decompose_prod_assum [] ty). intros sign ccl edty. - rewrite edty in e'. - case_eq (chop (ind_npars mdecl) (snd (decompose_app ccl))). - intros paramrels args ech. rewrite ech in e'. - inversion e'. subst. clear e'. - lazymatch type of hb with - | match ?t with _ => _ end = _ => - case_eq (t) ; - try (intro bot ; rewrite bot in hb ; discriminate hb) - end. - intros tl etl. rewrite etl in hb. - inversion hb. subst. clear hb. - edestruct IHict as [brtys' [eq' he]]. - + eauto. - + eexists. rewrite eq'. split. - * reflexivity. - * constructor ; auto. - simpl. split ; auto. - eapply eq_term_upto_univ_it_mkProd_or_LetIn ; auto. - eapply eq_term_upto_univ_mkApps. - -- eapply eq_term_upto_univ_lift. - eapply eq_term_eq_term_napp; eauto. - typeclasses eauto. - -- apply All2_same. intro. apply eq_term_upto_univ_refl ; auto. - Qed. - (* TODO MOVE *) Lemma wf_local_nth_error_vass : forall Σ Γ i na ty, @@ -93,7 +55,6 @@ Section Alpha. destruct IHi as [s h]. + inversion hΓ. all: auto. + exists s. - unfold PCUICTerm.tSort. (* TODO Why do I have to do this? *) change (tSort s) with (lift0 1 (lift0 (S i) (tSort s))). rewrite simpl_lift0. eapply PCUICWeakening.weakening with (Γ' := [ c ]). @@ -123,23 +84,11 @@ Section Alpha. nth_error (Γ ,,, Δ) i = Some d. Proof. intros Γ Δ i d h. - rewrite nth_error_app_context_lt. + rewrite -> nth_error_app_context_lt. - assumption. - apply nth_error_Some_length in h. assumption. Qed. - (* TODO MOVE *) - Lemma Forall2_eq : - forall A (l l' : list A), - Forall2 eq l l' -> - l = l'. - Proof. - intros A l l' h. - induction h. - - reflexivity. - - f_equal. all: auto. - Qed. - Lemma decompose_app_upto {Σ Re Rle x y hd tl} : eq_term_upto_univ Σ Re Rle x y -> decompose_app x = (hd, tl) -> @@ -158,27 +107,17 @@ Section Alpha. inv eqh; simpl in *; try discriminate; auto. Qed. - Lemma All2_trans' {A B C} - (P : A -> B -> Type) (Q : B -> C -> Type) (R : A -> C -> Type) - (H : forall x y z, P x y × Q y z -> R x z) {l1 l2 l3} - : All2 P l1 l2 -> All2 Q l2 l3 -> All2 R l1 l3. - Proof. - induction 1 in l3 |- *. - - inversion 1; constructor. - - inversion 1; subst. constructor; eauto. - Qed. - Lemma decompose_prod_assum_upto_names' ctx ctx' x y : - eq_context_upto [] eq eq ctx ctx' -> upto_names' x y -> + ctx ≡Γ ctx' -> upto_names' x y -> let (ctx0, x0) := decompose_prod_assum ctx x in let (ctx1, x1) := decompose_prod_assum ctx' y in - eq_context_upto [] eq eq ctx0 ctx1 * upto_names' x0 x1. + ctx0 ≡Γ ctx1 * upto_names' x0 x1. Proof. induction x in ctx, ctx', y |- *; intros eqctx eqt; inv eqt; simpl; try split; auto; try constructor; auto. - specialize (IHx2 (ctx,, vass na x1) (ctx',,vass na' a') b'). - apply IHx2; auto. constructor; auto. - - apply IHx3; auto. constructor; auto. + apply IHx2; auto. constructor; auto; constructor; auto. + - apply IHx3; auto. constructor; auto; constructor; auto. Qed. Lemma destInd_spec t : @@ -234,7 +173,7 @@ Section Alpha. Lemma upto_names_check_cofix mfix mfix' : All2 (fun x y : def term => - (upto_names' (dtype x) (dtype y) × upto_names' (dbody x) (dbody y)) + (dtype x ≡α dtype y × dbody x ≡α dbody y) × rarg x = rarg y) mfix mfix' -> map check_one_cofix mfix = map check_one_cofix mfix'. Proof. @@ -258,6 +197,167 @@ Section Alpha. destruct X as [-> _]; auto. Qed. + Lemma conv_context_app {Σ : global_env_ext} {wfΣ : wf Σ} (Γ1 Γ2 Γ2' : context) : + conv_context_rel Σ Γ1 Γ2 Γ2' -> conv_context Σ (Γ1 ,,, Γ2) (Γ1 ,,, Γ2'). + Proof. + intros wf. + eapply All2_fold_app. apply (length_of wf). + apply conv_ctx_refl. + eapply All2_fold_impl; tea. intros ???? []; constructor; auto. + Qed. + + Lemma eq_context_upto_conv_context_rel {Σ : global_env_ext} {wfΣ : wf Σ} (Γ Δ Δ' : context) : + Δ ≡Γ Δ' -> + conv_context_rel Σ Γ Δ Δ'. + Proof. + intros eq. + eapply All2_fold_impl; tea. + intros ???? []; constructor; auto; now constructor; apply upto_names_impl_eq_term. + Qed. + + Lemma eq_context_upto_map2_set_binder_name Σ pctx pctx' Γ Δ : + pctx ≡Γ pctx' -> + eq_context_upto Σ eq eq Γ Δ -> + eq_context_upto Σ eq eq + (map2 set_binder_name (forget_types pctx) Γ) + (map2 set_binder_name (forget_types pctx') Δ). + Proof. + intros eqp. + induction 1 in pctx, pctx', eqp |- *. + - induction eqp; cbn; constructor. + - depelim eqp. simpl. constructor. + simpl. constructor; auto. + destruct c, p; constructor; auto. + Qed. + + Lemma eq_context_upto_lift_context Σ Re Rle : + RelationClasses.subrelation Re Rle -> + forall u v n k, + eq_context_upto Σ Re Rle u v -> + eq_context_upto Σ Re Rle (lift_context n k u) (lift_context n k v). + Proof. + intros re u v n k. + induction 1. + - constructor. + - rewrite !lift_context_snoc; constructor; eauto. + depelim p; constructor; simpl; intuition auto; + rewrite -(length_of X); + apply eq_term_upto_univ_lift; auto. + Qed. + + Lemma eq_context_upto_subst_instance Σ : + forall u v i, + valid_constraints (global_ext_constraints Σ) + (subst_instance_cstrs i Σ) -> + eq_context_upto Σ eq eq u v -> + eq_context_upto Σ eq eq (subst_instance i u) (subst_instance i v). + Proof. + intros u v i vc. + induction 1. + - constructor. + - rewrite !PCUICUnivSubst.subst_instance_cons. constructor; eauto. + depelim p; constructor; simpl; intuition auto. + eapply (PCUICUnivSubstitution.eq_term_upto_univ_subst_preserved Σ (fun _ => eq) (fun _ => eq)). + intros x y u v ? ? ->; reflexivity. + intros x y u v ? ? ->; reflexivity. exact vc. + assumption. + eapply (PCUICUnivSubstitution.eq_term_upto_univ_subst_preserved Σ (fun _ => eq) (fun _ => eq)). + intros x y u v ? ? ->; reflexivity. + intros x y u v ? ? ->; reflexivity. exact vc. + assumption. + eapply (PCUICUnivSubstitution.eq_term_upto_univ_subst_preserved Σ (fun _ => eq) (fun _ => eq)). + intros x y u v ? ? ->; reflexivity. + intros x y u v ? ? ->; reflexivity. exact vc. + assumption. + Qed. + + Lemma case_predicate_context_equiv ind mdecl idecl p p' : + eq_predicate upto_names' eq p p' -> + eq_context_upto [] eq eq + (case_predicate_context ind mdecl idecl p) + (case_predicate_context ind mdecl idecl p'). + Proof. + intros [eqpars [eqinst [eqctx eqret]]]. + rewrite /case_predicate_context /case_predicate_context_gen. + apply eq_context_upto_map2_set_binder_name => //. + rewrite /pre_case_predicate_context_gen. + eapply R_universe_instance_eq in eqinst. rewrite -eqinst. + constructor. + - apply eq_context_upto_subst_context; tea; tc. + reflexivity. + now apply All2_rev. + - constructor; simpl; try reflexivity. + eapply eq_term_upto_univ_mkApps. reflexivity. + apply All2_app; [|reflexivity]. + eapply All2_map. eapply (All2_impl eqpars). + intros. now eapply eq_term_upto_univ_lift. + Qed. + + Lemma case_branch_context_equiv ind mdecl p p' bctx bctx' cdecl : + eq_predicate upto_names' eq p p' -> + bctx ≡Γ bctx' -> + (case_branch_context ind mdecl p (forget_types bctx) cdecl) ≡Γ + (case_branch_context ind mdecl p' (forget_types bctx') cdecl). + Proof. + intros [eqpars [eqinst [eqctx eqret]]] eqctx'. + eapply R_universe_instance_eq in eqinst. + rewrite /case_branch_context /case_branch_context_gen -eqinst. + apply eq_context_upto_subst_context. tc. + 2:now eapply All2_rev. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + apply eq_context_upto_subst_context. tc. + 2:eapply All2_refl; reflexivity. + eapply eq_context_upto_lift_context. tc. + apply eq_context_upto_subst_context. tc. + 2:eapply All2_refl; reflexivity. + eapply (eq_context_upto_subst_instance (empty_ext [])). + apply valid_constraints_empty. + simpl. apply All2_fold_All2. + eapply All2_fold_All2 in eqctx'. + generalize (cstr_args cdecl). + induction eqctx'. + * simpl. constructor. + * simpl. intros []. constructor. + constructor; auto. + destruct r, c as [na'' [b''|] ty']; constructor; auto; try reflexivity. + Qed. + + Lemma case_branch_type_equiv (Σ : global_env_ext) ind mdecl idecl p p' br br' c cdecl : + eq_predicate upto_names' eq p p' -> + bcontext br ≡Γ bcontext br' -> + let ptm := it_mkLambda_or_LetIn (pcontext p) (preturn p) in + let ptm' := it_mkLambda_or_LetIn (pcontext p') (preturn p') in + eq_term Σ Σ + (case_branch_type ind mdecl idecl p br ptm c cdecl).2 + (case_branch_type ind mdecl idecl p' br' ptm' c cdecl).2. + Proof. + intros [eqpars [eqinst [eqctx eqret]]] eqctx'. + eapply R_universe_instance_eq in eqinst. + intros ptm ptm'. + rewrite /case_branch_type /case_branch_type_gen -eqinst. cbn. + eapply eq_term_mkApps. + - eapply eq_term_upto_univ_lift. + rewrite /ptm /ptm'. + eapply eq_term_upto_univ_it_mkLambda_or_LetIn. tc. + eapply eq_context_upto_empty_impl; tea. + eapply eq_term_upto_univ_empty_impl; tea; tc. + - eapply All2_app. + * eapply All2_map, All2_refl. + intros. + eapply eq_term_upto_univ_empty_impl; tea; tc. + eapply eq_term_upto_univ_substs. tc. + reflexivity. + now eapply All2_rev. + * constructor. 2:constructor. + eapply eq_term_upto_univ_empty_impl; tea; tc. + eapply eq_term_upto_univ_mkApps. len. + reflexivity. + eapply All2_app. + + eapply All2_map. eapply (All2_impl eqpars). + intros. now eapply eq_term_upto_univ_lift. + + eapply All2_refl. reflexivity. + Qed. + Lemma typing_alpha : forall Σ Γ u v A, wf Σ.1 -> @@ -270,11 +370,47 @@ Section Alpha. forall v, eq_term_upto_univ [] eq eq u v -> Σ ;;; Γ |- v : A) - (fun Σ Γ wfΓ => wf_local Σ Γ) + (fun Σ Γ => + forall Γ' Δ Δ', + Γ = Γ' ,,, Δ -> + Δ ≡Γ Δ' -> + wf_local Σ (Γ' ,,, Δ')) ). eapply typing_ind_env. all: intros Σ wfΣ Γ wfΓ. - - auto. + - induction 1. + * intros Γ' Δ Δ' eq H; destruct Δ; noconf eq; depelim H; constructor. + * intros Γ' Δ Δ' eq H; destruct Δ; noconf eq; depelim H. + + constructor; auto. + + depelim c. simpl; constructor; auto. eapply IHX; eauto. + destruct tu as [s Hs]. + exists s. simpl in p. + eapply context_conversion. + { eapply p; eauto. } + { eapply IHX; eauto. } + now eapply conv_context_app, eq_context_upto_conv_context_rel. + * intros Γ' Δ Δ' eq H; destruct Δ; noconf eq; depelim H. + { constructor; auto. } + depelim c. simpl; constructor; auto. eapply IHX; eauto. + + destruct tu as [s Hs]. + exists s. simpl in p. + eapply context_conversion. + { eapply p0; eauto. } + { eapply IHX; eauto. } + { now eapply conv_context_app, eq_context_upto_conv_context_rel. } + + red. + specialize (p0 _ e1). + specialize (p _ e0). + eapply context_conversion in p0; revgoals. + { eapply conv_context_app, eq_context_upto_conv_context_rel; tea. } + eauto. + eapply context_conversion in p; revgoals. + { eapply conv_context_app, eq_context_upto_conv_context_rel; tea. } + { eapply IHX; eauto. } + eapply type_Cumul'; eauto. + now exists tu.π1. + constructor. now eapply eq_term_leq_term, upto_names_impl_eq_term. + - intros n decl hnth ih v e; invs e. eapply type_Rel ; eassumption. - intros l ih hl v e; invs e. @@ -302,9 +438,8 @@ Section Alpha. ++ apply conv_ctx_refl ; auto. ++ constructor. assumption. constructor. eapply upto_names_impl_eq_term. assumption. - + eapply validity in hB as [? hB]; eauto. - econstructor; eauto. - econstructor ; eauto with pcuic. + + eapply validity in hB;tea. + eapply isType_tProd; eauto. split; eauto with pcuic. + constructor. eapply eq_term_leq_term. apply eq_term_sym. @@ -340,7 +475,7 @@ Section Alpha. now apply upto_names_impl_eq_term. constructor. now apply upto_names_impl_eq_term. - + eapply validity_term ; eauto. + + eapply validity ; eauto. econstructor ; eauto. + constructor. eapply eq_term_leq_term. @@ -356,7 +491,7 @@ Section Alpha. all:typeclasses eauto. * eapply ihu. assumption. * eapply hty. - + eapply validity_term ; eauto. + + eapply validity ; eauto. econstructor ; eauto. + constructor. eapply eq_term_leq_term. @@ -364,60 +499,151 @@ Section Alpha. eapply upto_names_impl_eq_term. eapply eq_term_upto_univ_subst ; now auto. - intros cst u decl ? ? hdecl hcons v e; invs e. - apply Forall2_eq in H2. apply map_inj in H2 ; revgoals. - { apply Universe.make_inj. } - subst. - constructor ; auto. + eapply R_universe_instance_eq in H2. subst. + constructor; eauto. - intros ind u mdecl idecl isdecl ? ? hcons v e; invs e. - apply Forall2_eq in H2. apply map_inj in H2 ; revgoals. - { apply Universe.make_inj. } - subst. + eapply R_universe_instance_eq in H2. subst. econstructor ; eauto. - intros ind i u mdecl idecl cdecl isdecl ? ? ? v e; invs e. - apply Forall2_eq in H4. apply map_inj in H4 ; revgoals. - { apply Universe.make_inj. } - subst. + eapply R_universe_instance_eq in H4. subst. econstructor ; eauto. - - intros ind u npar p c brs args mdecl idecl isdecl X X0 H pars ps pty - Hcpt X1 X2 H1 H2 X3 X4 btys Hbbt Hbrs v e; invs e. - eapply type_Cumul'. - + eapply build_branches_type_eq_term in Hbbt; tea. - destruct Hbbt as [btys' [Hbbt1 Hbbt2]]. + - intros ind p c brs args ps mdecl idecl isdecl X X0 H cpc wfp + cup wfpctx convpctx Hret IHret + wfcpc kelim Hctxi IHctxi Hc IHc iscof ptm wfbrs Hbrs v e; invs e. + have eqp := X1. + destruct X1 as [eqpars [eqinst [eqctx eqret]]]. + assert (wf_predicate mdecl idecl p'). + { destruct wfp. split; auto. + { now rewrite <-(All2_length eqpars). } + eapply Forall2_All2 in H1. eapply All2_Forall2. + eapply All2_fold_All2 in eqctx. eapply All2_sym in eqctx. + eapply (All2_trans' (@eq_binder_annot name name)); tea. + 2:{ eapply All2_map; tea. eapply All2_impl; tea. + simpl; intros. destruct X1; simpl; now symmetry. } + simpl. intros x y [] []; etransitivity; tea. } + assert (conv_context Σ (Γ,,, cpc) (Γ,,, case_predicate_context ind mdecl idecl p')). + { eapply conv_context_app, eq_context_upto_conv_context_rel. + now eapply case_predicate_context_equiv. } + assert (conv_context Σ (Γ,,, pcontext p) (Γ,,, pcontext p')). + { eapply (eq_context_upto_conv_context_rel Γ) in eqctx; tea. + now apply conv_context_app. } + eapply R_universe_instance_eq in eqinst. + assert (isType Σ Γ (mkApps ptm (args ++ [c]))). + { eapply validity. econstructor; eauto. eapply wfpctx; eauto. + reflexivity. eapply wfcpc; eauto. reflexivity. + solve_all. eapply a0; eauto; reflexivity. + eapply b; eauto; reflexivity. } + eapply type_Cumul'; tea. + + have cu' : consistent_instance_ext Σ (ind_universes mdecl) (puinst p'). + { now rewrite -eqinst. } + have convctx' : conv_context Σ (Γ,,, pcontext p') + (Γ,,, case_predicate_context ind mdecl idecl p'). + { eapply conv_context_trans; tea. + eapply conv_context_trans; tea. + now eapply conv_context_sym. } + have ty' : Σ;;; Γ,,, pcontext p' |- preturn p' : tSort ps. + { eapply context_conversion; eauto. } + have wfcpc' : wf_local Σ (Γ,,, case_predicate_context ind mdecl idecl p'). + { eapply wfcpc. reflexivity. + rewrite /cpc. + now eapply case_predicate_context_equiv. } + have ctxinst' : ctx_inst Σ Γ (pparams p' ++ args) + (List.rev + (subst_instance (puinst p') (ind_params mdecl,,, ind_indices idecl))). + { rewrite -eqinst. + move: IHctxi => ctxi. + destruct eqp. + eapply ctx_inst_eq_context; tea. + rewrite List.rev_involutive. + * eapply weaken_wf_local; tea. + eapply (on_minductive_wf_params_indices_inst isdecl _ cup). + * eapply All2_app => //. apply All2_refl => //. reflexivity. } + have wfbrs' : wf_branches idecl brs'. + { move/Forall2_All2: wfbrs => wf. + apply All2_Forall2. eapply All2_trans'; tea. + intros cdecl br br'. + intros [wfbr [eqbrctx eqbodies]]. + rewrite /wf_branch. + red. do 2 red in wfbr. + eapply Forall2_All2 in wfbr. eapply All2_Forall2. + eapply All2_map_left. + eapply All2_fold_All2 in eqbrctx. + eapply All2_map_left_inv in wfbr. + eapply All2_trans'; tea. + 2:{ eapply All2_symP; tea. tc. } + intros ??? [[] ?]; try constructor; simpl; auto; now transitivity na'. } econstructor; tea; eauto. - unshelve eapply All2_trans'; [..|eassumption]. - * exact (fun br bty : nat × term => - (((br.1 = bty.1 × Σ;;; Γ |- br.2 : bty.2) - × (forall v : term, upto_names' br.2 v -> Σ;;; Γ |- v : bty.2)) - × ∑ s, Σ;;; Γ |- bty.2 : tSort s × - (forall v : term, upto_names' bty.2 v -> Σ;;; Γ |- v : tSort s))). - * clear. intros x y z X; rdest; cbn in *. - congruence. 2: eauto. econstructor; tea. - eauto. constructor. - now eapply upto_names_impl_leq_term. - * eapply All2_trans'; [..|eassumption]. - 2: apply All2_sym; tea. - clear. intros x y z X; rdest; cbn in *; eauto. congruence. - intros v H. unshelve eapply (upto_names_trans _ _ _ _) in H; tea. - eauto. + * eapply type_Cumul'. + eapply IHc; eauto. + eexists; eapply isType_mkApps_Ind; tea. + unshelve eapply (ctx_inst_spine_subst _ ctxinst'). + eapply weaken_wf_local; tea. + now eapply (on_minductive_wf_params_indices_inst isdecl). + eapply conv_cumul. rewrite -eqinst. + eapply mkApps_conv_args; trea. + eapply All2_app. + 2:{ eapply All2_refl; reflexivity. } + eapply (All2_impl eqpars). + intros. now constructor; eapply upto_names_impl_eq_term. + * eapply All2i_All2_mix_left in Hbrs; tea. + 2:now eapply Forall2_All2 in wfbrs. + epose proof (wf_case_branches_types (p:=p') ps args brs' isdecl). + forward X6. + eexists; eapply isType_mkApps_Ind; tea. + unshelve eapply (ctx_inst_spine_subst _ ctxinst'). + eapply weaken_wf_local; tea. + eapply (on_minductive_wf_params_indices_inst isdecl _ cu'). + specialize (X6 H0 ty' convctx' wfbrs'). + eapply All2i_All2_mix_left in X6; tea. + 2:now eapply Forall2_All2 in wfbrs'. + eapply (All2i_All2_All2i_All2i Hbrs X3 X6). + clear Hbrs X3 X6 wfbrs wfbrs'. + intros n cdecl br br' [wfbr [[IHbrctx Hbrctx] [[Hbbody IHcbc] [IHbbody [Hcbty IHcbty]]]]]. + intros [eqbrctxs eqbods] [wfbr' [wfcbc' brty']] brctxty. + have wfbrctx' : wf_local Σ (Γ,,, bcontext br'). + { eapply IHbrctx; [reflexivity|tas]. } + assert (cbreq := case_branch_context_equiv ind mdecl p p' (bcontext br) (bcontext br') cdecl eqp eqbrctxs). + have convbrctx' : conv_context Σ (Γ,,, bcontext br') (Γ,,, brctxty.1). + { eapply conv_context_trans; tea. + 2:{ rewrite /brctxty case_branch_type_fst. + eapply eq_context_upto_empty_conv_context. + eapply eq_context_upto_cat. reflexivity. + eassumption. } + eapply conv_context_trans. tea. 2:tea. + eapply conv_context_sym. tea. + eapply eq_context_upto_empty_conv_context. + eapply eq_context_upto_cat. reflexivity. eassumption. } + repeat splits => //. + { now eapply typing_wf_local in brty'. } + { eapply type_Cumul'. + * eapply context_conversion; tea. + eapply IHbbody => //. + eapply eq_context_upto_empty_conv_context. + apply eq_context_upto_cat. reflexivity. tas. + * eexists; red. + eapply context_conversion. + eapply brty'. assumption. + rewrite case_branch_type_fst. + now apply conv_context_sym. + * eapply conv_cumul. constructor. + rewrite /brctxty /ptm. + eapply case_branch_type_equiv => //. } + { eapply context_conversion. exact brty'. assumption. + now apply conv_context_sym. } + + + eapply conv_cumul, mkApps_conv_args; tea. + rewrite /ptm. + eapply it_mkLambda_or_LetIn_conv; tea. + now eapply conv_context_sym. + constructor. now eapply upto_names_impl_eq_term. + eapply All2_app. apply All2_refl; reflexivity. + constructor. constructor; now apply upto_names_impl_eq_term. constructor. - + eapply validity_term ; eauto. - instantiate (1 := tCase (ind, ind_npars mdecl) p c brs). - econstructor ; eauto. - solve_all. destruct b0 as [s [Hs IH]]; eauto. - + constructor. - eapply eq_term_leq_term. - apply eq_term_sym. - eapply eq_term_mkApps. - all: try (eapply upto_names_impl_eq_term ; assumption). - eapply All2_app. - * eapply All2_same. intro. eapply eq_term_refl. - * constructor ; eauto. - eapply upto_names_impl_eq_term. assumption. - intros p c u mdecl idecl pdecl isdecl args X X0 hc ihc H ty v e; invs e. eapply type_Cumul'. + econstructor. all: try eassumption. eapply ihc. assumption. - + eapply validity_term ; eauto. + + eapply validity ; eauto. econstructor ; eauto. + constructor. eapply eq_term_leq_term. @@ -446,19 +672,19 @@ Section Alpha. change (fix_context mfix') with (fix_context_gen 0 mfix'). eapply eq_context_upto_cat. * apply eq_context_upto_refl; typeclasses eauto. - * generalize 0. + * generalize 0 at 3 4. unfold fix_context_gen. eapply (All2_All_mix_left ihmfix) in X. clear -X. induction X; try constructor; simpl; intros n; auto. - destruct r as [[s [Hs IH]] [[[eqty eqann] eqbod] eqrarg]]. + destruct r as [[s [Hs IH]] [[[eqty eqbod] eqrarg] eqann]]. eapply eq_context_upto_cat. - + constructor; [assumption| |constructor]. + + constructor; constructor; auto. eapply eq_term_upto_univ_empty_impl; eauto. - 4:now eapply eq_term_upto_univ_lift. all:intros ? ? []; trivial. + 4:now eapply eq_term_upto_univ_lift. all:tc. + apply IHX. } assert(#|fix_context mfix| = #|fix_context mfix'|). - { now rewrite !fix_context_length, (All2_length _ _ X). } + { now rewrite !fix_context_length (All2_length X). } eapply type_Cumul'. + econstructor. * eapply (fix_guard_eq_term _ _ _ _ n); eauto. @@ -477,15 +703,13 @@ Section Alpha. eapply context_conversion; eauto. eapply (type_Cumul' (lift0 #|fix_context mfix| (dtype x))); auto. exists s. rewrite <-H. - eapply (weakening _ _ _ _ (tSort _)); eauto. now eapply typing_wf_local in b. + eapply (weakening _ _ _ _ (tSort _)); eauto. + eapply hwf; eauto. reflexivity. apply cumul_refl. rewrite <- H. eapply eq_term_upto_univ_lift. eapply eq_term_upto_univ_empty_impl. 4: intuition eauto. - all: intros ? ? []. - *** eapply eq_universe_refl. - *** eapply leq_universe_refl. - *** eapply leq_universe_refl. + all: intros ? ? []; reflexivity. * revert wffix. unfold wf_fixpoint. enough (map check_one_fix mfix = map check_one_fix mfix') as ->; auto. @@ -514,20 +738,20 @@ Section Alpha. change (fix_context mfix') with (fix_context_gen 0 mfix'). eapply eq_context_upto_cat. * apply eq_context_upto_refl; typeclasses eauto. - * generalize 0. + * generalize 0 at 3 4. unfold fix_context_gen. eapply (All2_All_mix_left ihmfix) in X. clear -X. induction X; try constructor; simpl; intros n; auto. destruct r as [[s [Hs IH]] [[[eqty eqann] eqbod] eqrarg]]. eapply eq_context_upto_cat. - + constructor; [assumption| |constructor]. + + constructor; constructor; tas. eapply eq_term_upto_univ_empty_impl. 4:now eapply eq_term_upto_univ_lift. all: intros ? ? []; reflexivity. + apply IHX. } assert(#|fix_context mfix| = #|fix_context mfix'|). - { now rewrite !fix_context_length, (All2_length _ _ X). } + { now rewrite !fix_context_length (All2_length X). } eapply type_Cumul'. + econstructor. * eapply (cofix_guard_eq_term _ _ _ _ n) ; eauto. @@ -546,7 +770,8 @@ Section Alpha. eapply context_conversion; eauto. eapply (type_Cumul' (lift0 #|fix_context mfix| (dtype x))); auto. exists s. rewrite <-H. - eapply (weakening _ _ _ _ (tSort _)); eauto. now eapply typing_wf_local in b. + eapply (weakening _ _ _ _ (tSort _)); eauto. + eapply hwf; eauto. reflexivity. apply cumul_refl. rewrite <- H. eapply eq_term_upto_univ_lift. eapply eq_term_upto_univ_empty_impl. @@ -574,91 +799,57 @@ Section Alpha. Lemma eq_term_upto_univ_napp_0 n t t' : eq_term_upto_univ_napp [] eq eq n t t' -> - upto_names' t t'. + t ≡α t'. Proof. apply eq_term_upto_univ_empty_impl; typeclasses eauto. Qed. - Lemma upto_names_eq_term_upto_univ Σ Re Rle napp t u - : eq_term_upto_univ_napp Σ Re Rle napp t u -> - forall t' u', t ≡ t' -> u ≡ u' -> - eq_term_upto_univ_napp Σ Re Rle napp t' u'. + Lemma upto_names_eq_term_refl Σ Re n t t' : + RelationClasses.Reflexive Re -> + t ≡α t' -> + eq_term_upto_univ_napp Σ Re Re n t t'. Proof. - revert napp t u Rle. fix aux 5. - destruct 1; cbn; intros t'' u'' H' H0'; - inv H'; inv H0'; try econstructor; eauto. - - revert args'0 args'1 X X0. - induction a; simpl; intros args0 args'0 H1 H2. - + inv H1; inv H2; constructor; eauto. - + inv H1; inv H2. constructor; eauto. - - apply eq_term_upto_univ_napp_0 in X. - apply eq_term_upto_univ_napp_0 in X3. - eapply aux; eauto. - - apply Forall2_eq, map_inj in H2. - apply Forall2_eq, map_inj in H3. - congruence. - all: apply Universe.make_inj. - - apply Forall2_eq, map_inj in H2. - apply Forall2_eq, map_inj in H3. - congruence. - all: apply Universe.make_inj. - - apply Forall2_eq, map_inj in H3. - apply Forall2_eq, map_inj in H4. - congruence. - all: apply Universe.make_inj. - - simpl. transitivity na'. - transitivity na; auto. - now symmetry. assumption. - - simpl. transitivity na'. - transitivity na; auto. - now symmetry. assumption. - - simpl. transitivity na'. - transitivity na; auto. - now symmetry. assumption. - - auto. revert brs'0 brs'1 X3 X6. - induction a; simpl; intros args0 args'0 H1 H2. - + inv H1; inv H2; constructor; eauto. - + inv H1; inv H2. constructor; eauto. - destruct X3, X7, r. split; eauto. congruence. - - revert mfix'0 mfix'1 X X0. - induction a; simpl; intros args0 args'0 H1 H2. - + inv H1; inv H2; constructor; eauto. - + inv H1; inv H2. constructor; eauto. - destruct X as [[[? ?] ?] ?], X1 as [[[? ?] ?] ?], r as [[[? ?] ?] ?]. - repeat split; eauto. congruence. - etransitivity. symmetry. apply e2. - etransitivity. eapply e10. assumption. - - revert mfix'0 mfix'1 X X0. - induction a; simpl; intros args0 args'0 H1 H2. - + inv H1; inv H2; constructor; eauto. - + inv H1; inv H2. constructor; eauto. - destruct X as [[[? ?] ?] ?], X1 as [[[? ?] ?] ?], r as [[[? ?] ?] ?]. - repeat split; eauto. congruence. - etransitivity. symmetry. apply e2. - etransitivity. eapply e10. assumption. + intros. + eapply eq_term_upto_univ_empty_impl; tea; tc. + all:intros x y ->; reflexivity. + Qed. + + Lemma upto_names_eq_term_upto_univ Σ Re Rle napp t u : + RelationClasses.Reflexive Re -> + RelationClasses.Reflexive Rle -> + RelationClasses.Symmetric Re -> + RelationClasses.Transitive Re -> + RelationClasses.Transitive Rle -> + RelationClasses.subrelation Re Rle -> + eq_term_upto_univ_napp Σ Re Rle napp t u -> + forall t' u', t ≡α t' -> u ≡α u' -> + eq_term_upto_univ_napp Σ Re Rle napp t' u'. + Proof. + intros. + eapply (upto_names_eq_term_refl Σ Re) in X0; tea. + eapply (upto_names_eq_term_refl Σ Re) in X1; tea. + symmetry in X0. + eapply eq_term_upto_univ_trans; tea. + eapply eq_term_upto_univ_impl; tea. reflexivity. reflexivity. + eapply eq_term_upto_univ_trans; tea. + eapply eq_term_upto_univ_impl; tea. reflexivity. reflexivity. Qed. Lemma upto_names_leq_term Σ φ t u t' u' - : t ≡ t' -> u ≡ u' -> leq_term Σ φ t u -> leq_term Σ φ t' u'. + : t ≡α t' -> u ≡α u' -> leq_term Σ φ t u -> leq_term Σ φ t' u'. Proof. - intros; eapply upto_names_eq_term_upto_univ; eassumption. + intros; eapply upto_names_eq_term_upto_univ; try eassumption; tc. Qed. Lemma upto_names_eq_term Σ φ t u t' u' - : t ≡ t' -> u ≡ u' -> eq_term Σ φ t u -> eq_term Σ φ t' u'. + : t ≡α t' -> u ≡α u' -> eq_term Σ φ t u -> eq_term Σ φ t' u'. Proof. - intros; eapply upto_names_eq_term_upto_univ; eassumption. + intros; eapply upto_names_eq_term_upto_univ; tea; tc. Qed. - Definition upto_names_decl := eq_decl_upto [] eq eq. - - Definition upto_names_ctx := eq_context_upto [] eq eq. - - Infix "≡Γ" := upto_names_ctx (at level 60). - Lemma destArity_alpha Γ u v ctx s : destArity Γ u = Some (ctx, s) -> - u ≡ v -> + u ≡α v -> ∑ ctx', destArity Γ v = Some (ctx', s) × ctx ≡Γ ctx'. Proof. induction u in v, Γ, ctx, s |- *; cbn; try discriminate. @@ -669,18 +860,19 @@ Section Alpha. intros [ctx' s'] e; rewrite e in X; cbn in X; inv X. destruct v; inv Y. eapply IHu2 in e; tea. destruct e as [ctx'' [e1 e2]]. - eexists; split. cbn. rewrite destArity_app, e1; reflexivity. + eexists; split. cbn. rewrite destArity_app e1; reflexivity. apply eq_context_upto_cat; tas. constructor; tas. reflexivity. + constructor; auto. - intros X Y. rewrite destArity_app in X. case_eq (destArity [] u3); [|intro e; rewrite e in X; discriminate]. intros [ctx' s'] e; rewrite e in X; cbn in X; inv X. destruct v; inv Y. eapply IHu3 in e; tea. destruct e as [ctx'' [e1 e2]]. - eexists; split. cbn. rewrite destArity_app, e1; reflexivity. + eexists; split. cbn. rewrite destArity_app e1; reflexivity. apply eq_context_upto_cat; tas. constructor; tas. reflexivity. + constructor; auto. Qed. - Lemma upto_names_conv_context (Σ : global_env_ext) Γ Δ : Γ ≡Γ Δ -> conv_context Σ Γ Δ. Proof. @@ -692,11 +884,11 @@ Section Alpha. Proof. intro hΣ. induction 1 in Γ' |- *. - intro Y; inv Y; constructor. - - intro Y; inv Y. constructor. auto. + - intro Y; inv Y. inv X1. constructor. auto. destruct t0 as [s Ht]. exists s. eapply typing_alpha; tea. eapply context_conversion; tea. auto. now apply upto_names_conv_context. - - intro Y; inv Y. constructor; auto. + - intro Y; inv Y. inv X1. constructor; auto. + destruct t0 as [s Ht]. exists s. eapply typing_alpha; tea. eapply context_conversion; tea. auto. now apply upto_names_conv_context. @@ -715,7 +907,7 @@ Section Alpha. Lemma isType_alpha Σ Γ u v : wf Σ.1 -> isType Σ Γ u -> - u ≡ v -> + u ≡α v -> isType Σ Γ v. Proof. intros hΣ [s Hs] eq. @@ -725,7 +917,7 @@ Section Alpha. Lemma isWfArity_alpha Σ Γ u v : wf Σ.1 -> isWfArity Σ Γ u -> - u ≡ v -> + u ≡α v -> isWfArity Σ Γ v. Proof. intros hΣ [isTy [ctx [s X1]]] e. @@ -736,5 +928,3 @@ Section Alpha. Qed. End Alpha. - -Infix "≡Γ" := upto_names_ctx (at level 60). diff --git a/pcuic/theories/PCUICArities.v b/pcuic/theories/PCUICArities.v index 7b029062e..d36b87680 100644 --- a/pcuic/theories/PCUICArities.v +++ b/pcuic/theories/PCUICArities.v @@ -1,15 +1,13 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import CRelationClasses ProofIrrelevance ssreflect. -From MetaCoq.Template Require Import config Universes utils BasicAst - AstUtils UnivSubst. +From MetaCoq.Template Require Import config Universes utils BasicAst. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction PCUICReflect PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICUnivSubstitution - PCUICCumulativity PCUICPosition PCUICEquality PCUICNameless + PCUICCumulativity PCUICPosition PCUICEquality PCUICSigmaCalculus PCUICInversion PCUICCumulativity PCUICReduction PCUICConfluence PCUICConversion PCUICContextConversion - PCUICParallelReductionConfluence PCUICWeakeningEnv - PCUICClosed PCUICSubstitution PCUICWfUniverses - PCUICWeakening PCUICGeneration PCUICUtils PCUICCtxShape PCUICContexts. + PCUICWeakeningEnv PCUICClosed PCUICSubstitution PCUICWfUniverses + PCUICWeakening PCUICGeneration PCUICUtils PCUICContexts. From Equations Require Import Equations. Require Import Equations.Prop.DepElim. @@ -17,8 +15,21 @@ Require Import Equations.Type.Relation_Properties. Derive Signature for typing_spine. +Implicit Types cf : checker_flags. + Notation isWAT := (isWfArity typing). +Lemma isType_Sort {cf:checker_flags} {Σ Γ s} : + wf_universe Σ s -> + wf_local Σ Γ -> + isType Σ Γ (tSort s). +Proof. + intros wfs wfΓ. + eexists; econstructor; eauto. +Qed. + +Hint Resolve @isType_Sort : pcuic. + Lemma isArity_it_mkProd_or_LetIn Γ t : isArity t -> isArity (it_mkProd_or_LetIn Γ t). Proof. intros isA. induction Γ using rev_ind; simpl; auto. @@ -79,43 +90,34 @@ Proof. -- rewrite smash_context_app /= . rewrite !app_context_assoc. assert (#|smash_context [] ctx| = #|ctx'|). - { apply context_relation_length in convctx. + { apply All2_fold_length in convctx. autorewrite with len in convctx |- *. simpl in convctx. simpl. lia. } - eapply context_relation_app_inv; auto. - apply context_relation_app in convctx; auto. - constructor; pcuic. - eapply context_relation_app in convctx as [_ convctx]. - unshelve eapply (context_relation_impl convctx). + eapply All2_fold_app; auto. + apply All2_fold_app_inv in convctx; auto. + constructor; pcuic. constructor; auto. + eapply All2_fold_app_inv in convctx as [_ convctx]. + unshelve eapply (All2_fold_impl convctx). simpl; pcuicfo. destruct X. constructor; auto. eapply conv_conv_ctx; eauto. - eapply context_relation_app_inv. constructor; pcuic. + eapply All2_fold_app. constructor; pcuic. constructor; pcuic. constructor; pcuic. now symmetry. - apply context_relation_refl. intros. + apply All2_fold_refl. intros. destruct x as [na'' [b'|] ty']; constructor; reflexivity. constructor; pcuic. eapply conv_conv_ctx; eauto. - eapply context_relation_app_inv. constructor; pcuic. + eapply All2_fold_app. constructor; pcuic. constructor; pcuic. constructor; pcuic. now symmetry. - apply context_relation_refl. intros. + apply All2_fold_refl. intros. destruct x as [na'' [b''|] ty']; constructor; reflexivity. eapply conv_conv_ctx; eauto. - eapply context_relation_app_inv. constructor; pcuic. + eapply All2_fold_app. constructor; pcuic. constructor; pcuic. constructor; pcuic. now symmetry. - apply context_relation_refl. intros. + apply All2_fold_refl. intros. destruct x as [? [?|] ?]; constructor; reflexivity. auto. Qed. - -Lemma destArity_spec_Some ctx T ctx' s : - destArity ctx T = Some (ctx', s) - -> it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s). -Proof. - pose proof (PCUICClosed.destArity_spec ctx T) as H. - intro e; now rewrite e in H. -Qed. - Lemma isType_tProd {cf:checker_flags} {Σ : global_env_ext} (HΣ' : wf Σ) {Γ} (HΓ : wf_local Σ Γ) {na A B} : isType Σ Γ (tProd na A B) @@ -277,6 +279,16 @@ Fixpoint sort_of_products us s := | u :: us => sort_of_products us (Universe.sort_of_product u s) end. +Lemma leq_universe_sort_of_products_mon {cf} Σ 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'). +Proof. + intros hu; induction hu in v, v' |- *; simpl; auto with pcuic. + intros lev. eapply IHhu. + eapply leq_universe_product_mon => //. +Qed. + Lemma type_it_mkProd_or_LetIn_sorts {cf:checker_flags} Σ Γ Γ' us t s : wf Σ.1 -> sorts_local_ctx (lift_typing typing) Σ Γ Γ' us -> @@ -318,14 +330,13 @@ Lemma subslet_app_closed {cf:checker_flags} Σ Γ s s' Δ Δ' : closed_ctx Δ -> subslet Σ Γ (s ++ s') (Δ' ,,, Δ). Proof. - induction 1 in s', Δ'; simpl; auto; move=> sub'; - rewrite closedn_ctx_snoc => /andb_and [clctx clt]; + induction 1 in s', Δ'; simpl; auto; move=> sub' => /andb_and [clctx clt]; try constructor; auto. - pose proof (subslet_length X). rewrite Nat.add_0_r in clt. - rewrite /closed_decl /= -H in clt. + rewrite /= -H in clt. rewrite subst_app_simpl /= (subst_closedn s') //. - pose proof (subslet_length X). rewrite Nat.add_0_r in clt. - rewrite /closed_decl /= -H in clt. move/andb_and: clt => [clt clT]. + rewrite /= -H in clt. move/andb_and: clt => [clt clT]. replace (subst0 s t) with (subst0 (s ++ s') t). + constructor; auto. rewrite !subst_app_simpl /= !(subst_closedn s') //. @@ -371,27 +382,9 @@ Proof. now rewrite - !subst_app_simpl firstn_skipn in X. Qed. -Lemma make_context_subst_skipn {Γ args s s'} : - make_context_subst Γ args s = Some s' -> - skipn #|Γ| s' = s. -Proof. - induction Γ in args, s, s' |- *. - - destruct args; simpl; auto. - + now intros [= ->]. - + now discriminate. - - destruct a as [na [b|] ty]; simpl. - + intros H. - specialize (IHΓ _ _ _ H). - now eapply skipn_n_Sn. - + destruct args; try discriminate. - intros Hsub. - specialize (IHΓ _ _ _ Hsub). - now eapply skipn_n_Sn. -Qed. - Lemma subslet_inds_gen {cf:checker_flags} Σ ind mdecl idecl : wf Σ -> - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> let u := PCUICLookup.abstract_instance (ind_universes mdecl) in subslet (Σ, ind_universes mdecl) [] (inds (inductive_mind ind) u (ind_bodies mdecl)) (arities_context (ind_bodies mdecl)). @@ -417,7 +410,7 @@ Proof. generalize (le_n #|ind_bodies mdecl|). generalize (ind_bodies mdecl) at 1 3 4 5. induction l using rev_ind; simpl; first constructor. - rewrite /subst_instance_context /= /map_context. + rewrite /subst_instance /= /map_context. simpl. rewrite /arities_context rev_map_spec /=. rewrite map_app /= rev_app_distr /=. rewrite /= app_length /= Nat.add_1_r. @@ -429,30 +422,32 @@ Proof. rewrite Nat.add_0_r in t. rewrite subst_closedn; auto. + eapply typecheck_closed in t as [? ?]; auto. + destruct p as [? ?]. + now move/andb_and: i0=> [? ?]. Qed. Lemma subslet_inds {cf:checker_flags} Σ ind u mdecl idecl : wf Σ.1 -> - declared_inductive Σ.1 mdecl ind idecl -> + declared_inductive Σ.1 ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> subslet Σ [] (inds (inductive_mind ind) u (ind_bodies mdecl)) - (subst_instance_context u (arities_context (ind_bodies mdecl))). + (subst_instance u (arities_context (ind_bodies mdecl))). Proof. intros wfΣ isdecl univs. unfold inds. - destruct isdecl as [declm _]. - pose proof declm as declm'. - apply PCUICWeakeningEnv.on_declared_minductive in declm' as [oind oc]; auto. + pose proof (proj1 isdecl) as declm. + apply PCUICWeakeningEnv.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_constr 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. } + econstructor; eauto. split; eauto. simpl. eapply isdecl. } clear oind. revert X. clear onNpars. generalize (le_n #|ind_bodies mdecl|). generalize (ind_bodies mdecl) at 1 3 4 5. induction l using rev_ind; simpl; first constructor. - rewrite /subst_instance_context /= /map_context. + rewrite /subst_instance /= /map_context. simpl. rewrite /arities_context rev_map_spec /=. rewrite map_app /= rev_app_distr /=. rewrite {1}/map_decl /= app_length /= Nat.add_1_r. @@ -462,8 +457,8 @@ Proof. - eapply Alli_app in X as [oind Hx]. depelim Hx. clear Hx. rewrite Nat.add_0_r in t. - rewrite subst_closedn; auto. - + eapply typecheck_closed in t as [? ?]; auto. + rewrite subst_closedn; auto. + + now eapply type_closed in t. Qed. Lemma weaken_subslet {cf:checker_flags} Σ s Δ Γ : @@ -572,12 +567,10 @@ Proof. apply inversion_LetIn in H; tas. now destruct H as [s1 [A' [HA [Ht [HB H]]]]]. Qed. -Lemma on_minductive_wf_params {cf : checker_flags} (Σ : global_env × universes_decl) - mdecl (u : Instance.t) ind : - wf Σ.1 -> +Lemma on_minductive_wf_params {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind mdecl} {u} : declared_minductive Σ.1 ind mdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_local Σ (subst_instance_context u (ind_params mdecl)). + wf_local Σ (subst_instance u (ind_params mdecl)). Proof. intros; eapply (wf_local_instantiate _ (InductiveDecl mdecl)); eauto. eapply on_declared_minductive in H; auto. @@ -631,13 +624,13 @@ Proof. now rewrite app_context_nil_l. Qed. -Lemma subst_telescope_subst_instance_constr u s k Γ : - subst_telescope (map (subst_instance_constr u) s) k - (subst_instance_context u Γ) = - subst_instance_context u (subst_telescope s k Γ). +Lemma subst_telescope_subst_instance u s k Γ : + subst_telescope (map (subst_instance u) s) k + (subst_instance u Γ) = + subst_instance u (subst_telescope s k Γ). Proof. - rewrite /subst_telescope /subst_instance_context /map_context. + rewrite /subst_telescope /subst_instance /= /subst_instance_context /map_context. rewrite map_mapi mapi_map. apply mapi_ext. intros. rewrite !compose_map_decl; apply map_decl_ext => ?. - now rewrite -subst_subst_instance_constr. + now rewrite -subst_instance_subst. Qed. diff --git a/pcuic/theories/PCUICAst.v b/pcuic/theories/PCUICAst.v index 789a49970..751bf3afe 100644 --- a/pcuic/theories/PCUICAst.v +++ b/pcuic/theories/PCUICAst.v @@ -1,6 +1,7 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Export utils Universes BasicAst - Environment EnvironmentTyping. +From Coq Require Import ssreflect Morphisms. +From MetaCoq.Template Require Export utils Universes BasicAst Environment Reflect. +From MetaCoq.Template Require EnvironmentTyping. From MetaCoq.PCUIC Require Export PCUICPrimitive. From Equations Require Import Equations. (** * AST of the Polymorphic Cumulative Calculus of Inductive Constructions @@ -21,6 +22,162 @@ Ltac pcuicfo_gen tac := Tactic Notation "pcuicfo" := pcuicfo_gen auto. Tactic Notation "pcuicfo" tactic(tac) := pcuicfo_gen tac. +(* This allows not relying on lemma names getting a length equality out of some type. *) +Class HasLen (A : Type) (x y : nat) := len : A -> x = y. + +(** Note the use of a global reference to avoid capture. *) +Notation length_of t := ltac:(let lemma := constr:(PCUICAst.len t) in exact lemma) (only parsing). + + +(* Defined here since BasicAst does not have access to universe instances. + Parameterized by term types as they are not yet defined. *) +Record predicate {term} := mk_predicate { + pparams : list term; (* The parameters *) + puinst : Instance.t; (* The universe instance *) + pcontext : list (context_decl term); (* The predicate context, + initially built from params and puinst *) + preturn : term; (* The return type *) }. +Derive NoConfusion for predicate. +Arguments predicate : clear implicits. +Arguments mk_predicate {_}. + +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); + pcontext := map_context paramf p.(pcontext); + preturn := preturnf p.(preturn) |}. + + Lemma map_pparams (p : predicate term) : + map paramf (pparams p) = pparams (map_predicate p). + Proof. reflexivity. Qed. + + Lemma map_preturn (p : predicate term) : + preturnf (preturn p) = preturn (map_predicate p). + Proof. reflexivity. Qed. + + Lemma map_pcontext (p : predicate term) : + map_context paramf (pcontext p) = pcontext (map_predicate p). + Proof. reflexivity. Qed. + + Lemma map_puinst (p : predicate term) : + uf (puinst p) = puinst (map_predicate p). + Proof. reflexivity. Qed. + +End map_predicate. + +Definition shiftf {A B} (f : nat -> A -> B) k := (fun k' => f (k' + k)). + +Section map_predicate_k. + Context {term : Type}. + Context (uf : Instance.t -> Instance.t). + Context (f : nat -> term -> term). + + Definition map_predicate_k k (p : predicate term) := + {| pparams := map (f k) p.(pparams); + puinst := uf p.(puinst); + pcontext := mapi_context (shiftf f k) p.(pcontext); + preturn := f (#|p.(pcontext)| + k) p.(preturn) |}. + + Lemma map_k_pparams k (p : predicate term) : + map (f k) (pparams p) = pparams (map_predicate_k k p). + Proof. reflexivity. Qed. + + Lemma map_k_preturn k (p : predicate term) : + f (#|p.(pcontext)| + k) (preturn p) = preturn (map_predicate_k k p). + Proof. reflexivity. Qed. + + Lemma map_k_pcontext k (p : predicate term) : + mapi_context (shiftf f k) (pcontext p) = pcontext (map_predicate_k k p). + Proof. reflexivity. Qed. + + Lemma map_k_puinst k (p : predicate term) : + uf (puinst p) = puinst (map_predicate_k k p). + Proof. reflexivity. Qed. + + Definition test_predicate (instp : Instance.t -> bool) (p : term -> bool) + (pred : predicate term) := + instp pred.(puinst) && forallb p pred.(pparams) && + test_context p pred.(pcontext) && p pred.(preturn). + + Definition test_predicate_k (instp : Instance.t -> bool) + (p : nat -> term -> bool) k (pred : predicate term) := + instp pred.(puinst) && forallb (p k) pred.(pparams) && + test_context_k p k pred.(pcontext) && p (#|pred.(pcontext)| + k) pred.(preturn). + +End map_predicate_k. + +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. *) + bbody : term; (* The branch body *) }. + Derive NoConfusion for branch. + + Definition string_of_branch (f : term -> string) (b : branch) := + "([" ^ String.concat "," (map (string_of_name ∘ binder_name ∘ decl_name) (bcontext b)) ^ "], " + ^ f (bbody b) ^ ")". + + 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 (p : term -> bool) (b : branch) := + test_context p b.(bcontext) && p b.(bbody). + + Definition test_branch_k (p : nat -> term -> bool) k (b : branch) := + test_context_k p k b.(bcontext) && p (#|b.(bcontext)| + k) b.(bbody). + +End Branch. +Arguments branch : clear implicits. + +Section map_branch. + Context {term term' : Type}. + Context (f : term -> term'). + + Definition map_branch (b : branch term) := + {| bcontext := map_context f b.(bcontext); + bbody := f b.(bbody) |}. + + Lemma map_bbody (b : branch term) : + f (bbody b) = bbody (map_branch b). + Proof. reflexivity. Qed. + + Lemma map_bcontext (b : branch term) : + map_context f (bcontext b) = bcontext (map_branch b). + Proof. reflexivity. Qed. +End map_branch. + +Definition map_branches {term B} (f : term -> B) l := List.map (map_branch f) l. + +Section map_branch_k. + Context {term term' : Type}. + Context (f : nat -> term -> term'). + + Definition map_branch_k k (b : branch term) := + {| bcontext := mapi_context (shiftf f k) b.(bcontext); + bbody := f (#|b.(bcontext)| + k) b.(bbody) |}. + + Lemma map_k_bbody k (b : branch term) : + f (#|b.(bcontext)| + k) (bbody b) = bbody (map_branch_k k b). + Proof. reflexivity. Qed. + + Lemma map_k_bcontext k (b : branch term) : + mapi_context (shiftf f k) (bcontext b) = bcontext (map_branch_k k b). + Proof. reflexivity. Qed. +End map_branch_k. + +Notation map_branches_k f k brs := + (List.map (map_branch_k f k) brs). + +Notation test_branches_k test k brs := + (List.forallb (test_branch_k test k) brs). + Inductive term := | tRel (n : nat) | tVar (i : ident) (* For free variables (e.g. in a goal) *) @@ -33,7 +190,7 @@ Inductive term := | tConst (k : kername) (ui : Instance.t) | tInd (ind : inductive) (ui : Instance.t) | tConstruct (ind : inductive) (n : nat) (ui : Instance.t) -| tCase (indn : inductive * nat) (p c : term) (brs : list (nat * term)) (* # of parameters/type info/discriminee/branches *) +| tCase (indn : case_info) (p : predicate term) (c : term) (brs : list (branch term)) | tProj (p : projection) (c : term) | tFix (mfix : mfixpoint term) (idx : nat) | tCoFix (mfix : mfixpoint term) (idx : nat) @@ -132,6 +289,174 @@ Record mutual_inductive_entry := { Derive NoConfusion for local_entry one_inductive_entry mutual_inductive_entry. +(** Basic operations on the AST: lifting, substitution and tests for variable occurrences. *) + +Fixpoint lift n k t : term := + match t with + | tRel i => tRel (if Nat.leb k i then (n + i) else i) + | tEvar ev args => tEvar ev (List.map (lift n k) args) + | tLambda na T M => tLambda na (lift n k T) (lift n (S k) M) + | tApp u v => tApp (lift n k u) (lift n k v) + | tProd na A B => tProd na (lift n k A) (lift n (S k) B) + | tLetIn na b t b' => tLetIn na (lift n k b) (lift n k t) (lift n (S k) b') + | tCase ind p c brs => + let p' := map_predicate_k id (lift n) k p in + let brs' := map_branches_k (lift n) k brs in + tCase ind p' (lift n k c) brs' + | tProj p c => tProj p (lift n k c) + | tFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in + tCoFix mfix' idx + | x => x + end. + +Notation lift0 n := (lift n 0). + +(** Parallel substitution: it assumes that all terms in the substitution live in the + same context *) + +Fixpoint subst s k u := + match u with + | tRel n => + if Nat.leb k n then + match nth_error s (n - k) with + | Some b => lift0 k b + | None => tRel (n - List.length s) + end + else tRel n + | tEvar ev args => tEvar ev (List.map (subst s k) args) + | tLambda na T M => tLambda na (subst s k T) (subst s (S k) M) + | tApp u v => tApp (subst s k u) (subst s k v) + | tProd na A B => tProd na (subst s k A) (subst s (S k) B) + | tLetIn na b ty b' => tLetIn na (subst s k b) (subst s k ty) (subst s (S k) b') + | tCase ind p c brs => + let p' := map_predicate_k id (subst s) k p in + let brs' := map_branches_k (subst s) k brs in + tCase ind p' (subst s k c) brs' + | tProj p c => tProj p (subst s k c) + | tFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in + tCoFix mfix' idx + | x => x + end. + +(** Substitutes [t1 ; .. ; tn] in u for [Rel 0; .. Rel (n-1)] *in parallel* *) +Notation subst0 t := (subst t 0). +Definition subst1 t k u := subst [t] k u. +Notation subst10 t := (subst1 t 0). +Notation "M { j := N }" := (subst1 N j M) (at level 10, right associativity). + +Fixpoint closedn k (t : term) : bool := + match t with + | tRel i => Nat.ltb i k + | tEvar ev args => List.forallb (closedn k) args + | tLambda _ T M | tProd _ T M => closedn k T && closedn (S k) M + | tApp u v => closedn k u && closedn k v + | tLetIn na b t b' => closedn k b && closedn k t && closedn (S k) b' + | tCase ind p c brs => + let p' := test_predicate_k (fun _ => true) closedn k p in + let brs' := test_branches_k closedn k brs in + p' && closedn k c && brs' + | tProj p c => closedn k c + | tFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (closedn k) (closedn k')) mfix + | tCoFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (closedn k) (closedn k')) mfix + | x => true + end. + +Notation closed t := (closedn 0 t). + +Fixpoint noccur_between k n (t : term) : bool := + match t with + | tRel i => Nat.ltb i k || Nat.leb (k + n) i + | tEvar ev args => List.forallb (noccur_between k n) args + | tLambda _ T M | tProd _ T M => noccur_between k n T && noccur_between (S k) n M + | tApp u v => noccur_between k n u && noccur_between k n v + | tLetIn na b t b' => noccur_between k n b && noccur_between k n t && noccur_between (S k) n b' + | tCase ind p c brs => + let p' := test_predicate_k (fun _ => true) (fun k' => noccur_between k' n) k p in + let brs' := test_branches_k (fun k => noccur_between k n) k brs in + p' && noccur_between k n c && brs' + | tProj p c => noccur_between k n c + | tFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix + | tCoFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix + | x => true + end. + +(** * Universe substitution + + Substitution of universe levels for universe level variables, used to + implement universe polymorphism. *) + +Instance subst_instance_constr : UnivSubst term := + fix subst_instance_constr u c {struct c} : term := + match c with + | tRel _ | tVar _ => c + | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) + | tSort s => tSort (subst_instance_univ u s) + | tConst c u' => tConst c (subst_instance_instance u u') + | tInd i u' => tInd i (subst_instance_instance u u') + | tConstruct ind k u' => tConstruct ind k (subst_instance_instance u u') + | tLambda na T M => tLambda na (subst_instance_constr u T) (subst_instance_constr u M) + | tApp f v => tApp (subst_instance_constr u f) (subst_instance_constr u v) + | tProd na A B => tProd na (subst_instance_constr u A) (subst_instance_constr u B) + | tLetIn na b ty b' => tLetIn na (subst_instance_constr u b) (subst_instance_constr u ty) + (subst_instance_constr u b') + | tCase ind p c brs => + let p' := map_predicate (subst_instance_instance u) (subst_instance_constr u) (subst_instance_constr u) p in + let brs' := List.map (map_branch (subst_instance_constr u)) brs in + tCase ind p' (subst_instance_constr u c) brs' + | tProj p c => tProj p (subst_instance_constr u c) + | tFix mfix idx => + let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in + tCoFix mfix' idx + | tPrim _ => c + end. + +(** Tests that the term is closed over [k] universe variables *) +Fixpoint closedu (k : nat) (t : term) : bool := + match t with + | tSort univ => closedu_universe k univ + | tInd _ u => closedu_instance k u + | tConstruct _ _ u => closedu_instance k u + | tConst _ u => closedu_instance k u + | tRel i => true + | tEvar ev args => forallb (closedu k) args + | tLambda _ T M | tProd _ T M => closedu k T && closedu k M + | tApp u v => closedu k u && closedu k v + | tLetIn na b t b' => closedu k b && closedu k t && closedu k b' + | tCase ind p c brs => + let p' := test_predicate (closedu_instance k) (closedu k) p in + let brs' := forallb (test_branch (closedu k)) brs in + p' && closedu k c && brs' + | tProj p c => closedu k c + | tFix mfix idx => + forallb (test_def (closedu k) (closedu k)) mfix + | tCoFix mfix idx => + forallb (test_def (closedu k) (closedu k)) mfix + | x => true + end. + Module PCUICTerm <: Term. Definition term := term. @@ -145,17 +470,835 @@ Module PCUICTerm <: Term. Definition tProj := tProj. Definition mkApps := mkApps. + Definition lift := lift. + Definition subst := subst. + Definition closedn := closedn. + Definition noccur_between := noccur_between. + Definition subst_instance_constr := subst_instance. End PCUICTerm. Ltac unf_term := unfold PCUICTerm.term in *; unfold PCUICTerm.tRel in *; - unfold PCUICTerm.tSort in *; unfold PCUICTerm.tProd in *; - unfold PCUICTerm.tLambda in *; unfold PCUICTerm.tLetIn in *; - unfold PCUICTerm.tInd in *; unfold PCUICTerm.tProj in *. - + unfold PCUICTerm.tSort in *; unfold PCUICTerm.tProd in *; + unfold PCUICTerm.tLambda in *; unfold PCUICTerm.tLetIn in *; + unfold PCUICTerm.tInd in *; unfold PCUICTerm.tProj in *; + unfold PCUICTerm.lift in *; unfold PCUICTerm.subst in *; + unfold PCUICTerm.closedn in *; unfold PCUICTerm.noccur_between in *; + unfold PCUICTerm.subst_instance_constr in *. + +(* These functors derive the notion of local context and lift substitution, term lifting, + the closed predicate to them. *) Module PCUICEnvironment := Environment PCUICTerm. -Include PCUICEnvironment. +Export PCUICEnvironment. +(* Do NOT `Include` this module, as this would sadly duplicate the rewrite database... *) + +Lemma context_assumptions_mapi_context f (ctx : context) : + context_assumptions (mapi_context f ctx) = context_assumptions ctx. +Proof. + now rewrite mapi_context_fold; len. +Qed. +Hint Rewrite context_assumptions_mapi_context : len. + +Module PCUICEnvTyping := EnvironmentTyping.EnvTyping PCUICTerm PCUICEnvironment. +(** Included in PCUICTyping only *) + +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 => + 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) => + match nth_error idecl.(ind_ctors) k with + | Some cdecl => Some (mdecl, idecl, cdecl) + | None => None + end + | _ => None + end. + +Global Instance context_reflect`(ReflectEq term) : + ReflectEq (list (BasicAst.context_decl term)) := _. + +Local Ltac finish := + let h := fresh "h" in + right ; + match goal with + | e : ?t <> ?u |- _ => + intro h ; apply e ; now inversion h + end. + +Local Ltac fcase c := + let e := fresh "e" in + 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_of_universe_instance (puinst p) + ^ ",(" ^ String.concat "," (map (string_of_name ∘ binder_name ∘ decl_name) (pcontext p)) ^ ")" + ^ "," ^ f (preturn p) ^ ")". + +Definition eqb_predicate_gen (eqb_univ_instance : Instance.t -> Instance.t -> bool) + (eqdecl : context_decl -> context_decl -> bool) + (eqterm : term -> term -> bool) (p p' : predicate term) := + forallb2 eqterm p.(pparams) p'.(pparams) && + eqb_univ_instance p.(puinst) p'.(puinst) && + forallb2 eqdecl p.(pcontext) p'.(pcontext) && + eqterm p.(preturn) p'.(preturn). + +(** Syntactic equality *) + +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 + on these types. *) +Hint Rewrite map_map_compose @compose_map_def map_length : map. +Hint Rewrite @forallb_map : map. + +Lemma map_predicate_map_predicate + {term term' term''} + (finst finst' : Instance.t -> Instance.t) + (f g : term' -> term'') + (f' g' : term -> term') + (p : predicate term) : + map_predicate finst f g (map_predicate finst' f' g' p) = + map_predicate (finst ∘ finst') (f ∘ f') (g ∘ g') p. +Proof. + unfold map_predicate. destruct p; cbn. + f_equal. + apply map_map. + rewrite map_map. + apply map_ext => x. + now rewrite compose_map_decl. +Qed. + +Lemma map_predicate_id x : map_predicate (@id _) (@id term) (@id term) x = id x. +Proof. + unfold map_predicate; destruct x; cbn; unfold id. + f_equal. apply map_id. + now rewrite map_decl_id map_id. +Qed. +Hint Rewrite @map_predicate_id : map. + +Definition ondecl {A} (P : A -> Type) (d : BasicAst.context_decl A) := + P d.(decl_type) × option_default P d.(decl_body) unit. + +Notation onctx P := (All (ondecl P)). + +Definition onctx_k (P : nat -> term -> Type) k (ctx : context) := + Alli (fun i d => ondecl (P (Nat.pred #|ctx| - i + k)) d) 0 ctx. + +Lemma ondeclP {P : term -> Type} {p : term -> bool} {d : context_decl} : + (forall x, reflectT (P x) (p x)) -> + reflectT (ondecl P d) (test_decl p d). +Proof. + intros hr. + rewrite /ondecl /test_decl; destruct d; cbn. + destruct (hr decl_type) => //; + destruct (reflect_option_default hr decl_body) => /= //; now constructor. +Qed. + +Lemma onctxP {p : term -> bool} {ctx : context} : + reflectT (onctx p ctx) (test_context p ctx). +Proof. + eapply equiv_reflectT. + - induction 1; simpl; auto. rewrite IHX /= //. + now move/(ondeclP reflectT_pred): p0. + - induction ctx. + * constructor. + * move => /= /andb_and [Hctx Hd]; constructor; eauto. + now move/(ondeclP reflectT_pred): Hd. +Qed. + +Definition tCasePredProp_k + (P : nat -> term -> Type) + k (p : predicate term) := + All (P k) p.(pparams) × onctx_k P k p.(pcontext) × + P (#|p.(pcontext)| + k) p.(preturn). + +Definition tCasePredProp {term} + (Pparams Preturn : term -> Type) + (p : predicate term) := + All Pparams p.(pparams) × + onctx Pparams p.(pcontext) × + Preturn p.(preturn). + +Lemma map_predicate_eq_spec {A B} (finst finst' : Instance.t -> Instance.t) + (f f' g g' : A -> B) (p : predicate A) : + finst (puinst p) = finst' (puinst p) -> + map f (pparams p) = map g (pparams p) -> + map_context f (pcontext p) = map_context g (pcontext p) -> + f' (preturn p) = g' (preturn p) -> + map_predicate finst f f' p = map_predicate finst' g g' p. +Proof. + intros. unfold map_predicate; f_equal; auto. +Qed. +Hint Resolve map_predicate_eq_spec : all. + +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) -> + mapi_context (shiftf f k) (pcontext p) = mapi_context (shiftf g k') (pcontext p) -> + shiftf f k #|pcontext p| (preturn p) = shiftf g k' #|pcontext p| (preturn p) -> + map_predicate_k finst f k p = map_predicate_k finst' g k' p. +Proof. + intros. unfold map_predicate_k; f_equal; auto. +Qed. +Hint Resolve map_predicate_k_eq_spec : all. + +Lemma map_decl_id_spec P f d : + ondecl P d -> + (forall x : term, P x -> f x = x) -> + map_decl f d = d. +Proof. + intros Hc Hf. + destruct Hc. + unfold map_decl; destruct d; cbn in *. f_equal; eauto. + destruct decl_body; simpl; eauto. f_equal. + eauto. +Qed. + +Lemma map_decl_id_spec_cond P p f d : + ondecl P d -> + test_decl p d -> + (forall x : term, P x -> p x -> f x = x) -> + map_decl f d = d. +Proof. + intros []. + unfold map_decl; destruct d; cbn in *. + unfold test_decl; simpl. + intros [pty pbody]%andb_and. intros Hx. + f_equal; eauto. + destruct decl_body; simpl; eauto. f_equal. + eauto. +Qed. + +Lemma map_context_id_spec P f ctx : + onctx P ctx -> + (forall x : term, P x -> f x = x) -> + map_context f ctx = ctx. +Proof. + intros Hc Hf. induction Hc; simpl; auto. + rewrite IHHc. f_equal; eapply map_decl_id_spec; eauto. +Qed. +Hint Resolve map_context_id_spec : all. + +Lemma map_context_id_spec_cond P p f ctx : + onctx P ctx -> + test_context p ctx -> + (forall x : term, P x -> p x -> f x = x) -> + map_context f ctx = 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. +Qed. +Hint Resolve map_context_id_spec_cond : all. + +Lemma map_context_map (f : term -> term) g (ctx : context) : + map_context f (map g ctx) = map (map_decl f ∘ g) ctx. +Proof. + induction ctx; simpl; f_equal; auto. +Qed. +Hint Rewrite map_context_map : map. + +Lemma map_map_context {A} (f : context_decl -> A) (g : term -> term) (ctx : context) : + map f (map_context g ctx) = map (f ∘ map_decl g) ctx. +Proof. + now rewrite /map_context map_map_compose. +Qed. +Hint Rewrite @map_map_context : map. + +Lemma map_predicate_id_spec {A} finst (f f' : A -> A) (p : predicate A) : + finst (puinst p) = puinst p -> + map f (pparams p) = pparams p -> + map_context f (pcontext p) = pcontext p -> + f' (preturn p) = preturn p -> + map_predicate finst f f' p = p. +Proof. + unfold map_predicate. + intros -> -> -> ->; destruct p; auto. +Qed. +Hint Resolve map_predicate_id_spec : all. + +Lemma map_predicate_k_id_spec {A} finst (f : nat -> A -> A) k (p : predicate A) : + finst (puinst p) = puinst p -> + map (f k) (pparams p) = pparams p -> + mapi_context (shiftf f k) (pcontext p) = pcontext p -> + shiftf f k #|p.(pcontext)| (preturn p) = preturn p -> + map_predicate_k finst f k p = p. +Proof. + unfold map_predicate_k, shiftf. + intros -> -> -> ->; destruct p; auto. +Qed. +Hint Resolve map_predicate_k_id_spec : all. + +Instance map_predicate_proper {term} : + Proper (`=1` ==> `=1` ==> Logic.eq ==> Logic.eq)%signature (@map_predicate term term id). +Proof. + intros eqf0 eqf1 eqf. + intros eqf'0 eqf'1 eqf'. + intros x y ->. + apply map_predicate_eq_spec; auto. + now apply map_ext => x. + now rewrite eqf. +Qed. + +Instance map_predicate_proper' {term} f : Proper (`=1` ==> Logic.eq ==> Logic.eq) + (@map_predicate term term id f). +Proof. + intros eqf0 eqf1 eqf. + intros x y ->. + apply map_predicate_eq_spec; auto. +Qed. + +Lemma map_fold_context_k f g ctx : map (map_decl f) (fold_context_k g ctx) = fold_context_k (fun i => f ∘ g i) ctx. +Proof. + rewrite !fold_context_k_alt map_mapi. + apply mapi_ext => i d. now rewrite compose_map_decl. +Qed. +Hint Rewrite map_fold_context_k : map. + +Lemma mapi_context_map (f : nat -> term -> term) g (ctx : context) : + mapi_context f (map g ctx) = mapi (fun i => map_decl (f (Nat.pred #|ctx| - i)) ∘ g) ctx. +Proof. + rewrite mapi_context_fold fold_context_k_alt mapi_map. now len. +Qed. +Hint Rewrite mapi_context_map : map. + +Lemma mapi_context_map_context (f : nat -> term -> term) g (ctx : context) : + mapi_context f (map_context g ctx) = + mapi_context (fun i => f i ∘ g) ctx. +Proof. + now rewrite !mapi_context_fold fold_context_k_map. +Qed. +Hint Rewrite mapi_context_map_context : map. + +Lemma map_context_mapi_context (f : term -> term) (g : nat -> term -> term) (ctx : context) : + map_context f (mapi_context g ctx) = + mapi_context (fun i => f ∘ g i) ctx. +Proof. + rewrite !mapi_context_fold. now unfold map_context; rewrite map_fold_context_k. +Qed. +Hint Rewrite map_context_mapi_context : map. + +Lemma map_mapi_context {A} (f : context_decl -> A) (g : nat -> term -> term) (ctx : context) : + map f (mapi_context g ctx) = mapi (fun i => f ∘ map_decl (g (Nat.pred #|ctx| - i))) ctx. +Proof. + now rewrite mapi_context_fold fold_context_k_alt map_mapi. +Qed. +Hint Rewrite @map_mapi_context : map. + +Lemma shiftf0 {A B} (f : nat -> A -> B) : shiftf f 0 =2 f. +Proof. intros x. unfold shiftf. now rewrite Nat.add_0_r. Qed. + +Hint Rewrite @shiftf0 : map. + +Lemma map_predicate_k_map_predicate_k + (finst finst' : Instance.t -> Instance.t) + (f f' : nat -> term -> term) + k k' (p : predicate term) : + map_predicate_k finst f k (map_predicate_k finst' f' k' p) = + map_predicate_k (finst ∘ finst') (fun i => f (i + k) ∘ f' (i + k')) 0 p. +Proof. + unfold map_predicate, map_predicate_k. destruct p; cbn. + f_equal. + now rewrite map_map. + now rewrite !mapi_context_fold fold_context_k_compose shiftf0. + now len. +Qed. +Hint Rewrite map_predicate_k_map_predicate_k : map. + +Lemma map_predicate_map_predicate_k + (finst finst' : Instance.t -> Instance.t) + (f : term -> term) (f' : nat -> term -> term) + k (p : predicate term) : + map_predicate finst f f (map_predicate_k finst' f' k p) = + map_predicate_k (finst ∘ finst') (fun k => f ∘ f' k) k p. +Proof. + unfold map_predicate, map_predicate_k. destruct p; cbn. + f_equal. + apply map_map. + rewrite !mapi_context_fold map_fold_context_k. + reflexivity. +Qed. +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) + k (p : predicate term) : + map_predicate_k finst f k (map_predicate finst' f' f' p) = + map_predicate_k (finst ∘ finst') (fun k => (f k) ∘ f') k p. +Proof. + unfold map_predicate, map_predicate_k. destruct p; cbn. + f_equal; len; auto. + * apply map_map. + * rewrite !mapi_context_fold. + fold (map_context f' pcontext0). + now rewrite fold_context_k_map. +Qed. +Hint Rewrite map_predicate_k_map_predicate : map. + +Lemma map_branch_map_branch + {term term' term''} + (f : term' -> term'') + (f' : term -> term') + (b : branch term) : + map_branch f (map_branch f' b) = + map_branch (f ∘ f') b. +Proof. + unfold map_branch; destruct b; cbn. + f_equal. + rewrite map_map. + now setoid_rewrite compose_map_decl. +Qed. +Hint Rewrite @map_branch_map_branch : map. + +Lemma map_branch_k_map_branch_k (f f' : nat -> term -> term) k k' (b : branch term) : + map_branch_k f k (map_branch_k f' k' b) = + map_branch_k (fun i => f (i + k) ∘ f' (i + k')) 0 b. +Proof. + unfold map_branch, map_branch_k; destruct b; cbn. len. + f_equal. + rewrite !mapi_context_fold. + now rewrite !fold_context_k_compose shiftf0. +Qed. +Hint Rewrite map_branch_k_map_branch_k : map. + +Lemma map_branch_map_branch_k + (f : term -> term) + (f' : nat -> term -> term) k + (b : branch term) : + map_branch f (map_branch_k f' k b) = + map_branch_k (fun k => f ∘ (f' k)) k b. +Proof. + unfold map_branch, map_branch_k; destruct b; cbn. + f_equal. + now rewrite !mapi_context_fold map_fold_context_k. +Qed. + +Hint Rewrite map_branch_map_branch_k : map. +Lemma map_branch_k_map_branch + (f' : term -> term) + (f : nat -> term -> term) k + (b : branch term) : + map_branch_k f k (map_branch f' b) = + map_branch_k (fun k => f k ∘ f') k b. +Proof. + unfold map_branch, map_branch_k; destruct b; cbn. len. + f_equal. + rewrite !mapi_context_fold. + now fold (map_context f' bcontext0); rewrite fold_context_k_map. +Qed. + +Hint Rewrite map_branch_k_map_branch : map. + +Lemma map_branch_id x : map_branch (@id term) x = id x. +Proof. + unfold map_branch, id; destruct x; cbn. + f_equal. now rewrite map_decl_id map_id. +Qed. +Hint Rewrite @map_branch_id : map. + +Lemma map_decl_eq_spec {A B} {P : A -> Type} {d} {f g : A -> B} : + ondecl P d -> + (forall x, P x -> f x = g x) -> + map_decl f d = map_decl g d. +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. +Qed. + +Lemma map_context_eq_spec {A B} P (f g : A -> B) ctx : + onctx P ctx -> + (forall x, P x -> f x = g x) -> + map_context f ctx = map_context g ctx. +Proof. + intros onc Hfg. + induction onc; simpl; auto. + rewrite IHonc. f_equal. + eapply map_decl_eq_spec; eauto. +Qed. + +Lemma map_branch_eq_spec {A B} (f g : A -> B) (x : branch A) : + map_context f (bcontext x) = map_context g (bcontext x) -> + f (bbody x) = g (bbody x) -> + map_branch f x = map_branch g x. +Proof. + intros. unfold map_branch; f_equal; auto. +Qed. +Hint Resolve map_branch_eq_spec : all. + +Lemma map_branch_k_eq_spec {A B} (f g : nat -> A -> B) k k' (x : branch A) : + mapi_context (shiftf f k) (bcontext x) = mapi_context (shiftf g k') (bcontext x) -> + shiftf f k #|x.(bcontext)| (bbody x) = shiftf g k' #|x.(bcontext)| (bbody x) -> + map_branch_k f k x = map_branch_k g k' x. +Proof. + intros. unfold map_branch_k; f_equal; auto. +Qed. +Hint Resolve map_branch_eq_spec : all. + +Instance map_branch_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) + (@map_branch term term). +Proof. + intros eqf0 eqf1 eqf. + intros x y ->. + apply map_branch_eq_spec; auto. + now rewrite eqf. +Qed. + +Lemma map_context_id (ctx : context) : map_context id ctx = ctx. +Proof. + unfold map_context. + now rewrite map_decl_id map_id. +Qed. + +Lemma map_branch_id_spec (f : term -> term) (x : branch term) : + map_context f (bcontext x) = bcontext x -> + f (bbody x) = (bbody x) -> + map_branch f x = x. +Proof. + intros. rewrite (map_branch_eq_spec _ id); auto. + now rewrite map_context_id. + now rewrite map_branch_id. +Qed. +Hint Resolve map_branch_id_spec : all. + +Lemma map_branch_k_id_spec (f : nat -> term -> term) k (x : branch term) : + mapi_context (shiftf f k) (bcontext x) = bcontext x -> + shiftf f k #|x.(bcontext)| (bbody x) = (bbody x) -> + map_branch_k f k x = x. +Proof. + intros. unfold map_branch_k. + destruct x; simpl in *; f_equal; eauto. +Qed. +Hint Resolve map_branch_k_id_spec : all. + +Lemma map_branches_map_branches + {term term' term''} + (f : term' -> term'') + (f' : term -> term') + (l : list (branch term)) : + map (fun b => map_branch f (map_branch f' b)) l = + map (map_branch (f ∘ f')) l. +Proof. + eapply map_ext => b. apply map_branch_map_branch. +Qed. + +Definition tCaseBrsProp {A} (P : A -> Type) (l : list (branch A)) := + All (fun x => onctx P (bcontext x) × P (bbody x)) l. + +Definition tCaseBrsProp_k (P : nat -> term -> Type) k (l : list (branch term)) := + All (fun x => onctx_k P k (bcontext x) × P (#|x.(bcontext)| + k) (bbody x)) l. + +Lemma map_branches_k_map_branches_k + {term term' term''} + (f : nat -> term' -> term'') + (g : term -> term') + (f' : nat -> term -> term') k + (l : list (branch term)) : + map (fun b => map_branch (f #|bcontext (map_branch g b)|) (map_branch (f' k) b)) l = + map (fun b => map_branch (f #|bcontext b|) (map_branch (f' k) b)) l. +Proof. + eapply map_ext => b. rewrite map_branch_map_branch. + rewrite map_branch_map_branch. + now simpl; autorewrite with len. +Qed. + +Lemma case_brs_map_spec {A B} {P : A -> Type} {l} {f g : A -> B} : + tCaseBrsProp P l -> (forall x, P x -> f x = g x) -> + map_branches f l = map_branches g l. +Proof. + intros. red in X. + eapply All_map_eq. eapply All_impl; eauto. simpl; intros. + destruct X0. + apply map_branch_eq_spec; eauto. + eapply map_context_eq_spec; eauto. +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 -> + (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. +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 -> + (forall x, P x -> p x -> f x = g x) -> + map_context f ctx = map_context g ctx. +Proof. + intros Ha Hctx Hfg. induction Ha; simpl; auto. + revert Hctx; simpl; intros [Hx Hl]%andb_and. + rewrite IHHa; f_equal; auto. + eapply map_decl_eqP_spec; eauto. +Qed. + +Lemma mapi_context_eqP_spec {A B} {P : A -> Type} {ctx} {f g : nat -> A -> B} : + All (ondecl P) ctx -> + (forall k x, P x -> f k x = g k x) -> + mapi_context f ctx = mapi_context g ctx. +Proof. + intros Ha Hfg. induction Ha; simpl; auto. + rewrite IHHa; f_equal. + destruct p as [Hty Hbody]. + unfold map_decl; destruct x ; cbn in *; f_equal. + * destruct decl_body; cbn in *; auto. + f_equal. eauto. + * eauto. +Qed. + +Lemma mapi_context_eqP_id_spec {A} {P : A -> Type} {ctx} {f : nat -> A -> A} : + All (ondecl P) ctx -> + (forall k x, P x -> f k x = x) -> + mapi_context f ctx = ctx. +Proof. + intros Ha Hfg. induction Ha; simpl; auto. + rewrite IHHa; f_equal. + destruct p as [Hty Hbody]. + unfold map_decl; destruct x ; cbn in *; f_equal. + * destruct decl_body; cbn in *; auto. + f_equal. eauto. + * eauto. +Qed. + +Lemma mapi_context_eqP_test_id_spec {A} {P : A -> Type} (p : nat -> A -> bool) + k {ctx} {f : nat -> A -> A} : + All (ondecl P) ctx -> + test_context_k p k ctx -> + (forall k (x : A), P x -> p k x -> f k x = x) -> + mapi_context (shiftf f k) ctx = ctx. +Proof. + intros Ha ht Hfg. revert ht. + induction Ha; simpl; auto. + intros [hl [hty hbod]%andb_and]%andb_and. + rewrite IHHa; auto; f_equal. + 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. +Qed. + +Lemma test_context_k_eqP_id_spec {A} {P : A -> Type} (p q : nat -> A -> bool) k k' {ctx} : + All (ondecl P) ctx -> + test_context_k p k ctx -> + (forall i (x : A), P x -> p (i + k) x -> q (i + k') x) -> + test_context_k q k' ctx. +Proof. + intros Ha ht Hfg. revert ht. + induction Ha; simpl; auto. + intros [hl [hty hbod]%andb_and]%andb_and. + rewrite IHHa; simpl; auto. + destruct p0 as [Hty Hbody]. + unfold test_decl; destruct x ; cbn in *; eauto. + destruct decl_body; cbn in *; auto. + rewrite !Hfg; auto. +Qed. + +Lemma test_context_k_eqP_eq_spec {A} {P : A -> Type} (p q : nat -> A -> bool) k k' {ctx} : + All (ondecl P) ctx -> + (forall i (x : A), P x -> p (i + k) x = q (i + k') x) -> + test_context_k p k ctx = test_context_k q k' ctx. +Proof. + intros Ha Hfg. + induction Ha; simpl; auto. + rewrite IHHa; auto; f_equal. + destruct p0 as [Hty Hbody]. + unfold test_decl; destruct x ; cbn in *; f_equal; eauto. + destruct decl_body; cbn in *; auto; + rewrite !Hfg; auto. +Qed. + +Lemma test_context_k_eq_spec (p q : nat -> term -> bool) k k' {ctx} : + (p =2 q) -> + k = k' -> + test_context_k p k ctx = test_context_k q k' ctx. +Proof. + intros Hfg <-. + 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 : + 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. + rewrite IHctx alli_app /= andb_comm andb_true_r andb_comm. f_equal. + len. now rewrite Nat.add_comm. +Qed. + +Instance test_context_k_Proper : Proper (`=2` ==> Logic.eq ==> `=1`) (@test_context_k term). +Proof. + intros f g Hfg k k' <- ctx. + now apply test_context_k_eq_spec. +Qed. + +Instance test_predicate_k_Proper : Proper (`=1` ==> `=2` ==> Logic.eq ==> `=1`) (@test_predicate_k term). +Proof. + intros hi hi' eqhi f g Hfg k k' <- ctx. + unfold test_predicate_k. rewrite eqhi. + now setoid_rewrite Hfg. +Qed. + +Instance test_branch_k_Proper : Proper (`=2` ==> Logic.eq ==> `=1`) (@test_branch_k term). +Proof. + intros f g Hfg k k' <- ctx. + unfold test_branch_k. + now setoid_rewrite Hfg. +Qed. + +Lemma case_brs_map_spec_cond {A B} {P : A -> Type} p {l} {f g : A -> B} : + tCaseBrsProp P l -> + forallb (test_branch p) l -> + (forall x, P x -> p x -> f x = g x) -> + map_branches f l = map_branches g l. +Proof. + intros. red in X. + eapply forallb_All in H. + eapply All_map_eq. + eapply All_prod in X; tea. clear H. + eapply All_impl; eauto. simpl; intros br [[]%andb_and []]. + apply map_branch_eq_spec; eauto. + eapply map_context_eqP_spec; eauto. +Qed. + +Lemma case_brs_map_k_spec {A B} {P : A -> Type} {k l} {f g : nat -> A -> B} : + tCaseBrsProp P l -> + (forall k x, P x -> f k x = g k x) -> + map_branches_k f k l = map_branches_k g k l. +Proof. + intros. red in X. + eapply All_map_eq. eapply All_impl; eauto. simpl; intros. + destruct X0 as [Hctx Hbod]. + apply map_branch_k_eq_spec; eauto. + apply (mapi_context_eqP_spec Hctx). + intros k' x' hx'. unfold shiftf. now apply H. +Qed. + +Lemma case_brs_forallb_map_spec {A B} {P : A -> Type} {p : A -> bool} + {l} {f g : A -> B} : + tCaseBrsProp P l -> + forallb (test_branch p) l -> + (forall x, P x -> p x -> f x = g x) -> + map (map_branch f) l = map (map_branch g) l. +Proof. + intros. + eapply All_map_eq. red in X. apply forallb_All in H. + eapply All_impl. eapply All_prod. exact X. exact H. simpl. + intros [bctx bbod] [[Hbctx Hbr] [Hctx hb]%andb_and]. cbn in *. + unfold map_branch; cbn. f_equal. + - eapply map_context_eqP_spec; eauto. + - eapply H0; eauto. +Qed. + +Lemma test_context_map (p : term -> bool) f (ctx : context) : + test_context p (map_context f ctx) = test_context (p ∘ f) ctx. +Proof. + induction ctx; simpl; auto. + rewrite IHctx. f_equal. + now rewrite test_decl_map_decl. +Qed. +Hint Rewrite test_context_map : map. + +Lemma onctx_test P (p q : term -> bool) ctx : + onctx P ctx -> + test_context p ctx -> + (forall t, P t -> p t -> q t) -> + test_context q ctx. +Proof. + intros Hc tc HP. revert tc. + induction Hc; simpl; auto. + destruct p0. + intros [pl [pbod pty]%andb_and]%andb_and. + rewrite (IHHc pl); simpl. + unfold test_decl. + rewrite (HP _ p0 pty) andb_true_r; simpl. + destruct (decl_body x); simpl in *; eauto. +Qed. + +(** Useful for inductions *) +Lemma onctx_k_rev {P : nat -> term -> Type} {k} {ctx} : + onctx_k P k ctx <~> + Alli (fun i => ondecl (P (i + k))) 0 (List.rev ctx). +Proof. + split. + - unfold onctx_k. + intros Hi. + eapply forall_nth_error_Alli => i x hx. + pose proof (nth_error_Some_length hx). + rewrite nth_error_rev // in hx. + rewrite List.rev_involutive in hx. + len in hx. + eapply Alli_nth_error in Hi; tea. + simpl in Hi. simpl. + replace (Nat.pred #|ctx| - (#|ctx| - S i) + k) with (i + k) in Hi => //. + len in H; by lia. + - intros Hi. + eapply forall_nth_error_Alli => i x hx. + eapply Alli_rev_nth_error in Hi; tea. + simpl. + replace (#|ctx| - S i + k) with (Nat.pred #|ctx| - i + k) in Hi => //. + lia. +Qed. + +Lemma onctx_k_shift {P : nat -> term -> Type} {k} {ctx} : + onctx_k P k ctx -> + onctx_k (fun k' => P (k' + k)) 0 ctx. +Proof. + intros Hi%onctx_k_rev. + eapply onctx_k_rev. + eapply Alli_impl; tea => /= n x. + now rewrite Nat.add_0_r. +Qed. + +Lemma onctx_k_P {P : nat -> term -> Type} {p : nat -> term -> bool} {k} {ctx : context} : + (forall x y, reflectT (P x y) (p x y)) -> + reflectT (onctx_k P k ctx) (test_context_k p k ctx). +Proof. + intros HP. + eapply equiv_reflectT. + - intros Hi%onctx_k_rev. + rewrite test_context_k_eq. + induction Hi; simpl; auto. + rewrite Nat.add_comm. + rewrite IHHi /= //. + now move/(ondeclP (HP _)): p0 => ->. + - intros Hi. eapply onctx_k_rev. + move: ctx Hi. induction ctx. + * constructor. + * move => /= /andb_and [Hctx Hd]. + eapply Alli_app_inv; eauto. constructor. + + move/(ondeclP (HP _)): Hd. now len. + + constructor. +Qed. -Module PCUICLookup := Lookup PCUICTerm PCUICEnvironment. +Module PCUICLookup := EnvironmentTyping.Lookup PCUICTerm PCUICEnvironment. Include PCUICLookup. -Derive NoConfusion for global_decl context_decl. +Derive NoConfusion for global_decl. diff --git a/pcuic/theories/PCUICAstUtils.v b/pcuic/theories/PCUICAstUtils.v index f6afefa10..29062a808 100644 --- a/pcuic/theories/PCUICAstUtils.v +++ b/pcuic/theories/PCUICAstUtils.v @@ -6,7 +6,11 @@ Require Import ssreflect. From Equations Require Import Equations. Set Equations Transparent. -Derive Signature for All All2. +Lemma eqb_annot_reflect {A} na na' : reflect (@eq_binder_annot A A na na') (eqb_binder_annot na na'). +Proof. + unfold eqb_binder_annot, eq_binder_annot. + destruct Classes.eq_dec; constructor; auto. +Qed. Definition string_of_aname (b : binder_annot name) := string_of_name b.(binder_name). @@ -28,9 +32,9 @@ Fixpoint string_of_term (t : term) := | tInd i u => "Ind(" ^ string_of_inductive i ^ "," ^ string_of_universe_instance u ^ ")" | tConstruct i n u => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ "," ^ string_of_universe_instance u ^ ")" - | tCase (ind, i) t p brs => - "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_term p ^ "," ^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")" + | tCase ci p t brs => + "Case(" ^ string_of_case_info ci ^ "," ^ string_of_term t ^ "," + ^ string_of_predicate string_of_term p ^ "," ^ string_of_list (string_of_branch string_of_term) brs ^ ")" | tProj (ind, i, k) c => "Proj(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_nat k ^ "," ^ string_of_term c ^ ")" @@ -39,6 +43,47 @@ Fixpoint string_of_term (t : term) := | tPrim i => "Int(" ^ string_of_prim string_of_term i ^ ")" end. +Ltac change_Sk := + repeat match goal with + | |- context [S (?x + ?y)] => progress change (S (x + y)) with (S x + y) + | |- context [#|?l| + (?x + ?y)] => progress replace (#|l| + (x + y)) with ((#|l| + x) + y) by now rewrite Nat.add_assoc + end. + +Ltac solve_all_one := + try lazymatch goal with + | H: tCasePredProp _ _ _ |- _ => destruct H as [? [? ?]] + end; + unfold tCaseBrsProp, tFixProp in *; + autorewrite with map; + rtoProp; + try ( + apply map_predicate_eq_spec || + apply map_predicate_k_eq_spec || + apply map_predicate_id_spec || + apply map_predicate_k_id_spec || + apply map_branch_k_eq_spec || + apply map_branch_k_id_spec || + apply map_def_eq_spec || + apply map_def_id_spec || + apply map_branch_eq_spec || + apply map_branch_id_spec || + (eapply All_forallb_eq_forallb; [eassumption|]) || + (eapply mapi_context_eqP_test_id_spec; [eassumption|eassumption|]) || + (eapply mapi_context_eqP_spec; [eassumption|]) || + (eapply mapi_context_eqP_id_spec; [eassumption|]) || + (eapply onctx_test; [eassumption|eassumption|]) || + (eapply test_context_k_eqP_id_spec; [eassumption|eassumption|]) || + (eapply test_context_k_eqP_eq_spec; [eassumption|]) || + (eapply map_context_eq_spec; [eassumption|])); + repeat toAll; try All_map; try close_Forall; + change_Sk; auto with all; + intuition eauto 4 with all. + +Ltac solve_all := repeat (progress solve_all_one). +Hint Extern 10 => rewrite !map_branch_map_branch : all. +Hint Extern 10 => rewrite !map_predicate_map_predicate : all. + + Lemma lookup_env_nil c s : lookup_env [] c = Some s -> False. Proof. induction c; simpl; auto => //. @@ -104,6 +149,44 @@ Proof. rewrite <- IHl. simpl. reflexivity. Qed. + +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. + intros napp eqapp. + destruct args using rev_case => //. + simpl in eqapp. subst fn => //. + rewrite -mkApps_nested in eqapp. noconf eqapp. + now rewrite removelast_app // last_app // /= app_nil_r. +Qed. + +Lemma removelast_length {A} (args : list A) : #|removelast args| = Nat.pred #|args|. +Proof. + induction args => //. destruct args => //. + now rewrite (removelast_app [_]) // app_length IHargs /=. +Qed. + +Lemma nth_error_removelast {A} {args : list A} {n arg} : + nth_error (removelast args) n = Some arg -> + nth_error args n = Some arg. +Proof. + intros h. rewrite nth_error_removelast //. + apply nth_error_Some_length in h. + now rewrite removelast_length in h. +Qed. + +Lemma mkApps_discr f args t : + args <> [] -> + mkApps f args = t -> + ~~ isApp t -> False. +Proof. + intros. + destruct args using rev_case => //. + rewrite -mkApps_nested in H0. destruct t => //. +Qed. + Fixpoint decompose_prod (t : term) : (list aname) * (list term) * term := match t with | tProd n A B => let (nAs, B) := decompose_prod B in @@ -150,15 +233,15 @@ Proof. exact (List.map LocalAssum types). - refine (List.map _ decl.(ind_bodies)). intros []. - refine {| mind_entry_typename := ind_name; - mind_entry_arity := remove_arity decl.(ind_npars) ind_type; + refine {| mind_entry_typename := ind_name0; + mind_entry_arity := remove_arity decl.(ind_npars) ind_type0; mind_entry_template := false; mind_entry_consnames := _; mind_entry_lc := _; |}. - refine (List.map (fun x => fst (fst x)) ind_ctors). + refine (List.map (fun x => cstr_name x) ind_ctors0). refine (List.map (fun x => remove_arity decl.(ind_npars) - (snd (fst x))) ind_ctors). + (cstr_type x)) ind_ctors0). Defined. Fixpoint decompose_prod_assum (Γ : context) (t : term) : context * term := @@ -167,6 +250,21 @@ 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'). +Proof. + induction t in ctx |- *; simpl; auto. + - simpl. rewrite IHt2. + rewrite (IHt2 ([] ,, vass _ _)). + destruct (decompose_prod_assum [] t2). simpl. + unfold snoc. now rewrite app_context_assoc. + - simpl. rewrite IHt3. + rewrite (IHt3 ([] ,, vdef _ _ _)). + destruct (decompose_prod_assum [] t3). simpl. + unfold snoc. now rewrite app_context_assoc. +Qed. Fixpoint decompose_prod_n_assum (Γ : context) n (t : term) : option (context * term) := match n with @@ -216,6 +314,18 @@ Proof. case: x => [na [body|] ty'] /=; by rewrite IHctx' // /snoc -app_assoc. Qed. +Lemma reln_length Γ Γ' n : #|reln Γ n Γ'| = #|Γ| + context_assumptions Γ'. +Proof. + induction Γ' in n, Γ |- *; simpl; auto. + destruct a as [? [b|] ?]; simpl; auto. + rewrite Nat.add_1_r. simpl. rewrite IHΓ' => /= //. +Qed. + +Lemma to_extended_list_k_length Γ n : #|to_extended_list_k Γ n| = context_assumptions Γ. +Proof. + now rewrite /to_extended_list_k reln_length. +Qed. + Lemma reln_list_lift_above l p Γ : Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) l -> Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) (reln l p Γ). @@ -251,7 +361,7 @@ Proof. destruct H; eexists; intuition eauto. Qed. -Fixpoint reln_alt p Γ := +Fixpoint reln_alt p (Γ : context) := match Γ with | [] => [] | {| decl_body := Some _ |} :: Γ => reln_alt (p + 1) Γ @@ -280,38 +390,6 @@ Proof. now rewrite -app_assoc !app_nil_r Nat.add_1_r. Qed. -Lemma context_assumptions_length_bound Γ : context_assumptions Γ <= #|Γ|. -Proof. - 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_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. - -Hint Rewrite context_assumptions_map context_assumptions_mapi : len. - -Lemma compose_map_decl f g x : map_decl f (map_decl g x) = map_decl (f ∘ g) x. -Proof. - destruct x as [? [?|] ?]; reflexivity. -Qed. - -Lemma map_decl_ext f g 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. - now rewrite (H t). -Qed. - Ltac merge_All := unfold tFixProp, tCaseBrsProp in *; repeat toAll. @@ -376,7 +454,6 @@ Proof. eapply decompose_app_rec_notApp. eassumption. Qed. - Lemma decompose_app_rec_inv {t l' f l} : decompose_app_rec t l' = (f, l) -> mkApps t l' = mkApps f l. @@ -478,6 +555,41 @@ Proof. - assumption. Qed. +Definition head x := (decompose_app x).1. +Definition arguments x := (decompose_app x).2. + +Lemma head_arguments x : mkApps (head x) (arguments x) = x. +Proof. + unfold head, arguments, decompose_app. + remember (decompose_app_rec x []). + destruct p as [f l]. + symmetry in Heqp. + eapply decompose_app_rec_inv in Heqp. + now simpl in *. +Qed. + +Lemma fst_decompose_app_rec t l : fst (decompose_app_rec t l) = fst (decompose_app t). +Proof. + induction t in l |- *; simpl; auto. rewrite IHt1. + unfold decompose_app. simpl. now rewrite (IHt1 [t2]). +Qed. + +Lemma decompose_app_rec_head t l f : fst (decompose_app_rec t l) = f -> + negb (isApp f). +Proof. + induction t; unfold isApp; simpl; try intros [= <-]; auto. + intros. apply IHt1. now rewrite !fst_decompose_app_rec. +Qed. + +Lemma head_nApp x : negb (isApp (head x)). +Proof. + unfold head. + eapply decompose_app_rec_head. reflexivity. +Qed. + +Lemma head_tapp t1 t2 : head (tApp t1 t2) = head t1. +Proof. rewrite /head /decompose_app /= fst_decompose_app_rec //. Qed. + Lemma mkApps_Fix_spec mfix idx args t : mkApps (tFix mfix idx) args = t -> match decompose_app t with | (tFix mfix idx, args') => args' = args diff --git a/pcuic/theories/PCUICCSubst.v b/pcuic/theories/PCUICCSubst.v index 42f4781f6..c1cbf27b8 100644 --- a/pcuic/theories/PCUICCSubst.v +++ b/pcuic/theories/PCUICCSubst.v @@ -27,8 +27,9 @@ Fixpoint csubst t k u := | tProd na A B => tProd na (csubst t k A) (csubst t (S k) B) | 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 (on_snd (csubst t k)) brs in - tCase ind (csubst t k p) (csubst t k c) brs' + let brs' := List.map (fun br => map_branch_k (csubst t) k br) brs in + 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 => let k' := List.length mfix + k in @@ -41,7 +42,7 @@ Fixpoint csubst t k u := | x => x end. -(** It is equivalent to general substitution on closed terms. *) +(** 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. @@ -58,6 +59,7 @@ Proof. + now destruct (Nat.leb_spec k n); try lia. Qed. +(** 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 abc7b956d..c1eff90fa 100644 --- a/pcuic/theories/PCUICCanonicity.v +++ b/pcuic/theories/PCUICCanonicity.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICTyping PCUICAst PCUICAstUtils PCUICWeakening PCUICSubstitution PCUICArities PCUICWcbvEval PCUICSR PCUICInversion - PCUICUnivSubstitution PCUICElimination (* PCUICContextConversion *) + PCUICUnivSubstitution PCUICElimination PCUICSigmaCalculus (* PCUICContextConversion *) PCUICUnivSubst PCUICWeakeningEnv PCUICCumulativity PCUICConfluence PCUICInduction PCUICLiftSubst PCUICContexts PCUICGeneration PCUICSpine PCUICConversion PCUICValidity PCUICInductives PCUICConversion @@ -11,10 +11,6 @@ From MetaCoq.PCUIC Require Import PCUICTyping PCUICAst PCUICAstUtils PCUICParallelReductionConfluence PCUICSN PCUICWcbvEval PCUICClosed PCUICReduction PCUICCSubst. - -Module PA := PCUICAst. -Module P := PCUICWcbvEval. - Local Existing Instance config.extraction_checker_flags. Require Import Equations.Prop.DepElim. @@ -181,46 +177,6 @@ Section Spines. now eapply Reflect.eqb_eq in eqhd. Qed. - Lemma expand_lets_nil t : expand_lets [] t = t. - Proof. by rewrite /expand_lets /expand_lets_k /= subst_empty lift0_id. Qed. - - Lemma context_assumptions_context {Γ} : - assumption_context Γ -> - context_assumptions Γ = #|Γ|. - Proof. - induction 1; simpl; auto. - Qed. - - Lemma subst_context_lift_id Γ k n : n <= k -> subst_context [tRel n] k (lift_context (S n) (S k) Γ) = lift_context n k Γ. - Proof. - intros nk. - rewrite subst_context_alt !lift_context_alt. - rewrite mapi_compose. - apply mapi_ext; len. - intros n' [? [?|] ?]; unfold lift_decl, subst_decl, map_decl; simpl. - intros. - now rewrite !Nat.add_succ_r !subst_reli_lift_id //. - f_equal. - now rewrite !Nat.add_succ_r !subst_reli_lift_id //. - Qed. - - Lemma expand_lets_assumption_context Γ Δ : - assumption_context Γ -> expand_lets_ctx Γ Δ = Δ. - Proof. - induction Γ using rev_ind. - - by rewrite /expand_lets_ctx /expand_lets_k_ctx /= lift0_context subst0_context. - - 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 subst_app_context /=; len. - rewrite subst_context_lift_id // lift0_context. - rewrite (context_assumptions_context assl). simpl. - rewrite !Nat.add_1_r subst_context_lift_id //. - rewrite /expand_lets_ctx /expand_lets_k_ctx in IHΓ. - rewrite (context_assumptions_context assl) in IHΓ . - now simpl in IHΓ. - Qed. Lemma cumul_it_mkProd_or_LetIn_smash Γ Δ T : Σ ;;; Γ |- it_mkProd_or_LetIn (smash_context [] Δ) (expand_lets Δ T) <= it_mkProd_or_LetIn Δ T. @@ -355,7 +311,8 @@ Section Spines. Proof. induction Δ in args, args' |- * using ctx_length_rev_ind. - simpl. destruct args' using rev_case => /= // sp hargs // /=; try lia. - depelim sp. eapply (f_equal (@length _)) in H; simpl in H; len in H. lia. + depelim sp. eapply (f_equal (@length _)) in H; simpl in H; len in H; simpl in H. + lia. eapply invert_cumul_prod_r in c as (? & ? & ? & ((? & ?) & ?) & ?); auto. eapply red_mkApps_tInd in r as (? & ? & ?); auto. solve_discr. - rewrite it_mkProd_or_LetIn_app /=; destruct d as [na [b|] ty]. @@ -388,10 +345,11 @@ Section Spines. intros ass. eapply assumption_context_app in ass as [ass _]. destruct n. rewrite Nat.sub_0_r. - rewrite !firstn_all2; len; simpl; try lia. + rewrite !firstn_all2; + rewrite ?app_length ?app_context_length ?subst_context_length ?Nat.add_0_r /=; simpl; try lia. now rewrite subst_context_app. replace (#|Γ| + 1 - S n) with (#|Γ| - n) by lia. - rewrite /app_context !firstn_app; len; + rewrite /app_context !firstn_app ?subst_context_length /= Nat.sub_0_r. replace (#|Γ| - n - #|Γ|) with 0 by lia. simpl. rewrite Nat.add_succ_r !app_nil_r. apply H; now try lia. Qed. @@ -578,7 +536,7 @@ Section Spines. destruct isty as [s Hs]. eapply inversion_it_mkProd_or_LetIn in Hs; eauto. now eapply typing_wf_local. - * len; simpl. eapply nth_error_None in hargs => //; len in hnth. + * len; simpl. eapply nth_error_None in hargs => //. eapply nth_error_None. lia. * eapply nth_error_None in hnth => //. len in hnth. lia. - eapply typing_spine_all_inv in sp => //. @@ -764,9 +722,9 @@ Section Normalization. - eapply PCUICValidity.inversion_mkApps in Ht as (? & ? & ?); auto. eapply inversion_Ind in t as (? & ? & ? & decli & ? & ?); auto. eapply PCUICSpine.typing_spine_strengthen in t0; eauto. - pose proof (on_declared_inductive wfΣ decli) as [onind oib]. + pose proof (on_declared_inductive wfΣ as decli) [onind oib]. rewrite oib.(ind_arity_eq) in t0. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in t0. + rewrite !subst_instance_it_mkProd_or_LetIn in t0. eapply typing_spine_arity_mkApps_Ind in t0; eauto. eexists; split; [sq|]; eauto. now do 2 eapply isArity_it_mkProd_or_LetIn. @@ -816,13 +774,13 @@ Section WeakNormalization. - unfold value_head in H. destruct t => //. constructor; eapply whne_mkApps. cbn in H; destruct lookup_env eqn:eq => //. - destruct g => //. destruct c => //. destruct cst_body => //. + destruct g => //. destruct c => //. destruct cst_body0 => //. eapply whne_const; eauto. - destruct f => //. cbn in H. destruct cunfold_fix as [[rarg body]|] eqn:unf => //. pose proof cl as cl'. rewrite closedn_mkApps in cl'. move/andP: cl' => [clfix _]. - rewrite -P.closed_unfold_fix_cunfold_eq in unf => //. + rewrite -PCUICWcbvEval.closed_unfold_fix_cunfold_eq in unf => //. rewrite /unfold_fix in unf. destruct nth_error eqn:nth => //. noconf unf. eapply whnf_fixapp. rewrite /unfold_fix nth. @@ -913,19 +871,7 @@ Section WeakNormalization. intros ht; eapply invert_cumul_prod_r in ht as (? & ? & ? & ((? & ?) & ?) & ?); auto. eapply red_mkApps_tInd in r as (? & ? & ?); auto. solve_discr. Qed. - - Lemma invert_cumul_ind_ind {Γ ind ind' u u' args args'} : - Σ ;;; Γ |- mkApps (tInd ind u) args <= mkApps (tInd ind' u') args' -> - (Reflect.eqb ind ind' * PCUICEquality.R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) #|args| u u' * - All2 (conv Σ Γ) args args'). - Proof. - intros ht; eapply invert_cumul_ind_l in ht as (? & ? & ? & ? & ?); auto. - eapply red_mkApps_tInd in r as (? & ? & ?); auto. solve_discr. - noconf H. subst. - intuition auto. eapply eq_inductive_refl. - transitivity x1; auto. symmetry. now eapply red_terms_conv_terms. - Qed. - + Lemma typing_cofix_coind {Γ mfix idx args ind u indargs} : Σ ;;; Γ |- mkApps (tCoFix mfix idx) args : mkApps (tInd ind u) indargs -> check_recursivity_kind Σ.1 (inductive_mind ind) CoFinite. @@ -985,9 +931,9 @@ Section WeakNormalization. eapply inversion_mkApps in typ as (?&?&?); auto. eapply inversion_Ind in t as (?&?&?&decl&?&?); auto. eapply PCUICSpine.typing_spine_strengthen in t0; eauto. - pose proof (PCUICWeakeningEnv.on_declared_inductive wfΣ decl) as [onind oib]. + pose proof (on_declared_inductive decl) as [onind oib]. rewrite oib.(ind_arity_eq) in t0. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in t0. + rewrite !subst_instance_it_mkProd_or_LetIn in t0. eapply typing_spine_arity_mkApps_Ind in t0; eauto. eexists; split; [sq|]; eauto. now do 2 eapply PCUICArities.isArity_it_mkProd_or_LetIn. @@ -1044,7 +990,7 @@ Section WeakNormalization. clear wh_normal_empty_gen. now specialize (wh_neutral_empty_gen _ tyarg eq_refl). - move/andP: cl => [/andP[_ clc] _]. - eapply inversion_Case in typed as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); auto. + eapply inversion_Case in typed as (? & ? & ? & ? & [] & ?); tas. eapply wh_neutral_empty_gen; eauto. - eapply inversion_Proj in typed as (? & ? & ? & ? & ? & ? & ? & ? & ?); auto. eapply wh_neutral_empty_gen; eauto. @@ -1178,18 +1124,21 @@ Section WeakNormalization. eapply t2. auto. - - redt (subst_instance_constr u body); auto. + - redt (subst_instance u body); auto. eapply red1_red. econstructor; eauto. eapply IHHe. eapply subject_reduction; eauto. eapply red1_red. econstructor; eauto. - epose proof (subject_reduction Σ [] _ _ _ wfΣ Ht). apply inversion_Case in Ht; auto; destruct_sigma Ht. - specialize (IHHe1 _ t0). - assert (red Σ [] (tCase (ind, pars) p discr brs) (iota_red pars c args brs)). + destruct c0. + specialize (IHHe1 _ scrut_ty). + assert (red Σ [] (tCase ci p discr brs) (iota_red ci.(ci_npar) args br)). { redt _. - eapply red_case; eauto. eapply All2_refl; intros; eauto. - eapply red1_red; constructor. } + eapply red_case; eauto. reflexivity. + eapply All2_refl; intros; eauto. red. + eapply All2_refl; split; red; reflexivity. + eapply red1_red; constructor; tas. } specialize (X X0). redt _; eauto. @@ -1246,7 +1195,8 @@ Section WeakNormalization. - epose proof (subject_reduction Σ [] _ _ _ wfΣ Ht). apply inversion_Case in Ht; auto; destruct_sigma Ht. - pose proof (subject_closed wfΣ t0) as H. + destruct c. + pose proof (subject_closed _ scrut_ty) as H. rewrite closedn_mkApps in H. move/andP: H => [clcofix clargs]. assert (red Σ [] (tCase ip p (mkApps (tCoFix mfix idx) args) brs) (tCase ip p (mkApps fn args) brs)). { eapply red1_red. eapply red_cofix_case. @@ -1287,3 +1237,5 @@ Section WeakNormalization. End reducible. End WeakNormalization. + +Print Assumptions eval_ind_canonical. diff --git a/pcuic/theories/PCUICCases.v b/pcuic/theories/PCUICCases.v new file mode 100644 index 000000000..f008ebe9a --- /dev/null +++ b/pcuic/theories/PCUICCases.v @@ -0,0 +1,687 @@ +(* Distributed under the terms of the MIT license. *) +From MetaCoq.Template Require Import config utils Reflect. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils. +Import Reflect. (* Reflect.eqb has priority over String.eqb *) + +Require Import ssreflect. +Require Import Equations.Prop.DepElim. +From Equations.Type Require Import Relation Relation_Properties. +From Equations Require Import Equations. +Set Equations Transparent. +Set Default Goal Selector "!". + +(** * Functions related to the "compact" case representation *) + +(** Inductive substitution, to produce a constructors' type *) +Definition inds ind u (l : list one_inductive_body) := + let fix aux n := + match n with + | 0 => [] + | S n => tInd (mkInd ind n) u :: aux n + end + in aux (List.length l). + +Lemma inds_length ind u l : #|inds ind u l| = #|l|. +Proof. + unfold inds. induction l; simpl; congruence. +Qed. +Hint Rewrite inds_length : len. + +Lemma inds_spec ind u l : + inds ind u l = List.rev (mapi (fun i _ => tInd {| inductive_mind := ind; inductive_ind := i |} u) l). +Proof. + unfold inds, mapi. induction l using rev_ind. + - simpl. reflexivity. + - now rewrite app_length /= Nat.add_1_r IHl mapi_rec_app /= rev_app_distr /= Nat.add_0_r. +Qed. + +Definition pre_case_predicate_context_gen ind mdecl idecl params puinst : context := + let indty := mkApps (tInd ind puinst) (map (lift0 #|idecl.(ind_indices)|) params ++ to_extended_list idecl.(ind_indices)) in + let inddecl := + {| decl_name := + {| binder_name := nNamed (ind_name idecl); binder_relevance := idecl.(ind_relevance) |}; + decl_body := None; + decl_type := indty |} + in + let ictx := + subst_context (List.rev params) 0 + (subst_instance puinst + (expand_lets_ctx mdecl.(ind_params) idecl.(ind_indices))) + in (inddecl :: ictx). + +Definition case_predicate_context_gen ind mdecl idecl params puinst pctx := + map2 set_binder_name pctx (pre_case_predicate_context_gen ind mdecl idecl params puinst). + +(** 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 {term} (c : list (BasicAst.context_decl term)) : list aname := + map (fun decl => decl.(decl_name)) c. + +Lemma forget_types_length {term} (ctx : list (BasicAst.context_decl term)) : + #|forget_types ctx| = #|ctx|. +Proof. + now rewrite /forget_types map_length. +Qed. +Hint Rewrite @forget_types_length : len. + +Definition case_predicate_context ind mdecl idecl p : context := + case_predicate_context_gen ind mdecl idecl p.(pparams) p.(puinst) (forget_types p.(pcontext)). +Arguments case_predicate_context _ _ _ !_. + +Definition case_branch_context_gen ind mdecl params puinst bctx cdecl : context := + subst_context (List.rev params) 0 + (expand_lets_ctx (subst_instance puinst mdecl.(ind_params)) + (* We expand the lets in the context of parameters before + substituting the actual parameters *) + (subst_context (inds (inductive_mind ind) puinst mdecl.(ind_bodies)) #|mdecl.(ind_params)| + (subst_instance puinst + (map2 set_binder_name bctx cdecl.(cstr_args))))). + +Definition case_branch_context ind mdecl p bctx cdecl : context := + case_branch_context_gen ind mdecl p.(pparams) p.(puinst) bctx cdecl. +Arguments case_branch_context _ _ _ _ !_. + +Definition case_branches_contexts_gen ind mdecl idecl params puinst brs : list context := + map2 (case_branch_context_gen ind mdecl params puinst) brs idecl.(ind_ctors). + +Definition case_branches_contexts ind mdecl idecl p brs : list context := + map2 (case_branch_context_gen ind mdecl p.(pparams) p.(puinst)) brs idecl.(ind_ctors). + +Definition case_branch_type_gen ind mdecl (idecl : one_inductive_body) params puinst bctx ptm i cdecl : context * term := + let cstr := tConstruct ind i puinst in + let args := to_extended_list cdecl.(cstr_args) in + let cstrapp := mkApps cstr (map (lift0 #|cdecl.(cstr_args)|) params ++ args) in + let brctx := case_branch_context_gen ind mdecl params puinst bctx cdecl in + let upars := subst_instance puinst mdecl.(ind_params) in + let indices := + (map (subst (List.rev params) #|cdecl.(cstr_args)|) + (map (expand_lets_k upars #|cdecl.(cstr_args)|) + (map (subst (inds (inductive_mind ind) puinst mdecl.(ind_bodies)) + (#|mdecl.(ind_params)| + #|cdecl.(cstr_args)|)) + (map (subst_instance puinst) cdecl.(cstr_indices))))) in + let ty := mkApps (lift0 #|cdecl.(cstr_args)| ptm) (indices ++ [cstrapp]) in + (brctx, ty). + +Definition case_branch_type ind mdecl idecl p (b : branch term) ptm i cdecl : context * term := + case_branch_type_gen ind mdecl idecl p.(pparams) p.(puinst) (forget_types b.(bcontext)) ptm i cdecl. +Arguments case_branch_type _ _ _ _ _ _ _ !_. + +Lemma case_branch_type_fst ci mdecl idecl p br ptm c cdecl : + (case_branch_type ci mdecl idecl p br ptm c cdecl).1 = + (case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl). +Proof. reflexivity. Qed. + +(* Definition case_branches_types_gen ind mdecl idecl params puinst ptm : list (context * term) := + mapi (case_branch_type_gen ind mdecl idecl params puinst ptm) idecl.(ind_ctors). + +Definition case_branches_types ind mdecl idecl p ptm : list (context * term) := + mapi (case_branch_type_gen ind mdecl idecl p.(pparams) p.(puinst) ptm) idecl.(ind_ctors). *) + +Lemma map2_length {A B C} (l : list A) (l' : list B) (f : A -> B -> C) : #|l| = #|l'| -> + #|map2 f l l'| = #|l|. +Proof. + induction l in l' |- *; destruct l' => /= //. + intros [= eq]. now rewrite IHl. +Qed. + +Lemma map2_set_binder_name_context_assumptions + (l : list aname) (l' : context) : #|l| = #|l'| -> + context_assumptions (map2 set_binder_name l l') = context_assumptions l'. +Proof. + induction l in l' |- *; destruct l' => /= //. + intros [= eq]. now rewrite IHl. +Qed. + +Definition idecl_binder idecl := + {| decl_name := + {| binder_name := nNamed idecl.(ind_name); + binder_relevance := idecl.(ind_relevance) |}; + decl_body := None; + decl_type := idecl.(ind_type) |}. + +Definition wf_predicate_gen mdecl idecl (pparams : list term) (pcontext : list aname) : Prop := + let decl := idecl_binder idecl in + (#|pparams| = mdecl.(ind_npars)) /\ + (Forall2 (fun na decl => eq_binder_annot na decl.(decl_name)) + pcontext (decl :: idecl.(ind_indices))). + +Definition wf_predicate mdecl idecl (p : predicate term) : Prop := + wf_predicate_gen mdecl idecl p.(pparams) (forget_types p.(pcontext)). + +Definition wf_predicateb mdecl idecl (p : predicate term) : bool := + let decl := idecl_binder idecl in + eqb #|p.(pparams)| mdecl.(ind_npars) + && forallb2 (fun na decl => eqb_binder_annot na decl.(decl_name)) + (forget_types p.(pcontext)) (decl :: idecl.(ind_indices)). + +Lemma wf_predicateP mdecl idecl p : reflect (wf_predicate mdecl idecl p) (wf_predicateb mdecl idecl p). +Proof. + rewrite /wf_predicate /wf_predicate_gen /wf_predicateb. + case: Reflect.eqb_spec => eqpars /= //. + * case: (forallb2P _ _ (forget_types (pcontext p)) (idecl_binder idecl :: ind_indices idecl) + (fun na decl => eqb_annot_reflect na decl.(decl_name))); constructor => //. + intros [_ Hi]; contradiction. + * constructor; intros [H _]; contradiction. +Qed. + +Definition wf_branch_gen cdecl (bctx : list aname) : Prop := + (Forall2 (fun na decl => eq_binder_annot na decl.(decl_name)) + bctx cdecl.(cstr_args)). + +Definition wf_branch cdecl (b : branch term) : Prop := + wf_branch_gen cdecl (forget_types b.(bcontext)). + +Definition wf_branchb cdecl (b : branch term) : bool := + forallb2 (fun na decl => eqb_binder_annot na decl.(decl_name)) (forget_types b.(bcontext)) cdecl.(cstr_args). + +Lemma wf_branchP cdecl b : reflect (wf_branch cdecl b) (wf_branchb cdecl b). +Proof. + rewrite /wf_branch /wf_branch_gen /wf_branchb. + apply (forallb2P _ _ (forget_types (bcontext b)) (cstr_args cdecl) + (fun na decl => eqb_annot_reflect na decl.(decl_name))). +Qed. + +Definition wf_branches_gen (ctors : list constructor_body) (brs : list (list aname)) : Prop := + Forall2 wf_branch_gen ctors brs. + +Definition wf_branches idecl (brs : list (branch term)) : Prop := + Forall2 wf_branch idecl.(ind_ctors) brs. + +Definition wf_branchesb idecl (brs : list (branch term)) : bool := + forallb2 wf_branchb idecl.(ind_ctors) brs. + +Lemma wf_branchesP idecl brs : reflect (wf_branches idecl brs) (wf_branchesb idecl brs). +Proof. + rewrite /wf_branches /wf_branches_gen /wf_branchesb. + apply (forallb2P _ _ _ _ wf_branchP). +Qed. + +Lemma case_predicate_context_length {ci mdecl idecl p} : + wf_predicate mdecl idecl p -> + #|case_predicate_context (ci_ind ci) mdecl idecl p| = #|p.(pcontext)|. +Proof. + intros hl. + unfold case_predicate_context, case_predicate_context_gen. + rewrite map2_length /= //. + 2:len => //. + destruct hl. + rewrite (Forall2_length H0). now len. +Qed. + +Lemma case_predicate_context_length_indices {ci mdecl idecl p} : + wf_predicate mdecl idecl p -> + #|case_predicate_context (ci_ind ci) mdecl idecl p| = S #|idecl.(ind_indices)|. +Proof. + intros hl. + unfold case_predicate_context, case_predicate_context_gen. + pose proof (Forall2_length (proj2 hl)). simpl in H. + rewrite -H. + rewrite map2_length /= //; len. now len in H. +Qed. + +Lemma wf_predicate_length_pars {mdecl idecl p} : + wf_predicate mdecl idecl p -> + #|p.(pparams)| = ind_npars mdecl. +Proof. + now intros []. +Qed. + +Lemma wf_predicate_length_pcontext {mdecl idecl p} : + wf_predicate mdecl idecl p -> + #|p.(pcontext)| = S #|ind_indices idecl|. +Proof. + intros []. + pose proof (Forall2_length H0). now len in H1. +Qed. + +Lemma wf_branch_length {cdecl br} : + wf_branch cdecl br -> + #|br.(bcontext)| = #|cstr_args cdecl|. +Proof. intros H. apply Forall2_length in H. now len in H. Qed. + +Lemma case_branch_context_length {ind mdecl p br cdecl} : + wf_branch cdecl br -> + #|case_branch_context ind mdecl p (forget_types br.(bcontext)) cdecl| = #|br.(bcontext)|. +Proof. + intros hl. + unfold case_branch_context, case_branch_context_gen; len. + rewrite map2_length //. + * red in hl. + now rewrite (Forall2_length hl). + * now len. +Qed. + +Lemma case_branch_context_length_args {ind mdecl p br cdecl} : + wf_branch cdecl br -> + #|case_branch_context ind mdecl p (forget_types br.(bcontext)) cdecl| = #|cdecl.(cstr_args)|. +Proof. + intros hl. + unfold case_branch_context, case_branch_context_gen; len. + apply Forall2_length in hl. + rewrite map2_length //. +Qed. + +Lemma case_branch_context_assumptions {ind mdecl p br cdecl} : + wf_branch cdecl br -> + context_assumptions (case_branch_context ind mdecl p (forget_types br.(bcontext)) cdecl) = + context_assumptions cdecl.(cstr_args). +Proof. + intros hl. + unfold case_branch_context, case_branch_context_gen; len. + apply Forall2_length in hl. + rewrite /expand_lets_ctx /expand_lets_k_ctx. len. + now rewrite map2_set_binder_name_context_assumptions. +Qed. + +Lemma case_branches_contexts_length {ind mdecl idecl p pctx} : + #|idecl.(ind_ctors)| = #|pctx| -> + #|case_branches_contexts ind mdecl idecl p pctx| = #|pctx|. +Proof. + intros hl. + unfold case_branches_contexts. + rewrite map2_length //. +Qed. + +Lemma case_branch_type_length {ci mdecl idecl p br ptm i cdecl} : + wf_branch cdecl br -> + #|(case_branch_type ci mdecl idecl p br ptm i cdecl).1| = #|cstr_args cdecl|. +Proof. + intros wf; simpl. + now rewrite case_branch_context_length_args. +Qed. + +(* +(** For cases typing *) + +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_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_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. + + +(** Compute the type of a case from the predicate [p], actual parameters [pars] and + an inductive declaration. *) + +Fixpoint instantiate_params_subst + (params : context) + (pars s : list term) + (ty : term) : option (list term × term) := + match params with + | [] => match pars with + | [] => Some (s, ty) + | _ :: _ => None (* Too many arguments to substitute *) + end + | d :: params => + match d.(decl_body), ty with + | None, tProd _ _ B => + match pars with + | hd :: tl => instantiate_params_subst params tl (hd :: s) B + | [] => None (* Not enough arguments to substitute *) + end + | Some b, tLetIn _ _ _ b' => instantiate_params_subst params pars (subst0 s b :: s) b' + | _, _ => None (* Not enough products in the type *) + end + end. + +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. + induction params in pars, s, ty |- *. + - split. + * destruct pars => /= // => [= -> ->]. + constructor. + * intros. depelim H. reflexivity. + - split. + * destruct a as [na [b|] ?] => /=; destruct ty => //. + + move/IHparams. + intros. now constructor. + + destruct pars => //. + move/IHparams. + now constructor. + * intros H; depelim H; simpl; + now apply IHparams. +Qed. + +Universe cpred. + +Variant ind_case_predicate_context ind mdecl idecl params puinst pctx : context -> Type@{cpred} := +| mk_ind_case_predicate_context s ty ictx inds : + instantiate_params_subst_spec + (List.rev (subst_instance puinst (ind_params mdecl))) params [] + (subst_instance puinst (ind_type idecl)) s ty -> + let sty := subst s 0 ty in + sty = it_mkProd_or_LetIn ictx (tSort inds) -> + #|pctx| = S #|ictx| -> + let indty := mkApps (tInd ind puinst) (map (lift0 #|ictx|) params ++ to_extended_list ictx) in + let inddecl := + {| decl_name := + {| binder_name := nNamed (ind_name idecl) ; + binder_relevance := idecl.(ind_relevance) |}; + decl_body := None; + decl_type := indty |} + in + let ictx' := map2 (fun na decl => set_binder_name na decl) pctx (inddecl :: ictx) in + ind_case_predicate_context ind mdecl idecl params puinst pctx ictx'. + +Variant case_predicate_context Σ ci p : context -> Type@{cpred} := +| mk_case_predicate_context mdecl idecl pctx : + declared_inductive Σ (ci_ind ci) mdecl idecl -> + ind_case_predicate_context (ci_ind ci) mdecl idecl p.(pparams) p.(puinst) p.(pcontext) pctx -> + case_predicate_context Σ ci p pctx. + +Variant ind_case_branch_context ind mdecl (cdecl : constructor_body) p : context -> Type@{cpred} := +| mk_ind_case_branch_context s ty argctx indices : + instantiate_params_subst_spec (List.rev (subst_instance p.(puinst) (ind_params mdecl))) p.(pparams) [] + (subst_instance p.(puinst) (cdecl.(cstr_type))) s ty -> + let sty := subst s 0 ty in + sty = it_mkProd_or_LetIn argctx (mkApps (tInd ind p.(puinst)) (map (lift0 #|argctx|) p.(pparams) ++ indices)) -> + ind_case_branch_context ind mdecl cdecl p argctx. + +Definition ind_case_branches_contexts ind mdecl idecl p : list context -> Type@{cpred} := + All2 (fun cdecl brctx => ind_case_branch_context ind mdecl cdecl p brctx) idecl.(ind_ctors). + +Variant case_branches_contexts Σ ci p : list context -> Type@{cpred} := + | mk_case_branches_contexts mdecl idecl brsctx : + declared_inductive Σ (ci_ind ci) mdecl idecl -> + ind_case_branches_contexts (ci_ind ci) mdecl idecl p brsctx -> + case_branches_contexts Σ ci p brsctx. + +Variant ind_case_branch_type ind mdecl (cdecl : constructor_body) i p pctx : context -> term -> Type@{cpred} := +| mk_ind_case_branch_type s ty argctx indices : + instantiate_params_subst_spec (List.rev (subst_instance p.(puinst) (ind_params mdecl))) p.(pparams) [] + (subst_instance p.(puinst) (cdecl.(cstr_type))) s ty -> + let sty := subst s 0 ty in + sty = it_mkProd_or_LetIn argctx (mkApps (tInd ind p.(puinst)) (map (lift0 #|argctx|) p.(pparams) ++ indices)) -> + let cstr := tConstruct ind i p.(puinst) in + let args := to_extended_list argctx in + let cstrapp := mkApps cstr (map (lift0 #|argctx|) p.(pparams) ++ args) in + let ptm := it_mkLambda_or_LetIn pctx p.(preturn) in + let ty := mkApps (lift0 #|argctx| ptm) (indices ++ [cstrapp]) in + ind_case_branch_type ind mdecl cdecl i p pctx argctx ty. + +Definition ind_case_branches_types ind mdecl idecl p pctx : list (context * term) -> Type@{cpred} := + All2i (fun i cdecl '(brctx, brty) => ind_case_branch_type ind mdecl cdecl i p pctx brctx brty) 0 idecl.(ind_ctors). + + +(* If [ty] is [Π params . B] *) +(* and [⊢ pars : params] *) +(* then [instantiate_params] is [B{pars}] *) +Definition instantiate_params (params : context) (pars : list term) (ty : term) : option term := + match instantiate_params_subst (List.rev params) pars [] ty with + | Some (s, ty) => Some (subst0 s ty) + | None => None + end. + +Lemma instantiate_params_ params pars ty : + instantiate_params params pars ty + = option_map (fun '(s, ty) => subst0 s ty) + (instantiate_params_subst (List.rev params) pars [] ty). +Proof. + unfold instantiate_params. + repeat (destruct ?; cbnr). +Qed. +(* +(* [params], [p] and output are already instanciated by [u] *) +Definition build_branches_type ind mdecl idecl params u p : list (option (nat × term)) := + let inds := inds ind.(inductive_mind) u mdecl.(ind_bodies) in + let branch_type i '(id, t, ar) := + let ty := subst0 inds (subst_instance u t) in + match instantiate_params (subst_instance u mdecl.(ind_params)) params ty with + | Some ty => + let '(sign, ccl) := decompose_prod_assum [] ty in + let nargs := List.length sign in + let allargs := snd (decompose_app ccl) in + let '(paramrels, args) := chop mdecl.(ind_npars) allargs in + let cstr := tConstruct ind i u in + let args := (args ++ [mkApps cstr (paramrels ++ to_extended_list sign)]) in + Some (ar, it_mkProd_or_LetIn sign (mkApps (lift0 nargs p) args)) + | None => None + end + in mapi branch_type idecl.(ind_ctors). + +Lemma build_branches_type_ ind mdecl idecl params u p : + build_branches_type ind mdecl idecl params u p + = let inds := inds ind.(inductive_mind) u mdecl.(ind_bodies) in + let branch_type i '(id, t, ar) := + let ty := subst0 inds (subst_instance u t) in + option_map (fun ty => + let '(sign, ccl) := decompose_prod_assum [] ty in + let nargs := List.length sign in + let allargs := snd (decompose_app ccl) in + let '(paramrels, args) := chop mdecl.(ind_npars) allargs in + let cstr := tConstruct ind i u in + let args := (args ++ [mkApps cstr (paramrels ++ to_extended_list sign)]) in + (ar, it_mkProd_or_LetIn sign (mkApps (lift0 nargs p) args))) + (instantiate_params (subst_instance u mdecl.(ind_params)) + params ty) + in mapi branch_type idecl.(ind_ctors). +Proof. + apply mapi_ext. intros ? [[? ?] ?]; cbnr. + repeat (destruct ?; cbnr). +Qed. *) + + +(* [params] and output already instantiated by [u] *) +Definition build_case_predicate_context ind mdecl idecl params u pctx : option context := + index_part <- instantiate_params (subst_instance u (ind_params mdecl)) params + (subst_instance u (ind_type idecl)) ;; + '(Γ, _) <- destArity [] index_part ;; + let inddecl := + {| decl_name := mkBindAnn (nNamed idecl.(ind_name)) idecl.(ind_relevance); + decl_body := None; + decl_type := mkApps (tInd ind u) (map (lift0 #|Γ|) params ++ to_extended_list Γ) |} in + if Reflect.eqb (S #|Γ|) #|pctx| then + let ictx := map2 set_binder_name pctx (Γ ,, inddecl) in + ret ictx + else None. +*) +Lemma lookup_inductive_declared Σ ind mdecl idecl : + lookup_inductive Σ ind = Some (mdecl, idecl) -> + declared_inductive Σ ind mdecl idecl. +Proof. + unfold lookup_inductive, lookup_minductive, declared_inductive, + declared_minductive. + destruct lookup_env => //. + destruct g => //. + destruct nth_error eqn:e => //. + intros [= -> ->]. now rewrite e. +Qed. + +(* +Definition onSome {A} (P : A -> Type) (x : option A) : Type := + match x with + | Some x => P x + | None => False + end. + +Lemma instantiate_params_subst_spec_fn {params pars s ty s' s'' ty' ty''} : + instantiate_params_subst_spec params pars s ty s' ty' -> + instantiate_params_subst_spec params pars s ty s'' ty'' -> + s' = s'' /\ ty' = ty''. +Proof. + induction 1; intros ipars; depelim ipars; auto. +Qed. + +Lemma instantiate_paramsP params pars ty t : + instantiate_params params pars ty = Some t <~> + ∑ s' ty', instantiate_params_subst_spec (List.rev params) pars [] ty s' ty' * + (t = subst0 s' ty'). +Proof. + unfold instantiate_params. + destruct instantiate_params_subst as [[s'' ty'']|] eqn:ipars. + * apply instantiate_params_substP in ipars. + split. + + intros [= <-]. exists s'', ty''; split; auto. + + intros [s' [ty' [H' Heq]]]. subst t. + now destruct (instantiate_params_subst_spec_fn ipars H') as [-> ->]. + * split; intros => //. + + destruct X as [s' [ty' [H' Heq]]]. + eapply instantiate_params_substP in H'. congruence. +Qed. + + +Lemma instantiate_params_subst_make_context_subst ctx args s ty s' ty' : + instantiate_params_subst ctx args s ty = Some (s', ty') -> + ∑ ctx'', + make_context_subst ctx args s = Some s' /\ + decompose_prod_n_assum [] (length ctx) ty = Some (ctx'', ty'). +Proof. + induction ctx in args, s, ty, s' |- *; simpl. + - case: args => [|a args'] // [= <- <-]. exists []; intuition congruence. + - case: a => [na [body|] ty''] /=. + + destruct ty; try congruence. + intros. move: (IHctx _ _ _ _ H) => [ctx'' [Hmake Hdecomp]]. + eapply (decompose_prod_n_assum_extend_ctx [vdef na0 ty1 ty2]) in Hdecomp. + unfold snoc. eexists; intuition eauto. + + destruct ty; try congruence. + case: args => [|a args']; try congruence. + move=> H. move: (IHctx _ _ _ _ H) => [ctx'' [Hmake Hdecomp]]. + eapply (decompose_prod_n_assum_extend_ctx [vass na0 ty1]) in Hdecomp. + unfold snoc. eexists; intuition eauto. +Qed. + +Lemma instantiate_params_make_context_subst ctx args ty ty' : + instantiate_params ctx args ty = Some ty' -> + ∑ ctx' ty'' s', + decompose_prod_n_assum [] (length ctx) ty = Some (ctx', ty'') /\ + make_context_subst (List.rev ctx) args [] = Some s' /\ ty' = subst0 s' ty''. +Proof. + unfold instantiate_params. + case E: instantiate_params_subst => // [[s ty'']]. + move=> [= <-]. + eapply instantiate_params_subst_make_context_subst in E. + destruct E as [ctx'' [Hs Hty'']]. + exists ctx'', ty'', s. split; auto. + now rewrite -> List.rev_length in Hty''. +Qed. +*) + + +(* +Lemma build_case_predicate_type_spec {cf:checker_flags} Σ ind mdecl idecl pars u pctx : + forall (o : on_ind_body (lift_typing typing) Σ (inductive_mind ind) mdecl (inductive_ind ind) idecl), + build_case_predicate_context ind mdecl idecl pars u = Some pctx -> + ∑ parsubst, (context_subst (subst_instance u (ind_params mdecl)) pars parsubst * + (pctx = (subst_context parsubst 0 (subst_instance u o.(ind_indices)) ,, + (vass {| binder_name := nNamed (ind_name idecl); + binder_relevance := idecl.(ind_relevance) |} + (mkApps (tInd ind u) (map (lift0 #|o.(ind_indices)|) pars ++ + to_extended_list o.(ind_indices))))))). +Proof. + intros []. unfold build_case_predicate_context. + destruct instantiate_params eqn:Heq=> //. + eapply instantiate_params_make_context_subst in Heq => /=. + destruct destArity as [[ctx p]|] eqn:Har => //. + move=> [=] <-. destruct Heq as [ctx' [ty'' [s' [? [? ?]]]]]. + subst t. exists s'. split. + * apply make_context_subst_spec in H0. + now rewrite List.rev_involutive in H0. + * clear onProjections. clear onConstructors. + assert (ctx = subst_context s' 0 (subst_instance u ind_indices)) as ->. + { move: H. rewrite ind_arity_eq subst_instance_it_mkProd_or_LetIn. + rewrite decompose_prod_n_assum_it_mkProd app_nil_r => [=]. + move=> Hctx' Hty'. + subst ty'' ctx'. + move: Har. rewrite subst_instance_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. + rewrite destArity_it_mkProd_or_LetIn. simpl. move=> [=] <- /=. + now rewrite app_context_nil_l. } + f_equal. rewrite subst_context_length subst_instance_length. + unfold vass. + f_equal. f_equal. f_equal. + unfold to_extended_list. + rewrite to_extended_list_k_subst map_subst_instance_to_extended_list_k. + reflexivity. +Qed. + + +Lemma instantiate_params_subst_it_mkProd_or_LetIn params pars ty s' ty' : + #|pars| = context_assumptions params -> + instantiate_params_subst_spec (List.rev params) pars [] + (it_mkProd_or_LetIn params ty) s' ty' -> + context_subst params pars s' * (ty = ty'). +Proof. + intros hpars ipars. + eapply instantiate_params_substP in ipars. + eapply instantiate_params_subst_make_context_subst in ipars as [ctx'' [mcs dec]]. + apply make_context_subst_spec in mcs. + rewrite List.rev_involutive in mcs. + split; auto. len in dec. + rewrite decompose_prod_n_assum_it_mkProd app_nil_r in dec. + noconf dec. reflexivity. +Qed. +Derive Signature for context_subst. + +Lemma instantiate_params_subst_it_mkProd_or_LetIn_inv params pars ty s : + context_subst params pars s -> + instantiate_params_subst_spec (List.rev params) pars [] + (it_mkProd_or_LetIn params ty) s ty. +Proof. + intros cs. + rewrite -(List.rev_involutive params) in cs. + rewrite -{2}(List.rev_involutive params). + eapply instantiate_params_substP. + eapply make_context_subst_spec_inv in cs. + revert cs. generalize (@nil term). + revert pars s ty. + induction (List.rev params); intros. + - simpl. now destruct pars; noconf cs. + - simpl. destruct a as [na [b|] bty]; rewrite it_mkProd_or_LetIn_app /=. + * apply IHl. now simpl in cs. + * destruct pars; noconf cs. + apply IHl. now simpl in cs. +Qed. + +Arguments Reflect.eqb : simpl never. + +Lemma ind_case_predicate_contextP ind pparams puinst pcontext mdecl idecl : + forall pctx, + ind_case_predicate_context ind mdecl idecl + pparams puinst pcontext pctx <~> + build_case_predicate_context ind mdecl idecl pparams puinst pcontext = Some pctx. +Proof. + intros pctx. + split. + * intros []. + unfold build_case_predicate_context. + eapply instantiate_params_substP in i. + unfold instantiate_params. + rewrite i /=. + subst sty. rewrite e. + rewrite destArity_it_mkProd_or_LetIn /=. + case: Reflect.eqb_spec; len; [move=> _|congruence]. + subst ictx'. f_equal. f_equal. + rewrite app_context_nil_l /snoc. + f_equal. + * rewrite /build_case_predicate_context. + unfold instantiate_params. + destruct instantiate_params_subst as [[s' ty']|] eqn:ipars => //. + eapply instantiate_params_substP in ipars. + simpl. + destruct destArity as [[Γ ?]|] eqn:da => //. + case: Reflect.eqb_spec => //. + intros eq [= <-]. + econstructor; eauto. + apply destArity_spec_Some in da. simpl in da. eauto. +Qed. + +(** To formalize reduction independently of typing invariants on cases, + each case reduction step carries the contexts necessary to express it. *) + +Record case_contexts Σ ci (p : predicate term) := + { case_pctx : context; + case_brsctxs : list context; + case_pctx_prf : case_predicate_context Σ ci p case_pctx; + case_brsctxs_prf : case_branches_contexts Σ ci p case_brsctxs }. +Arguments case_pctx {Σ ci p}. +Arguments case_brsctxs {Σ ci p}. +Arguments case_pctx_prf {Σ ci p}. +Arguments case_brsctxs_prf {Σ ci p}. + +*) \ No newline at end of file diff --git a/pcuic/theories/PCUICCasesImpl.v b/pcuic/theories/PCUICCasesImpl.v new file mode 100644 index 000000000..04a839fcf --- /dev/null +++ b/pcuic/theories/PCUICCasesImpl.v @@ -0,0 +1,381 @@ +(* From PCUICSigmaCalculus *) +(* +Lemma instantiate_params_subst_length : + forall params pars s t s' t', + instantiate_params_subst params pars s t = Some (s', t') -> + #|params| + #|s| = #|s'|. +Proof. + intros params pars s t s' t' h. + induction params in pars, s, t, s', t', h |- *. + - cbn in h. destruct pars. all: try discriminate. + inversion h. reflexivity. + - cbn in h. destruct (decl_body a). + + destruct t. all: try discriminate. + cbn. eapply IHparams in h. cbn in h. lia. + + destruct t. all: try discriminate. + destruct pars. 1: discriminate. + cbn. eapply IHparams in h. cbn in h. lia. +Qed. + +Lemma instantiate_params_subst_inst : + forall params pars s t σ s' t', + instantiate_params_subst params pars s t = Some (s', t') -> + instantiate_params_subst + (mapi_rec (fun i decl => inst_decl (⇑^i σ) decl) params #|s|) + (map (inst σ) pars) + (map (inst σ) s) + t.[⇑^#|s| σ] + = Some (map (inst σ) s', t'.[⇑^(#|s| + #|params|) σ]). +Proof. + intros params pars s t σ s' t' h. + induction params in pars, s, t, σ, s', t', h |- *. + - simpl in *. destruct pars. 2: discriminate. + simpl. inversion h. subst. clear h. + f_equal. f_equal. f_equal. f_equal. lia. + - simpl in *. destruct (decl_body a). + + simpl. destruct t. all: try discriminate. + simpl. eapply IHparams with (σ := σ) in h. + simpl in h. + replace (#|s| + S #|params|) + with (S (#|s| + #|params|)) + by lia. + rewrite <- h. f_equal. + * f_equal. autorewrite with sigma. + eapply inst_ext. intro i. + unfold Upn, subst_consn, subst_compose. + case_eq (nth_error s i). + -- intros t e. + rewrite nth_error_idsn_Some. + ++ eapply nth_error_Some_length. eassumption. + ++ simpl. + rewrite nth_error_map. rewrite e. simpl. + reflexivity. + -- intro neq. + rewrite nth_error_idsn_None. + ++ eapply nth_error_None. assumption. + ++ simpl. rewrite idsn_length. + autorewrite with sigma. + rewrite <- subst_ids. eapply inst_ext. intro j. + cbn. unfold ids. rewrite map_length. + replace (#|s| + j - #|s|) with j by lia. + rewrite nth_error_map. + erewrite (iffRL (nth_error_None _ _)) by lia. + simpl. reflexivity. + * autorewrite with sigma. reflexivity. + + simpl. destruct t. all: try discriminate. + simpl. destruct pars. 1: discriminate. + simpl. eapply IHparams with (σ := σ) in h. simpl in h. + replace (#|s| + S #|params|) + with (S (#|s| + #|params|)) + by lia. + rewrite <- h. + f_equal. autorewrite with sigma. reflexivity. +Qed. *) + +Lemma instantiate_params_inst : +forall params pars T σ T', + closed_ctx params -> + instantiate_params params pars T = Some T' -> + instantiate_params params (map (inst σ) pars) T.[σ] = Some T'.[σ]. +Proof. +intros params pars T σ T' hcl e. +unfold instantiate_params in *. +case_eq (instantiate_params_subst (List.rev params) pars [] T) ; + try solve [ intro bot ; rewrite bot in e ; discriminate e ]. +intros [s' t'] e'. rewrite e' in e. inversion e. subst. clear e. +eapply instantiate_params_subst_inst with (σ := σ) in e'. +simpl in e'. +autorewrite with sigma in e'. +rewrite List.rev_length in e'. +match type of e' with +| context [ mapi_rec ?f ?l 0 ] => + change (mapi_rec f l 0) with (mapi f l) in e' +end. +rewrite closed_tele_inst in e' ; auto. +rewrite e'. f_equal. autorewrite with sigma. +eapply inst_ext. intro i. +unfold Upn, subst_consn, subst_compose. +rewrite idsn_length map_length. +apply instantiate_params_subst_length in e'. +rewrite List.rev_length map_length in e'. cbn in e'. +replace (#|params| + 0) with #|params| in e' by lia. +rewrite e'. clear e'. +case_eq (nth_error s' i). +- intros t e. + rewrite nth_error_idsn_Some. + { eapply nth_error_Some_length in e. lia. } + simpl. + rewrite nth_error_map. rewrite e. simpl. reflexivity. +- intro neq. + rewrite nth_error_idsn_None. + { eapply nth_error_None in neq. lia. } + simpl. autorewrite with sigma. rewrite <- subst_ids. + eapply inst_ext. intro j. + cbn. unfold ids. + replace (#|s'| + j - #|s'|) with j by lia. + rewrite nth_error_map. + erewrite (iffRL (nth_error_None _ _)) by lia. + simpl. reflexivity. +Qed. + +Corollary instantiate_params_rename : +forall params pars T f T', + closed_ctx params -> + instantiate_params params pars T = Some T' -> + instantiate_params params (map (rename f) pars) (rename f T) = + Some (rename f T'). +Proof. +intros params pars T f T' hcl e. +eapply instantiate_params_inst with (σ := ren f) in e. 2: auto. +autorewrite with sigma. rewrite <- e. f_equal. +Qed. + +Lemma build_branches_type_rename : +forall ind mdecl idecl args u p brs f, + closed_ctx (subst_instance u (ind_params mdecl)) -> + map_option_out (build_branches_type ind mdecl idecl args u p) = Some brs -> + map_option_out ( + build_branches_type + ind + mdecl + (map_one_inductive_body + (context_assumptions (ind_params mdecl)) + #|arities_context (ind_bodies mdecl)| + (fun i : nat => rename (shiftn i f)) + (inductive_ind ind) + idecl + ) + (map (rename f) args) + u + (rename f p) + ) = Some (map (on_snd (rename f)) brs). +Proof. +intros ind mdecl idecl args u p brs f hcl. +unfold build_branches_type. +destruct idecl as [ina ity ike ict ipr]. simpl. +unfold mapi. +generalize 0 at 3 6. +intros n h. +induction ict in brs, n, h, f |- *. +- cbn in *. inversion h. reflexivity. +- cbn. cbn in h. + lazymatch type of h with + | match ?t with _ => _ end = _ => + case_eq (t) ; + try (intro bot ; rewrite bot in h ; discriminate h) + end. + intros [m t] e'. rewrite e' in h. + destruct a as [[na ta] ar]. + lazymatch type of e' with + | match ?expr with _ => _ end = _ => + case_eq (expr) ; + try (intro bot ; rewrite bot in e' ; discriminate e') + end. + intros ty ety. rewrite ety in e'. + eapply instantiate_params_rename with (f := f) in ety as ety'. + 2: assumption. + simpl. + match goal with + | |- context [ instantiate_params _ _ ?t ] => + match type of ety' with + | instantiate_params _ _ ?t' = _ => + replace t with t' ; revgoals + end + end. + { clear e' ety h IHict ety'. + rewrite <- rename_subst_instance. + rewrite arities_context_length. + autorewrite with sigma. + eapply inst_ext. intro i. + unfold shiftn, ren, subst_compose, subst_consn. simpl. + case_eq (nth_error (inds (inductive_mind ind) u (ind_bodies mdecl)) i). + + intros t' e. + eapply nth_error_Some_length in e as hl. + rewrite inds_length in hl. + destruct (Nat.ltb_spec i #|ind_bodies mdecl|) ; try lia. + rewrite e. + give_up. + + intro neq. + eapply nth_error_None in neq as hl. + rewrite inds_length in hl. + rewrite inds_length. + destruct (Nat.ltb_spec i #|ind_bodies mdecl|) ; try lia. + unfold ids. simpl. + rewrite (iffRL (nth_error_None _ _)). + { rewrite inds_length. lia. } + f_equal. lia. + } + rewrite ety'. + case_eq (decompose_prod_assum [] ty). intros sign ccl edty. + rewrite edty in e'. + (* TODO inst edty *) + case_eq (chop (ind_npars mdecl) (snd (decompose_app ccl))). + intros paramrels args' ech. rewrite ech in e'. + (* TODO inst ech *) + inversion e'. subst. clear e'. + lazymatch type of h with + | match ?t with _ => _ end = _ => + case_eq (t) ; + try (intro bot ; rewrite bot in h ; discriminate h) + end. + intros tl etl. rewrite etl in h. + (* TODO inst etl *) + inversion h. subst. clear h. + (* edestruct IHict as [brtys' [eq' he]]. *) + (* + eauto. *) + (* + eexists. rewrite eq'. split. *) + (* * reflexivity. *) + (* * constructor ; auto. *) + (* simpl. split ; auto. *) + (* eapply eq_term_upto_univ_it_mkProd_or_LetIn ; auto. *) + (* eapply eq_term_upto_univ_mkApps. *) + (* -- eapply eq_term_upto_univ_lift. assumption. *) + (* -- apply All2_same. intro. apply eq_term_upto_univ_refl ; auto. *) +Admitted. + + +Lemma build_branches_type_inst : + forall ind mdecl idecl args u p brs σ, + closed_ctx (subst_instance u (ind_params mdecl)) -> + map_option_out (build_branches_type ind mdecl idecl args u p) = Some brs -> + map_option_out ( + build_branches_type + ind + mdecl + (map_one_inductive_body + (context_assumptions (ind_params mdecl)) + #|arities_context (ind_bodies mdecl)| + (fun i : nat => inst (⇑^i σ)) + (inductive_ind ind) + idecl + ) + (map (inst σ) args) + u + p.[σ] + ) = Some (map (on_snd (inst σ)) brs). +Proof. + intros ind mdecl idecl args u p brs σ hcl. + unfold build_branches_type. + destruct idecl as [ina ity ike ict ipr]. simpl. + unfold mapi. + generalize 0 at 3 6. + intros n h. + induction ict in brs, n, h, σ |- *. + - cbn in *. inversion h. reflexivity. + - cbn. cbn in h. + lazymatch type of h with + | match ?t with _ => _ end = _ => + case_eq (t) ; + try (intro bot ; rewrite bot in h ; discriminate h) + end. + intros [m t] e'. rewrite e' in h. + destruct a as [[na ta] ar]. + lazymatch type of e' with + | match ?expr with _ => _ end = _ => + case_eq (expr) ; + try (intro bot ; rewrite bot in e' ; discriminate e') + end. + intros ty ety. rewrite ety in e'. + eapply instantiate_params_inst with (σ := σ) in ety as ety'. 2: assumption. + autorewrite with sigma. simpl. + autorewrite with sigma in ety'. + rewrite <- inst_subst_instance. + autorewrite with sigma. + match goal with + | |- context [ instantiate_params _ _ ?t.[?σ] ] => + match type of ety' with + | instantiate_params _ _ ?t'.[?σ'] = _ => + replace t.[σ] with t'.[σ'] ; revgoals + end + end. + { eapply inst_ext. intro i. + unfold Upn, subst_compose, subst_consn. + rewrite arities_context_length. + case_eq (nth_error (inds (inductive_mind ind) u (ind_bodies mdecl)) i). + - intros t' e. + rewrite nth_error_idsn_Some. + { eapply nth_error_Some_length in e. + rewrite inds_length in e. assumption. + } + simpl. rewrite e. + give_up. + - intro neq. simpl. rewrite inds_length idsn_length. + rewrite nth_error_idsn_None. + { eapply nth_error_None in neq. rewrite inds_length in neq. lia. } + give_up. + } + rewrite ety'. + case_eq (decompose_prod_assum [] ty). intros sign ccl edty. + rewrite edty in e'. + (* TODO inst edty *) + case_eq (chop (ind_npars mdecl) (snd (decompose_app ccl))). + intros paramrels args' ech. rewrite ech in e'. + (* TODO inst ech *) + inversion e'. subst. clear e'. + lazymatch type of h with + | match ?t with _ => _ end = _ => + case_eq (t) ; + try (intro bot ; rewrite bot in h ; discriminate h) + end. + intros tl etl. rewrite etl in h. + (* TODO inst etl *) + inversion h. subst. clear h. + (* edestruct IHict as [brtys' [eq' he]]. *) + (* + eauto. *) + (* + eexists. rewrite eq'. split. *) + (* * reflexivity. *) + (* * constructor ; auto. *) + (* simpl. split ; auto. *) + (* eapply eq_term_upto_univ_it_mkProd_or_LetIn ; auto. *) + (* eapply eq_term_upto_univ_mkApps. *) + (* -- eapply eq_term_upto_univ_lift. assumption. *) + (* -- apply All2_same. intro. apply eq_term_upto_univ_refl ; auto. *) +Admitted. + +(* Lemma types_of_case_inst : *) +(* forall Σ ind mdecl idecl npar args u p pty indctx pctx ps btys σ, *) +(* wf Σ -> *) +(* declared_inductive Σ ind mdecl idecl -> *) +(* types_of_case ind mdecl idecl (firstn npar args) u p pty = *) +(* Some (indctx, pctx, ps, btys) -> *) +(* types_of_case ind mdecl idecl (firstn npar (map (inst σ) args)) u p.[σ] pty.[σ] = *) +(* Some (inst_context σ indctx, inst_context σ pctx, ps, map (on_snd (inst σ)) btys). *) +(* Proof. *) +(* intros Σ ind mdecl idecl npar args u p pty indctx pctx ps btys σ hΣ hdecl h. *) +(* unfold types_of_case in *. *) +(* case_eq (instantiate_params (subst_instance u (ind_params mdecl)) (firstn npar args) (subst_instance u (ind_type idecl))) ; *) +(* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) +(* intros ity eity. rewrite eity in h. *) +(* pose proof (on_declared_inductive hΣ as hdecl) [onmind onind]. *) +(* apply onParams in onmind as Hparams. *) +(* assert (closedparams : closed_ctx (subst_instance u (ind_params mdecl))). *) +(* { rewrite closedn_subst_instance. *) +(* eapply PCUICWeakening.closed_wf_local. all: eauto. eauto. } *) +(* epose proof (inst_declared_inductive _ mdecl ind idecl σ hΣ) as hi. *) +(* forward hi by assumption. rewrite <- hi. *) +(* eapply instantiate_params_inst with (σ := σ) in eity ; auto. *) +(* rewrite -> ind_type_map. *) +(* rewrite firstn_map. *) +(* autorewrite with sigma. *) +(* (* rewrite eity. *) *) +(* (* case_eq (destArity [] ity) ; *) *) +(* (* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) *) +(* (* intros [args0 ?] ear. rewrite ear in h. *) *) +(* (* eapply inst_destArity with (σ := σ) in ear as ear'. *) *) +(* (* simpl in ear'. autorewrite with sigma in ear'. *) *) +(* (* rewrite ear'. *) *) +(* (* case_eq (destArity [] pty) ; *) *) +(* (* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) *) +(* (* intros [args' s'] epty. rewrite epty in h. *) *) +(* (* eapply inst_destArity with (σ := σ) in epty as epty'. *) *) +(* (* simpl in epty'. autorewrite with sigma in epty'. *) *) +(* (* rewrite epty'. *) *) +(* (* case_eq (map_option_out (build_branches_type ind mdecl idecl (firstn npar args) u p)) ; *) *) +(* (* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) *) +(* (* intros brtys ebrtys. rewrite ebrtys in h. *) *) +(* (* inversion h. subst. clear h. *) *) +(* (* eapply build_branches_type_inst with (σ := σ) in ebrtys as ebrtys'. *) *) +(* (* 2: assumption. *) *) +(* (* rewrite ebrtys'. reflexivity. *) *) +(* (* Qed. *) *) +(* Admitted. *) diff --git a/pcuic/theories/PCUICClosed.v b/pcuic/theories/PCUICClosed.v index 35a50d762..8c148dcea 100644 --- a/pcuic/theories/PCUICClosed.v +++ b/pcuic/theories/PCUICClosed.v @@ -1,57 +1,79 @@ (* Distributed under the terms of the MIT license. *) +From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction - PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICWeakeningEnv. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction + PCUICLiftSubst PCUICUnivSubst PCUICContextRelation PCUICTyping PCUICWeakeningEnv. Require Import ssreflect ssrbool. From Equations Require Import Equations. - -Lemma All_forallb_eq_forallb {A} (P : A -> Type) (p q : A -> bool) l : - All P l -> - (forall x, P x -> p x = q x) -> - forallb p l = forallb q l. -Proof. - induction 1; simpl; intuition (f_equal; auto). -Qed. - (** * Lemmas about the [closedn] predicate *) -Definition closed_decl n d := - option_default (closedn n) d.(decl_body) true && closedn n d.(decl_type). - -Definition closedn_ctx n ctx := - forallb id (mapi (fun k d => closed_decl (n + k) d) (List.rev ctx)). - -Notation closed_ctx ctx := (closedn_ctx 0 ctx). +Notation closed_decl n := (test_decl (closedn n)). +Notation closedn_ctx := (test_context_k closedn). +Notation closed_ctx := (closedn_ctx 0). Lemma lift_decl_closed n k d : closed_decl k d -> lift_decl n k d = d. Proof. - case: d => na [body|] ty; rewrite /closed_decl /lift_decl /map_decl /=. + case: d => na [body|] ty; rewrite /test_decl /lift_decl /map_decl /=; unf_term. - move/andP => [cb cty]. now rewrite !lift_closed //. - move=> cty; now rewrite !lift_closed //. Qed. Lemma closed_decl_upwards k d : closed_decl k d -> forall k', k <= k' -> closed_decl k' d. Proof. - case: d => na [body|] ty; rewrite /closed_decl /=. - - move/andP => [cb cty] k' lek'. do 2 rewrite (@closed_upwards k) //. + case: d => na [body|] ty; rewrite /test_decl /=. + - move/andP => /= [cb cty] k' lek'. do 2 rewrite (@closed_upwards k) //. - move=> cty k' lek'; rewrite (@closed_upwards k) //. Qed. +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. +Proof. + intros Hf. + rewrite /fold_context_k /mapi. + generalize 0. + induction ctx using rev_ind; simpl; intros n; auto. + rewrite List.rev_app_distr /=. + move/andP=> [] Hc Hd. + rewrite Hf //; len. f_equal. + now apply IHctx. +Qed. + +Lemma closedn_ctx_cons n d Γ : closedn_ctx n (d :: Γ) = closedn_ctx n Γ && closed_decl (n + #|Γ|) d. +Proof. + rewrite /=. rewrite Nat.add_comm. bool_congr. +Qed. + +Lemma test_context_k_app p n Γ Γ' : + test_context_k p n (Γ ,,, Γ') = + test_context_k p n Γ && test_context_k p (n + #|Γ|) Γ'. +Proof. + rewrite /app_context /= !test_context_k_eq List.rev_app_distr alli_app /=. f_equal. + rewrite List.rev_length. + rewrite Nat.add_0_r alli_shift. + now setoid_rewrite Nat.add_assoc. +Qed. + +Lemma closedn_ctx_app n Γ Γ' : + closedn_ctx n (Γ ,,, Γ') = + closedn_ctx n Γ && closedn_ctx (n + #|Γ|) Γ'. +Proof. + now rewrite test_context_k_app. +Qed. + Lemma closed_ctx_lift n k ctx : closedn_ctx k ctx -> lift_context n k ctx = ctx. Proof. induction ctx in n, k |- *; auto. - unfold closed_ctx, id. rewrite lift_context_snoc. + rewrite closedn_ctx_cons lift_context_snoc. simpl. - rewrite /mapi mapi_rec_app forallb_app List.rev_length /= /snoc Nat.add_0_r. - move/andb_and => /= [Hctx /andb_and [Ha _]]. - f_equal. rewrite lift_decl_closed. apply: closed_decl_upwards; eauto. lia. - reflexivity. - rewrite IHctx // lift_decl_closed //. + move/andb_and => /= [Hctx Hd]. + f_equal. rewrite IHctx // lift_decl_closed // Nat.add_comm //. Qed. -Lemma map_decl_ext' f g k d : closed_decl k d -> +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. @@ -63,20 +85,54 @@ Proof. now rewrite Hfg. Qed. +Lemma test_decl_map_decl (p : term -> bool) (f : term -> term) d : + test_decl p (map_decl f d) = test_decl (p ∘ f) d. +Proof. + rewrite /test_decl /map_decl; destruct d; simpl. + now destruct decl_body. +Qed. + +Lemma plus_minus' n m : n + m - m = n. +Proof. lia. Qed. + +Lemma test_context_k_mapi (p : nat -> term -> bool) k (f : nat -> term -> term) ctx : + test_context_k p k (mapi_context f ctx) = + test_context_k (fun i t => p i (f (i - k) t)) k ctx. +Proof. + induction ctx; simpl; auto. + rewrite IHctx. f_equal. rewrite test_decl_map_decl. + len. now setoid_rewrite plus_minus'. +Qed. +Hint Rewrite test_context_k_mapi : map. + +Lemma test_context_k_map (p : nat -> term -> bool) k (f : term -> term) ctx : + test_context_k p k (map_context f ctx) = + test_context_k (fun i t => p i (f t)) k ctx. +Proof. + induction ctx; simpl; auto. + rewrite IHctx. f_equal. rewrite test_decl_map_decl. + now len. +Qed. +Hint Rewrite test_context_k_map : map. + Lemma closedn_lift n k k' t : closedn k t -> closedn (k + n) (lift n k' t). Proof. revert k. induction t in n, k' |- * using term_forall_list_ind; intros; simpl in *; rewrite -> ?andb_and in *; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc; + autorewrite with map; simpl closed in *; solve_all; - unfold test_def, test_snd in *; - try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; solve_all)]; try easy. + unfold test_def, test_snd, test_predicate_k, test_branch_k in *; + try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy. - elim (Nat.leb_spec k' n0); intros. simpl. elim (Nat.ltb_spec); auto. apply Nat.ltb_lt in H. lia. simpl. elim (Nat.ltb_spec); auto. intros. apply Nat.ltb_lt in H. lia. + + - simpl. rtoProp; solve_all. len. + now eapply i. + - simpl. rtoProp; solve_all. len. now eapply b0. Qed. Lemma closedn_lift_inv n k k' t : k <= k' -> @@ -85,9 +141,11 @@ Lemma closedn_lift_inv n k k' t : k <= k' -> Proof. induction t in n, k, k' |- * using term_forall_list_ind; intros; simpl in *; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc in *; - simpl closed in *; repeat (rtoProp; solve_all); try change_Sk; - unfold test_def, on_snd, test_snd in *; simpl in *; eauto with all. + 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 *; + rewrite -> ?map_length, ?Nat.add_assoc in *; + simpl in *; eauto 2 with all. - revert H0. elim (Nat.leb_spec k n0); intros. simpl in *. @@ -96,28 +154,34 @@ Proof. - specialize (IHt2 n (S k) (S k')). eauto with all. - specialize (IHt2 n (S k) (S k')). eauto with all. - specialize (IHt3 n (S k) (S k')). eauto with all. - - rtoProp. solve_all. specialize (b0 n (#|m| + k) (#|m| + k')). eauto with all. + - rtoProp. solve_all; unfold shiftf in *. + * rewrite test_context_k_mapi in H4. + eapply test_context_k_eqP_id_spec; tea. simpl; intuition auto. + rewrite Nat.add_assoc in H6. + eapply H5; [|tea]. lia. + * eapply (i n (#|pcontext p| + k)). lia. + now len in H3. + - rtoProp. solve_all; unfold shiftf in *. + * rewrite test_context_k_mapi in H1. + solve_all. rewrite Nat.add_assoc in H7. + eapply H6; [|eauto with all]. lia. + * eapply (b0 n (#|bcontext x| + k)); eauto; try lia. + now len in H3. + - rtoProp. solve_all. specialize (b0 n (#|m| + k) (#|m| + k')). + now len in H1. - rtoProp. solve_all. specialize (b0 n (#|m| + k) (#|m| + k')). eauto with all. Qed. Lemma closedn_mkApps k f u: - closedn k f -> forallb (closedn k) u -> - closedn k (mkApps f u). -Proof. - induction u in k, f |- *; simpl; auto. - move=> Hf /andb_and[Ha Hu]. apply IHu. simpl. now rewrite Hf Ha. auto. -Qed. - -Lemma closedn_mkApps_inv k f u: - closedn k (mkApps f u) -> - closedn k f && forallb (closedn k) u. + closedn k (mkApps f u) = closedn k f && forallb (closedn k) u. Proof. induction u in k, f |- *; simpl; auto. - now rewrite andb_true_r. - - move/IHu/andb_and => /= [/andb_and[Hf Ha] Hu]. - now rewrite Hf Ha Hu. + - now rewrite IHu /= andb_assoc. Qed. +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 -> closedn (k + k' + #|s|) t = @@ -126,9 +190,10 @@ Proof. intros Hs. solve_all. revert Hs. induction t in k' |- * using term_forall_list_ind; intros; simpl in *; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + autorewrite with map => //; simpl closed in *; try change_Sk; - unfold test_def, on_snd, test_snd in *; simpl in *; eauto 4 with all. + unfold test_def, test_branch_k, test_predicate_k in *; simpl in *; + solve_all. - elim (Nat.leb_spec k' n); intros. simpl. destruct nth_error eqn:Heq. @@ -144,9 +209,6 @@ Proof. elim: Nat.ltb_spec; symmetry. apply Nat.ltb_lt. lia. apply Nat.ltb_nlt. intro. lia. - - rewrite forallb_map. - eapply All_forallb_eq_forallb; eauto. - - specialize (IHt2 (S k')). rewrite <- Nat.add_succ_comm in IHt2. rewrite IHt1 // IHt2 //. @@ -156,25 +218,28 @@ Proof. - specialize (IHt3 (S k')). rewrite <- Nat.add_succ_comm in IHt3. rewrite IHt1 // IHt2 // IHt3 //. - - rewrite IHt1 // IHt2 //. - rewrite forallb_map. simpl. - bool_congr. eapply All_forallb_eq_forallb; eauto. - - rewrite forallb_map. simpl. - eapply All_forallb_eq_forallb; eauto. simpl. - intros x [h1 h2]. rewrite h1 //. - specialize (h2 (#|m| + k')). - rewrite Nat.add_assoc in h2. - rewrite (Nat.add_comm k #|m|) in h2. - rewrite -> !Nat.add_assoc in *. - rewrite h2 //. - - rewrite forallb_map. simpl. - eapply All_forallb_eq_forallb; eauto. simpl. - intros x [h1 h2]. rewrite h1 //. - specialize (h2 (#|m| + k')). - rewrite Nat.add_assoc in h2. - rewrite (Nat.add_comm k #|m|) in h2. - rewrite -> !Nat.add_assoc in *. - rewrite h2 //. + - rewrite IHt //. + f_equal; [|solve_all;f_equal]. f_equal. f_equal. f_equal. + all:len; solve_all. + * rewrite (Nat.add_comm i) -(Nat.add_assoc k). rewrite H //. + unfold shiftf. lia_f_equal. + * specialize (e (#|pcontext p| + k')). + now rewrite Nat.add_assoc (Nat.add_comm k) in e. + * specialize (H (i + k')). + rewrite (Nat.add_comm i) -(Nat.add_assoc k). rewrite H //. + unfold shiftf. lia_f_equal. + * specialize (b (#|bcontext x| + k')). + now rewrite Nat.add_assoc (Nat.add_comm k) in b. + - rewrite a //. + specialize (b (#|m| + k')). + rewrite Nat.add_assoc 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 b //. Qed. Lemma closedn_subst_eq' s k k' t : @@ -184,9 +249,9 @@ Proof. intros Hs. solve_all. revert Hs. induction t in k' |- * using term_forall_list_ind; intros; simpl in *; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + autorewrite with map; simpl closed in *; repeat (rtoProp; f_equal; solve_all); try change_Sk; - unfold test_def, on_snd, test_snd in *; simpl in *; eauto 4 with all. + unfold test_def, map_branch, test_branch, test_predicate in *; simpl in *; eauto 4 with all. - move: Hs; elim (Nat.leb_spec k' n); intros. simpl. destruct nth_error eqn:Heq. @@ -204,15 +269,30 @@ Proof. rewrite <- Nat.add_succ_comm in IHt2. eauto. - specialize (IHt3 (S k')). rewrite <- Nat.add_succ_comm in IHt3. eauto. + - move/andb_and: H => [hpar hret]. + rewrite !Nat.add_assoc in hret. + specialize (i (#|pcontext p| + k')). + rewrite Nat.add_assoc (Nat.add_comm k) in i. + simpl in *. unfold test_predicate_k. simpl. solve_all. + * rewrite test_context_k_mapi /shiftf in H2. solve_all. + rewrite (Nat.add_comm i0) -(Nat.add_assoc k); eauto. + eapply H3. + red; rewrite -H4. lia_f_equal. + * rewrite i //. len in hret. eauto. + - unfold test_branch_k in *. rtoProp; solve_all. + * rewrite test_context_k_mapi /shiftf in H0. + solve_all. rewrite (Nat.add_comm i0) -(Nat.add_assoc k); eauto. + eapply H3. red; rewrite -H4; lia_f_equal. + * specialize (b0 (#|bcontext x| + k')). + rewrite Nat.add_assoc (Nat.add_comm k) in b0. + 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 in *. 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 in *. rewrite b0 //. now autorewrite with len in hbod. Qed. @@ -242,105 +322,35 @@ Proof. rewrite H. now apply lift_closed. Qed. -Local Open Scope sigma. - -Require Import Morphisms. - Instance Upn_ext n : Proper (`=1` ==> `=1`) (Upn n). - Proof. - unfold Upn. reduce_goal. now rewrite H. - Qed. - - Instance Up_ext : Proper (`=1` ==> `=1`) Up. - Proof. - unfold Up. reduce_goal. unfold subst_compose, subst_cons. - destruct a. reflexivity. now rewrite H. - Qed. - - Lemma Upn_S σ n : ⇑^(S n) σ =1 ⇑ ⇑^n σ. - Proof. - rewrite Upn_Up. induction n in σ |- *. rewrite !Upn_0. now eapply Up_ext. - rewrite Upn_Up. rewrite IHn. eapply Up_ext. now rewrite Upn_Up. - Qed. - Hint Rewrite Upn_0 Upn_S : sigma. - - Ltac sigma := autorewrite with sigma. - -Instance up_proper k : Proper (`=1` ==> `=1`) (up k). -Proof. reduce_goal. now apply up_ext. Qed. - -Lemma Upn_Upn k k' σ : ⇑^(k + k') σ =1 ⇑^k (⇑^k' σ). -Proof. - setoid_rewrite <- up_Upn. rewrite -(@up_Upn k'). - symmetry; apply up_up. -Qed. -Hint Rewrite Upn_Upn : sigma. - -Lemma inst_closed σ k t : closedn k t -> t.[⇑^k σ] = t. -Proof. - intros Hs. - induction t in σ, k, Hs |- * using term_forall_list_ind; intros; sigma; - simpl in *; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc in *; - simpl closed in *; repeat (rtoProp; f_equal; solve_all); try change_Sk; - unfold test_def, on_snd, test_snd in *; simpl in *; eauto with all. - - - revert Hs. - unfold Upn. - elim (Nat.ltb_spec n k); intros. simpl in *. - destruct (subst_consn_lt (l := idsn k) (i := n)) as [t [Heq Heq']]. - + now rewrite idsn_length //. - + now rewrite idsn_lt in Heq. - + discriminate. - - specialize (IHt2 σ (S k) H0). rewrite -{2}IHt2. now sigma. - - specialize (IHt2 σ (S k) H0). rewrite -{2}IHt2. now sigma. - - specialize (IHt3 σ (S k) H0). rewrite -{2}IHt3. now sigma. - - rtoProp. specialize (b0 σ (#|m| + k) H0). eapply map_def_id_spec; auto. - revert b0. now sigma. - - rtoProp. specialize (b0 σ (#|m| + k) H0). eapply map_def_id_spec; auto. - revert b0. now sigma. -Qed. - -Lemma closedn_subst_instance_constr k t u : - closedn k (subst_instance_constr u t) = closedn k t. +Lemma closedn_subst_instance k t u : + closedn k (subst_instance u t) = closedn k t. Proof. revert k. induction t in |- * using term_forall_list_ind; intros; simpl in *; rewrite -> ?andb_and in *; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def; - try solve [repeat (f_equal; eauto)]; simpl closed in *; - try rewrite ?map_length; intuition auto. - - - rewrite forallb_map; eapply All_forallb_eq_forallb; eauto. - - red in X. rewrite forallb_map. f_equal; eauto using All_forallb_eq_forallb. - f_equal; eauto. - - red in X. rewrite forallb_map. - eapply All_forallb_eq_forallb; eauto. - unfold test_def, map_def. simpl. + autorewrite with map; len; + unfold test_predicate_k, test_branch_k in *; solve_all. + + - unfold test_predicate_k, map_predicate; simpl. + f_equal. f_equal. f_equal. f_equal. + all: len; solve_all. + f_equal; len; solve_all. + - unfold test_def, map_def. simpl. do 3 (f_equal; intuition eauto). - - red in X. rewrite forallb_map. - eapply All_forallb_eq_forallb; eauto. - unfold test_def, map_def. simpl. + - unfold test_def, map_def. simpl. do 3 (f_equal; intuition eauto). Qed. Lemma closed_map_subst_instance n u l : - forallb (closedn n) (map (subst_instance_constr u) l) = + forallb (closedn n) (map (subst_instance u) l) = forallb (closedn n) l. Proof. induction l; simpl; auto. - now rewrite closedn_subst_instance_constr IHl. + now rewrite closedn_subst_instance IHl. Qed. -Lemma destArity_spec ctx T : - match destArity ctx T with - | Some (ctx', s) => it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s) - | None => True - end. -Proof. - induction T in ctx |- *; simpl; try easy. - specialize (IHT2 (ctx,, vass na T1)). now destruct destArity. - specialize (IHT3 (ctx,, vdef na T1 T2)). now destruct destArity. -Qed. +Lemma closedn_ctx_tip n d : closedn_ctx n [d] = closed_decl n d. +Proof. now rewrite test_context_k_eq /= andb_true_r Nat.add_0_r. Qed. Lemma closedn_All_local_closed: forall (cf : checker_flags) (Σ : global_env_ext) (Γ : context) (ctx : list context_decl) @@ -353,56 +363,22 @@ Proof. intros cf Σ Γ ctx wfΓ' al. remember (Γ ,,, ctx) as Γ'. revert Γ' wfΓ' ctx HeqΓ' al. induction Γ. simpl. intros. subst. unfold app_context in *. rewrite app_nil_r in wfΓ' al. - induction al; try constructor. unfold closedn_ctx. - unfold snoc. simpl. rewrite mapi_app forallb_app. simpl. - rewrite Nat.add_0_r. cbn. - move/andP: p => [] Ht _. rewrite List.rev_length Ht. - unfold closed_ctx in IHal. - now rewrite IHal. - unfold closed_ctx. simpl. - rewrite mapi_app forallb_app /= List.rev_length /closed_decl /= Nat.add_0_r p. - unfold closed_ctx in IHal. - now rewrite IHal. + induction al; try constructor; + rewrite closedn_ctx_cons /=; cbn. + move/andP: p => [] /= -> _. now rewrite IHal. + now rewrite IHal /= /test_decl /=. intros. - unfold app_context in *. subst Γ'. simpl. - unfold closed_ctx. specialize (IHΓ (ctx ++ a :: Γ) wfΓ' (ctx ++ [a])). + unfold app_context in *. subst Γ'. + specialize (IHΓ (ctx ++ a :: Γ) wfΓ' (ctx ++ [a])). rewrite -app_assoc in IHΓ. specialize (IHΓ eq_refl al). - simpl. rewrite mapi_app forallb_app. - move/andP: IHΓ => []. unfold closed_ctx. - simpl. rewrite List.rev_length rev_app_distr mapi_app forallb_app /=. - intros ->. move/andP => [/andP [->]] _. simpl. - intros. red. red in b. rewrite -b. - rewrite !mapi_rev !forallb_rev. f_equal. eapply mapi_ext. intros. - f_equal. lia. -Qed. - -Require Import ssrbool. - -Lemma closedn_ctx_cons n d Γ : closedn_ctx n (d :: Γ) = closedn_ctx n Γ && closed_decl (n + #|Γ|) d. -Proof. - unfold closedn_ctx. - simpl. rewrite mapi_app. rewrite forallb_app /= andb_true_r. - now rewrite Nat.add_0_r List.rev_length. -Qed. - -Lemma closedn_ctx_app n Γ Γ' : - closedn_ctx n (Γ ,,, Γ') = - closedn_ctx n Γ && closedn_ctx (n + #|Γ|) Γ'. -Proof. - rewrite /closedn_ctx /app_context /= List.rev_app_distr mapi_app forallb_app /=. - bool_congr. - rewrite List.rev_length. - f_equal. eapply mapi_ext. intros. - f_equal. lia. + rewrite closedn_ctx_app /= Nat.add_1_r andb_assoc in IHΓ. + now rewrite closedn_ctx_cons /=. Qed. -Lemma closedn_mkProd_or_LetIn (Γ : context) d T : - closed_decl #|Γ| d -> - closedn (S #|Γ|) T -> closedn #|Γ| (mkProd_or_LetIn d T). +Lemma closedn_mkProd_or_LetIn n d T : + closed_decl n d && closedn (S n) T = closedn n (mkProd_or_LetIn d T). Proof. - destruct d as [na [b|] ty]; simpl in *. unfold closed_decl. - simpl. now move/andP => [] -> ->. - simpl. now move/andP => [] /= _ -> ->. + destruct d as [na [b|] ty]; reflexivity. Qed. Lemma closedn_mkLambda_or_LetIn (Γ : context) d T : @@ -410,22 +386,19 @@ Lemma closedn_mkLambda_or_LetIn (Γ : context) d T : closedn (S #|Γ|) T -> closedn #|Γ| (mkLambda_or_LetIn d T). Proof. destruct d as [na [b|] ty]; simpl in *. unfold closed_decl. - simpl. now move/andP => [] -> ->. + simpl. now move/andP => [] /= -> ->. simpl. now move/andP => [] /= _ -> ->. Qed. -Lemma closedn_it_mkProd_or_LetIn - (Γ : context) (ctx : list context_decl) T : - closedn_ctx #|Γ| ctx -> - closedn (#|Γ| + #|ctx|) T -> closedn #|Γ| (it_mkProd_or_LetIn ctx T). +Lemma closedn_it_mkProd_or_LetIn n (ctx : list context_decl) T : + closedn n (it_mkProd_or_LetIn ctx T) = + closedn_ctx n ctx && closedn (n + #|ctx|) T. Proof. - induction ctx in Γ, T |- *. simpl. + induction ctx in n, T |- *. simpl. - now rewrite Nat.add_0_r. - - rewrite closedn_ctx_cons. move/andP => [] cctx ca cT. - apply (IHctx Γ (mkProd_or_LetIn a T) cctx). - simpl in cT. rewrite <- app_length. - eapply closedn_mkProd_or_LetIn; - now rewrite app_length // plus_n_Sm. + - rewrite closedn_ctx_cons. + rewrite (IHctx n (mkProd_or_LetIn a T)) /= -closedn_mkProd_or_LetIn. + now rewrite // plus_n_Sm andb_assoc. Qed. Lemma closedn_it_mkLambda_or_LetIn @@ -532,17 +505,17 @@ Proof. rewrite subst_context_snoc. simpl. eapply Alli_app_inv. eapply IHΔ'; eauto. constructor; [|constructor]. simpl. - rewrite /closed_decl /map_decl /= Nat.add_0_r List.rev_length subst_context_length. - inv X'. unfold closed_decl in H0. simpl in H0. + 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. - move/andP: H0 => [Hl Hr]. + move/andP: H0 => [Hl Hr]; rewrite !closedn_subst /= ?H //; eapply closed_upwards; eauto; try lia. - intros. eapply Alli_app in X as [X X']. rewrite subst_context_snoc. simpl. eapply Alli_app_inv. eapply IHΔ'; eauto. constructor; [|constructor]. simpl. - rewrite /closed_decl /map_decl /= Nat.add_0_r List.rev_length subst_context_length. - inv X'. unfold closed_decl in H0. simpl in H0. + 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. rewrite !closedn_subst /= ?H //; eapply closed_upwards; eauto; try lia. Qed. @@ -568,7 +541,7 @@ Proof. rewrite List.rev_length Nat.add_0_r in H. clear X1. rewrite List.rev_app_distr. eapply Alli_app_inv; repeat constructor. - now rewrite /closed_decl Nat.add_0_r /=. + now rewrite Nat.add_0_r /=. rewrite List.rev_length /=. clear -X0. apply Alli_shift, (Alli_impl _ X0). intros. eapply closed_decl_upwards; eauto; lia. @@ -581,7 +554,17 @@ Proof. intros; apply (closed_smash_context_gen n _ []); auto. constructor. Qed. -Lemma closedn_ctx_spec k Γ : closedn_ctx k Γ <~> Alli closed_decl k (List.rev Γ). +Lemma closedn_subst_instance_context {k Γ u} : + closedn_ctx k (subst_instance u Γ) = closedn_ctx k Γ. +Proof. + rewrite !test_context_k_eq. + rewrite rev_subst_instance. + rewrite alli_map. + apply alli_ext; intros i [? [] ?]; unfold closed_decl, test_decl; cbn. + all: now rewrite !closedn_subst_instance. +Qed. + +Lemma closedn_ctx_spec k Γ : closedn_ctx k Γ <~> Alli (fun k => closed_decl k) k (List.rev Γ). Proof. split. - induction Γ as [|d ?]. @@ -591,8 +574,8 @@ Proof. repeat constructor. now rewrite List.rev_length. - induction Γ in k |- * => //. simpl. move/Alli_app => [clΓ cld]. - simpl. depelim cld. rewrite List.rev_length Nat.add_comm in i. - now rewrite closedn_ctx_cons IHΓ. + simpl. depelim cld. rewrite List.rev_length in i. + now rewrite i IHΓ. Qed. Lemma closedn_smash_context (Γ : context) n : @@ -606,23 +589,17 @@ Proof. now apply (Alli_shiftn_inv 0 _ n) in H. Qed. -Lemma context_assumptions_app Γ Δ : context_assumptions (Γ ++ Δ) = - context_assumptions Γ + context_assumptions Δ. -Proof. - induction Γ as [|[? [] ?] ?]; simpl; auto. -Qed. - Lemma weaken_env_prop_closed {cf:checker_flags} : weaken_env_prop (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 declared_projection_closed_ind {cf:checker_flags} {Σ : global_env_ext} {mdecl idecl p pdecl} : - wf Σ.1 -> - declared_projection Σ.1 mdecl idecl p pdecl -> +Lemma declared_projection_closed_ind {cf:checker_flags} {Σ : global_env} {mdecl idecl p pdecl} : + wf Σ -> + declared_projection Σ p mdecl idecl pdecl -> Forall_decls_typing (fun _ (Γ : context) (t T : term) => - closedn #|Γ| t && closedn #|Γ| T) Σ.1 -> + closedn #|Γ| t && closedn #|Γ| T) Σ -> closedn (S (ind_npars mdecl)) pdecl.2. Proof. intros wfΣ isdecl X0. @@ -631,7 +608,8 @@ Proof. clearbody oib. have onpars := onParams (declared_minductive_inv weaken_env_prop_closed wfΣ X0 isdecl.p1.p1). have parslen := onNpars (declared_minductive_inv weaken_env_prop_closed wfΣ X0 isdecl.p1.p1). - simpl in onp. destruct (ind_cshapes oib) as [|? []] eqn:Heq; try contradiction. + simpl in onp. + destruct (ind_ctors idecl) as [|? []] eqn:Heq; try contradiction. destruct onp as [_ onp]. red in onp. destruct (nth_error (smash_context [] _) _) eqn:Heq'; try contradiction. @@ -679,18 +657,19 @@ Proof. rewrite context_assumptions_app in Heq'. lia. Qed. +Set SimplIsCbn. + Lemma typecheck_closed `{cf : checker_flags} : env_prop (fun Σ Γ t T => closedn #|Γ| t && closedn #|Γ| T) - (fun Σ Γ _ => closed_ctx Γ). + (fun Σ Γ => closed_ctx Γ). Proof. assert (X := weaken_env_prop_closed). - apply typing_ind_env; intros * wfΣ Γ wfΓ *; simpl; intros; rewrite -> ?andb_and in *; try solve [intuition auto]. + apply typing_ind_env; intros * wfΣ Γ wfΓ *; intros; cbn in *; + rewrite -> ?andb_and in *; try solve [intuition auto]. - - induction X0; simpl; auto; rewrite (closedn_ctx_app _ Γ [_]); simpl. - unfold closedn_ctx at 2; simpl. rewrite IHX0. unfold id; simpl. - move/andP: p => [ct cs]. now rewrite /closed_decl /= Nat.add_0_r ct. - move/andP: p => [ct cs]. now rewrite {2}/closedn_ctx /closed_decl /= Nat.add_0_r IHX0 ct. + - induction X0; auto; rewrite closedn_ctx_cons /= IHX0 /= //. + now move/andP: p => [] /= -> _. - pose proof (nth_error_Some_length H). elim (Nat.ltb_spec n #|Γ|); intuition auto. all: try lia. clear H1. @@ -701,9 +680,9 @@ Proof. rewrite -Nat.add_1_r. apply closedn_lift. rewrite closedn_ctx_cons in H0. move/andP: H0 => [_ ca]. destruct a as [na [b|] ty]. simpl in ca. - rewrite /closed_decl /= in ca. + rewrite /test_decl /= in ca. now move/andP: ca => [_ cty]. - now rewrite /closed_decl /= in ca. + now rewrite /test_decl /= in ca. simpl. rewrite -Nat.add_1_r. rewrite -(simpl_lift _ (S n) 0 1 0); try lia. @@ -713,13 +692,13 @@ Proof. - intuition auto. generalize (closedn_subst [u] #|Γ| 0 B). rewrite Nat.add_0_r. - move=> Hs. apply: Hs => /=. rewrite H1 => //. + move=> Hs. apply: Hs => /=. simpl. rewrite H1 => //. rewrite Nat.add_1_r. auto. - - rewrite closedn_subst_instance_constr. + - rewrite closedn_subst_instance. eapply lookup_on_global_env in X0; eauto. destruct X0 as [Σ' [HΣ' IH]]. - repeat red in IH. destruct decl, cst_body. simpl in *. + repeat red in IH. destruct decl, cst_body0. simpl in *. rewrite -> andb_and in IH. intuition auto. eauto using closed_upwards with arith. simpl in *. @@ -727,7 +706,7 @@ Proof. rewrite -> andb_and in Hs. intuition auto. eauto using closed_upwards with arith. - - rewrite closedn_subst_instance_constr. + - rewrite closedn_subst_instance. eapply declared_inductive_inv in X0; eauto. apply onArity in X0. repeat red in X0. destruct X0 as [s Hs]. rewrite -> andb_and in Hs. @@ -738,7 +717,7 @@ Proof. + unfold inds. clear. simpl. induction #|ind_bodies mdecl|. constructor. simpl. now rewrite IHn. + rewrite inds_length. - rewrite closedn_subst_instance_constr. + rewrite closedn_subst_instance. eapply declared_inductive_inv in X0; eauto. pose proof X0.(onConstructors) as XX. eapply All2_nth_error_Some in Hcdecl; eauto. @@ -748,19 +727,34 @@ Proof. rewrite arities_context_length in Hs. eauto using closed_upwards with arith. - - intuition auto. - + solve_all. unfold test_snd. simpl in *. - rtoProp; eauto. - + apply closedn_mkApps; auto. - rewrite forallb_app. simpl. rewrite H2. - rewrite forallb_skipn; auto. - now apply closedn_mkApps_inv in H9. + - destruct H4 as [clret _]. + destruct H7 as [clc clty]. + rewrite closedn_mkApps in clty. simpl in clty. + rewrite forallb_app in clty. move/andP: clty => [clpar clinds]. + rewrite app_context_length in clret. + red in H9. eapply Forall2_All2 in H9. + eapply All2i_All2_mix_left in X5; eauto. + intuition auto. + + unfold test_predicate_k. simpl. rtoProp; intuition eauto. + rewrite closedn_ctx_app in H3. + now move/andP: H3 => []. + + unfold test_branch_k. clear H9. solve_all. + * rewrite closedn_ctx_app in a1. + now move/andP: a1 => []. + * eapply All2_fold_app_inv_l in b as [_ conv] => //. + now len in H9. + + rewrite closedn_mkApps; auto. + rewrite closedn_it_mkLambda_or_LetIn //. + rewrite closedn_ctx_app in H3. + now move/andP: H3 => []. + now rewrite Nat.add_comm. + rewrite forallb_app. simpl. now rewrite clc clinds. - intuition auto. apply closedn_subst0. - + simpl. apply closedn_mkApps_inv in H3. + + simpl. rewrite closedn_mkApps in H3. rewrite forallb_rev H2. apply H3. - + rewrite closedn_subst_instance_constr. + + rewrite closedn_subst_instance. eapply declared_projection_closed_ind in X0; eauto. simpl; rewrite List.rev_length H1. eapply closed_upwards; eauto. lia. @@ -796,16 +790,13 @@ Proof. intros X X0. simpl in *. induction X0; constructor; auto. clear IHX0. destruct d; simpl. - - destruct c; simpl. destruct cst_body; simpl in *. - red in o |- *. simpl in *. now eapply X. - red in o |- *. simpl in *. now eapply X. + - destruct c; simpl. destruct cst_body0; simpl in *; now eapply X. - red in o. simpl in *. destruct o0 as [onI onP onNP]. constructor; auto. -- eapply Alli_impl. exact onI. eauto. intros. - refine {| ind_indices := X1.(ind_indices); - ind_arity_eq := X1.(ind_arity_eq); - ind_cshapes := X1.(ind_cshapes) |}. + refine {| ind_arity_eq := X1.(ind_arity_eq); + ind_cunivs := X1.(ind_cunivs) |}. --- apply onArity in X1. unfold on_type in *; simpl in *. now eapply X. --- pose proof X1.(onConstructors) as X11. red in X11. @@ -813,18 +804,19 @@ Proof. simpl. intros. destruct X2 as [? ? ? ?]; unshelve econstructor; eauto. * apply X; eauto. * clear -X0 X on_cargs. revert on_cargs. - generalize (cshape_args y), (cshape_sorts y). - induction c; destruct l; simpl; auto; + generalize (cstr_args x0). + induction c in y |- *; destruct y; simpl; auto; destruct a as [na [b|] ty]; simpl in *; auto; split; intuition eauto. * clear -X0 X on_cindices. revert on_cindices. - generalize (List.rev (lift_context #|cshape_args y| 0 (ind_indices X1))). - generalize (cshape_indices y). + generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))). + generalize (cstr_indices x0). induction 1; simpl; constructor; auto. --- simpl; intros. pose (onProjections X1 H0). simpl in *; auto. --- destruct X1. simpl. unfold check_ind_sorts in *. - destruct Universe.is_prop, Universe.is_sprop; auto. + destruct Universe.is_prop => //. + destruct Universe.is_sprop; auto. split. * apply ind_sorts. * destruct indices_matter; auto. @@ -835,7 +827,6 @@ Proof. intros. now apply X. Qed. - Lemma declared_decl_closed `{checker_flags} {Σ : global_env} {cst decl} : wf Σ -> lookup_env Σ cst = Some decl -> @@ -860,30 +851,31 @@ Proof. intros cl Hfg. induction l in n, cl, Hfg |- *; simpl; try congruence. intros. rewrite Hfg; simpl; try lia. - simpl in cl. rewrite /closedn_ctx /mapi mapi_rec_app /= forallb_app in cl. - move/andP: cl => [cll clr]. simpl in clr. unfold id in clr. - rewrite List.rev_length in clr. rewrite Nat.add_0_r in clr. - move/andP : clr => [clr _]. eapply closed_decl_upwards; eauto. lia. + rewrite closedn_ctx_cons in cl. + move/andP: cl => [cll clr]. eapply closed_decl_upwards; eauto. lia. f_equal. rewrite IHl; auto. - simpl in cl. rewrite /closedn_ctx /mapi mapi_rec_app /= forallb_app in cl. - move/andP: cl => [cll _]. simpl in cll. - apply cll. + rewrite closedn_ctx_cons in cl. + now move/andP: cl => []. intros. apply Hfg. simpl; lia. simpl. lia. simpl. eapply closed_decl_upwards; eauto. lia. Qed. +Definition closed_constructor_body mdecl (b : constructor_body) := + closedn_ctx (#|ind_bodies mdecl| + #|ind_params mdecl|) b.(cstr_args) && + forallb (closedn (#|ind_bodies mdecl| + #|ind_params mdecl| + #|b.(cstr_args)|)) b.(cstr_indices) && + closedn #|ind_bodies mdecl| b.(cstr_type). + Definition closed_inductive_body mdecl idecl := closedn 0 idecl.(ind_type) && - forallb (fun cdecl => - closedn (#|arities_context mdecl.(ind_bodies)|) (cdecl_type cdecl)) idecl.(ind_ctors) && + closedn_ctx #|mdecl.(ind_params)| idecl.(ind_indices) && + forallb (closed_constructor_body mdecl) idecl.(ind_ctors) && forallb (fun x => closedn (S (ind_npars mdecl)) x.2) idecl.(ind_projs). Definition closed_inductive_decl mdecl := closed_ctx (ind_params mdecl) && - forallb (closed_inductive_body mdecl) (ind_bodies mdecl). - + forallb (closed_inductive_body mdecl) (ind_bodies mdecl). Lemma closedn_All_local_env (ctx : list context_decl) : All_local_env @@ -891,28 +883,24 @@ Lemma closedn_All_local_env (ctx : list context_decl) : closedn #|Γ| b && option_default (closedn #|Γ|) t true) ctx -> closedn_ctx 0 ctx. Proof. - induction 1. constructor. - rewrite /closedn_ctx /= mapi_app forallb_app /= [forallb _ _]IHX /id /closed_decl /=. - now rewrite Nat.add_0_r List.rev_length t0. - rewrite /closedn_ctx /= mapi_app forallb_app /= [forallb _ _]IHX /id /closed_decl /=. - now rewrite Nat.add_0_r List.rev_length t1. + induction 1; auto; rewrite closedn_ctx_cons IHX /=; now move/andP: t0 => []. Qed. Lemma skipn_0 {A} (l : list A) : skipn 0 l = l. Proof. reflexivity. Qed. -Lemma declared_projection_closed {cf:checker_flags} {Σ : global_env_ext} {mdecl idecl p pdecl} : - wf Σ.1 -> - declared_projection Σ.1 mdecl idecl p pdecl -> +Lemma declared_projection_closed {cf:checker_flags} {Σ : global_env} {mdecl idecl p pdecl} : + wf Σ -> + declared_projection Σ p mdecl idecl pdecl -> closedn (S (ind_npars mdecl)) pdecl.2. Proof. intros; eapply declared_projection_closed_ind; eauto. - eapply typecheck_closed; eauto. eapply type_Prop. + eapply (env_prop_sigma _ _ typecheck_closed); eauto. Qed. -Lemma declared_inductive_closed {cf:checker_flags} {Σ : global_env_ext} {mdecl mind} : - wf Σ.1 -> - declared_minductive Σ.1 mind mdecl -> +Lemma declared_minductive_closed {cf:checker_flags} {Σ : global_env} {mdecl mind} : + wf Σ -> + declared_minductive Σ mind mdecl -> closed_inductive_decl mdecl. Proof. intros wfΣ decl. @@ -924,7 +912,7 @@ Proof. apply onInductives in decl'. eapply All_forallb. - assert (Alli (fun i => declared_inductive Σ.1 mdecl {| inductive_mind := mind; inductive_ind := i |}) + 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. } @@ -934,20 +922,37 @@ Proof. intros n x [decli oib]. rewrite /closed_inductive_body. apply andb_and; split. apply andb_and. split. - - apply onArity in oib. hnf in oib. - now move/andP: oib => []. + - rewrite andb_and. split. + * apply onArity in oib. hnf in oib. + now move/andP: oib => [] /= ->. + * pose proof (onArity oib). + rewrite oib.(ind_arity_eq) in X. + red in X. simpl in X. + rewrite !closedn_it_mkProd_or_LetIn /= !andb_true_r in X. + now move/andP: X. - pose proof (onConstructors oib). red in X. eapply All_forallb. eapply All2_All_left; eauto. - intros cdecl cs X0; eapply on_ctype in X0. - now move/andP: X0 => []. + intros cdecl cs X0; + move/andP: (on_ctype X0) => []. + simpl. unfold closed_constructor_body. + intros Hty _. + rewrite arities_context_length in Hty. + rewrite Hty. + rewrite X0.(cstr_eq) closedn_it_mkProd_or_LetIn in Hty. + move/andP: Hty => [] _. + rewrite closedn_it_mkProd_or_LetIn. + move/andP=> [] ->. rewrite closedn_mkApps /=. + move/andP=> [] _. rewrite forallb_app. + now move/andP=> [] _ ->. + - eapply All_forallb. pose proof (onProjections oib). destruct (eq_dec (ind_projs x) []) as [->|eq]; try constructor. specialize (X eq). clear eq. - destruct (ind_cshapes oib) as [|? []]; try contradiction. + destruct (ind_ctors x) as [|? []]; try contradiction. apply on_projs in X. - assert (Alli (fun i pdecl => declared_projection Σ.1 mdecl x - (({| inductive_mind := mind; inductive_ind := n |}, mdecl.(ind_npars)), i) pdecl) + assert (Alli (fun i pdecl => declared_projection Σ + (({| inductive_mind := mind; inductive_ind := n |}, mdecl.(ind_npars)), i) mdecl x pdecl) 0 (ind_projs x)). { eapply forall_nth_error_Alli. intros. split; auto. } @@ -955,21 +960,52 @@ Proof. now eapply declared_projection_closed in H. Qed. -Lemma rev_subst_instance_context {u Γ} : - List.rev (subst_instance_context u Γ) = subst_instance_context u (List.rev Γ). +Lemma declared_inductive_closed {cf:checker_flags} + {Σ : global_env} {mdecl mind idecl} : + wf Σ -> + declared_inductive Σ mind mdecl idecl -> + closed_inductive_body mdecl idecl. Proof. - unfold subst_instance_context, map_context. - now rewrite map_rev. + intros wf [decli hnth]. + apply declared_minductive_closed in decli; auto. + move/andP: decli => [clpars cli]. + solve_all. eapply nth_error_all in cli; eauto. + now simpl in cli. Qed. -Lemma closedn_subst_instance_context {k Γ u} : - closedn_ctx k (subst_instance_context u Γ) = closedn_ctx k Γ. +Lemma declared_inductive_closed_pars_indices {cf:checker_flags} + {Σ : global_env} {mdecl mind idecl} : + wf Σ -> + declared_inductive Σ mind mdecl idecl -> + closed_ctx (ind_params mdecl ,,, ind_indices idecl). Proof. - unfold closedn_ctx; f_equal. - rewrite rev_subst_instance_context. - rewrite mapi_map. apply mapi_ext. - intros n [? [] ?]; unfold closed_decl; cbn. - all: now rewrite !closedn_subst_instance_constr. + intros wf decli. + pose proof (declared_minductive_closed _ (proj1 decli)). + move/andP: H => [] clpars _. move: decli. + move/declared_inductive_closed. + move/andP => [] /andP [] clind clbodies. + move/andP: clind => [] _ indpars _. + now rewrite closedn_ctx_app clpars indpars. +Qed. + +Lemma declared_constructor_closed {cf:checker_flags} {Σ : global_env} {mdecl idecl c cdecl} : + wf Σ -> + declared_constructor Σ c mdecl idecl cdecl -> + closed_constructor_body mdecl cdecl. +Proof. + intros wf declc. + move: (declared_minductive_closed wf (proj1 (proj1 declc))). + rewrite /closed_inductive_decl. + rewrite /closed_inductive_body. + move/andP=> [_ clbs]. + destruct declc. + destruct H. + solve_all. + eapply nth_error_all in clbs; eauto. + simpl in clbs. + move/andP: clbs => [] /andP [] _ clc _. + solve_all. + eapply nth_error_all in clc; eauto. now simpl in clc. Qed. Lemma subject_closed `{checker_flags} {Σ Γ t T} : @@ -980,7 +1016,7 @@ Proof. move=> wfΣ c. pose proof (typing_wf_local c). apply typecheck_closed in c; eauto. - now move: c => [_ /andP [ct _]]. + now move: c => [_ [_ /andP [ct _]]]. Qed. Lemma type_closed `{checker_flags} {Σ Γ t T} : @@ -991,7 +1027,7 @@ Proof. move=> wfΣ c. pose proof (typing_wf_local c). apply typecheck_closed in c; eauto. - now move: c => [_ /andP [_ ct]]. + now move: c => [_ [_ /andP [_ ct]]]. Qed. Lemma isType_closed {cf:checker_flags} {Σ Γ T} : wf Σ.1 -> isType Σ Γ T -> closedn #|Γ| T. @@ -1002,23 +1038,8 @@ Lemma closed_wf_local `{checker_flags} {Σ Γ} : wf_local Σ Γ -> closed_ctx Γ. Proof. - intros wfΣ. unfold closed_ctx, mapi. intros wf. generalize 0. - induction wf; intros n; auto; unfold closed_ctx, snoc; simpl; - rewrite mapi_rec_app forallb_app; unfold id, closed_decl. - - simpl. - destruct t0 as [s Hs]. - eapply typecheck_closed in Hs as [closedΓ tcl]; eauto. - rewrite -> andb_and in *. simpl in *; rewrite andb_true_r in tcl |- *. - simpl in *. intuition auto. - + apply IHwf. - + erewrite closed_upwards; eauto. rewrite List.rev_length. lia. - - simpl. eapply typecheck_closed in t1 as [closedΓ tcl]; eauto. - rewrite -> andb_and in *. intuition auto. - + apply IHwf. - + erewrite closed_upwards; eauto. - * erewrite closed_upwards; eauto. - rewrite List.rev_length. lia. - * rewrite List.rev_length. lia. + intros wfΣ wfΓ. + apply (env_prop_wf_local _ _ typecheck_closed Σ wfΣ _ wfΓ). Qed. Lemma closedn_ctx_decl {Γ n d k} : @@ -1034,25 +1055,28 @@ Proof. Qed. Lemma ctx_inst_closed {cf:checker_flags} (Σ : global_env_ext) Γ i Δ : - wf Σ.1 -> ctx_inst (lift_typing typing) Σ Γ i Δ -> All (closedn #|Γ|) i. + wf Σ.1 -> ctx_inst typing Σ Γ i Δ -> All (closedn #|Γ|) i. Proof. intros wfΣ; induction 1; auto; constructor; auto. - now eapply subject_closed in p. + now eapply subject_closed in t0. Qed. +Arguments lift_context _ _ _ : simpl never. +Arguments subst_context _ _ _ : simpl never. + Lemma closedn_ctx_lift n k k' Γ : closedn_ctx k Γ -> closedn_ctx (n + k) (lift_context n k' Γ). Proof. - induction Γ as [|d ?]; simpl; auto; rewrite lift_context_snoc !closedn_ctx_cons /=; + induction Γ as [|d ?]; cbn; auto; rewrite lift_context_snoc !closedn_ctx_cons /=; move/andP=> [clΓ cld]; rewrite IHΓ //; autorewrite with len in cld. - move: cld; rewrite /closed_decl. simpl. + move: cld; rewrite /test_decl. simpl. move/andP=> [clb clt]; apply andb_and; split. destruct (decl_body d) => /= //. simpl in clb |- *. eapply (closedn_lift n) in clb. - autorewrite with len. now rewrite -Nat.add_assoc Nat.add_comm. + autorewrite with len. now rewrite Nat.add_comm (Nat.add_comm n) Nat.add_assoc. eapply (closedn_lift n) in clt. - autorewrite with len. now rewrite -Nat.add_assoc Nat.add_comm. + autorewrite with len. now rewrite Nat.add_comm (Nat.add_comm n) Nat.add_assoc. Qed. Lemma closedn_ctx_subst k k' s Γ : @@ -1060,10 +1084,10 @@ Lemma closedn_ctx_subst k k' s Γ : forallb (closedn k) s -> closedn_ctx (k + k') (subst_context s k' Γ). Proof. - induction Γ as [|d ?] in k' |- *; simpl; auto; rewrite subst_context_snoc !closedn_ctx_cons /=; + induction Γ as [|d ?] in k' |- *; auto; rewrite subst_context_snoc !closedn_ctx_cons /=; move/andP=> [clΓ cld] cls; rewrite IHΓ //; autorewrite with len in cld. - move: cld; rewrite /closed_decl. simpl. + move: cld; rewrite /test_decl. simpl. move/andP=> [clb clt]; apply andb_and; split. destruct (decl_body d) => /= //. simpl in clb |- *. rewrite -Nat.add_assoc [#|s| + _]Nat.add_comm Nat.add_assoc in clb. @@ -1076,6 +1100,56 @@ Proof. autorewrite with len. now rewrite (Nat.add_comm #|Γ|). Qed. +Lemma map_subst_closedn (s : list term) (k : nat) l : + forallb (closedn k) l -> map (subst s k) l = l. +Proof. + induction l; simpl; auto. + move/andP=> [cla cll]. rewrite IHl //. + now rewrite subst_closedn. +Qed. + +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 /=; + move/andP => [clΓ /andP[clb clt]]. + - rewrite IHΓ //. + epose proof (closedn_subst (extended_subst Γ k') (k' + k + context_assumptions Γ) 0). + autorewrite with len in H. rewrite andb_true_r. + eapply H; auto. + replace (k' + k + context_assumptions Γ + #|Γ|) + with (k + #|Γ| + (context_assumptions Γ + k')) by lia. + eapply closedn_lift. eapply clb. + - apply andb_and. split. + * apply Nat.ltb_lt; lia. + * specialize (IHΓ k (S k') clΓ). + red. rewrite -IHΓ. f_equal. f_equal. lia. +Qed. + +Lemma closedn_extended_subst Γ : + closed_ctx Γ -> + forallb (closedn (context_assumptions Γ)) (extended_subst Γ 0). +Proof. + intros clΓ. now apply (closedn_extended_subst_gen Γ 0 0). +Qed. + +Lemma closedn_ctx_expand_lets Γ Δ : + closed_ctx (Γ ,,, Δ) -> + closedn_ctx (context_assumptions Γ) (expand_lets_ctx Γ Δ). +Proof. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + intros cl. + pose proof (closedn_ctx_subst (context_assumptions Γ) 0). + rewrite Nat.add_0_r in H. apply: H. + - simpl. len. + rewrite closedn_ctx_lift //. + rewrite closedn_ctx_app in cl. now move/andP: cl. + - apply (closedn_extended_subst_gen Γ 0 0). + rewrite closedn_ctx_app in cl. + now move/andP: cl => []. +Qed. + Lemma declared_constant_closed_type {cf:checker_flags} : forall Σ cst decl, wf Σ -> @@ -1094,50 +1168,93 @@ Proof. now eapply subject_closed in h. Qed. +Lemma declared_constant_closed_body {cf : checker_flags} : + forall Σ cst decl body, + wf Σ -> + declared_constant Σ cst decl -> + decl.(cst_body) = Some body -> + closed body. +Proof. + intros Σ cst decl body hΣ h e. + unfold declared_constant in h. + eapply lookup_on_global_env in h. 2: eauto. + destruct h as [Σ' [wfΣ' decl']]. + red in decl'. red in decl'. + destruct decl as [ty bo un]. simpl in *. + rewrite e in decl'. + now eapply subject_closed in decl'. +Qed. + Lemma declared_inductive_closed_type {cf:checker_flags} : forall Σ mdecl ind idecl, wf Σ -> - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> closed idecl.(ind_type). Proof. intros Σ mdecl ind idecl hΣ h. - unfold declared_inductive in h. destruct h as [h1 h2]. + unfold declared_inductive in h. + destruct h as [h1 h2]. unfold declared_minductive in h1. eapply lookup_on_global_env in h1. 2: eauto. destruct h1 as [Σ' [wfΣ' decl']]. red in decl'. destruct decl' as [h ? ? ?]. eapply Alli_nth_error in h. 2: eassumption. - simpl in h. destruct h as [? ? ? [? h] ? ? ?]. - eapply typecheck_closed in h as [? e]. 2: auto. - move/andP in e. destruct e. assumption. + simpl in h. destruct h as [? [? h] ? ? ?]. + eapply typecheck_closed in h as [? e]. 2: auto. + now move: e => [_ /andP []]. +Qed. + +Lemma declared_inductive_closed_params {cf:checker_flags} {Σ mdecl ind idecl} {wfΣ : wf Σ} : + declared_inductive Σ ind mdecl idecl -> + closed_ctx mdecl.(ind_params). +Proof. + intros h. + pose proof (on_declared_inductive h) as [onmind _]. + eapply onParams in onmind. + eapply closed_wf_local; eauto. simpl. auto. +Qed. + +Lemma declared_inductive_closed_params_inst {cf:checker_flags} {Σ mdecl ind idecl} {wfΣ : wf Σ} {u} : + declared_inductive Σ ind mdecl idecl -> + closed_ctx (subst_instance u mdecl.(ind_params)). +Proof. + intros h. + rewrite closedn_subst_instance_context. + now apply (declared_inductive_closed_params h). +Qed. + +Lemma declared_minductive_ind_npars {cf:checker_flags} {Σ} {wfΣ : wf Σ} {mdecl ind} : + declared_minductive Σ ind mdecl -> + ind_npars mdecl = context_assumptions mdecl.(ind_params). +Proof. + intros h. + unfold declared_minductive in h. + eapply lookup_on_global_env in h. 2: eauto. + destruct h as [Σ' [wfΣ' decl']]. + red in decl'. destruct decl' as [h ? ? ?]. + now rewrite onNpars. Qed. -Lemma declared_inductive_closed_constructors {cf:checker_flags} : - forall Σ ind mdecl idecl, - wf Σ -> - declared_inductive Σ mdecl ind idecl -> - All (fun '(na, t, n) => closedn #|arities_context mdecl.(ind_bodies)| t) - idecl.(ind_ctors). +Lemma declared_inductive_closed_constructors {cf:checker_flags} {Σ ind mdecl idecl} {wfΣ : wf Σ} : + declared_inductive Σ ind mdecl idecl -> + All (closed_constructor_body mdecl) idecl.(ind_ctors). Proof. - intros Σ ind mdecl idecl hΣ [hmdecl hidecl]. - eapply (declared_inductive_closed (Σ:=empty_ext Σ)) in hmdecl; auto. + intros [hmdecl hidecl]. + eapply (declared_minductive_closed (Σ:=empty_ext Σ)) in hmdecl; auto. unfold closed_inductive_decl in hmdecl. move/andP: hmdecl => [clpars clbodies]. - eapply nth_error_forallb in clbodies; eauto. + eapply forallb_nth_error in clbodies; eauto. erewrite hidecl in clbodies. simpl in clbodies. unfold closed_inductive_body in clbodies. move/andP: clbodies => [/andP [_ cl] _]. - eapply forallb_All in cl. apply (All_impl cl). - now intros [[? ?] ?]; simpl. + now eapply forallb_All in cl. Qed. -Lemma declared_minductive_closed_inds {cf:checker_flags} : - forall Σ ind mdecl u, - wf Σ -> - declared_minductive Σ (inductive_mind ind) mdecl -> - forallb (closedn 0) (inds (inductive_mind ind) u (ind_bodies mdecl)). +Lemma declared_minductive_closed_inds {cf:checker_flags} {Σ ind mdecl u} {wfΣ : wf Σ} : + declared_minductive Σ (inductive_mind ind) mdecl -> + forallb (closedn 0) (inds (inductive_mind ind) u (ind_bodies mdecl)). Proof. - intros Σ ind mdecl u hΣ h. + intros h. red in h. eapply lookup_on_global_env in h. 2: eauto. destruct h as [Σ' [wfΣ' decl']]. @@ -1150,48 +1267,60 @@ Proof. - simpl. eauto. Qed. -Lemma declared_inductive_closed_inds {cf:checker_flags} : - forall Σ ind mdecl idecl u, - wf Σ -> - declared_inductive Σ mdecl ind idecl -> - forallb (closedn 0) (inds (inductive_mind ind) u (ind_bodies mdecl)). +Lemma declared_constructor_closed_type {cf:checker_flags} + {Σ mdecl idecl c cdecl u} {wfΣ : wf Σ} : + declared_constructor Σ c mdecl idecl cdecl -> + closed (type_of_constructor mdecl cdecl c u). Proof. - intros Σ ind mdecl idecl u hΣ h. - unfold declared_inductive in h. destruct h as [hmdecl hidecl]. - eapply declared_minductive_closed_inds in hmdecl. all: eauto. + intros h. + unfold declared_constructor in h. + destruct c as [i ci]. simpl in h. destruct h as [hidecl hcdecl]. + eapply declared_inductive_closed_constructors in hidecl as h. + unfold type_of_constructor. simpl. + eapply All_nth_error in h. 2: eassumption. + move/andP: h => [/andP [hargs hindices]] hty. + eapply closedn_subst0. + - eapply declared_minductive_closed_inds. all: eauto. + - simpl. rewrite inds_length. + rewrite closedn_subst_instance. assumption. Qed. -Lemma declared_constructor_closed_type {cf:checker_flags} : - forall Σ mdecl idecl c cdecl u, - wf Σ -> - declared_constructor Σ mdecl idecl c cdecl -> - closed (type_of_constructor mdecl cdecl c u). +Lemma declared_constructor_closed_args {cf:checker_flags} + {Σ mdecl idecl c cdecl} {wfΣ : wf Σ} : + declared_constructor Σ c mdecl idecl cdecl -> + closedn_ctx (#|ind_bodies mdecl| + #|ind_params mdecl|) cdecl.(cstr_args). Proof. - intros Σ mdecl idecl c cdecl u hΣ h. + intros h. unfold declared_constructor in h. destruct c as [i ci]. simpl in h. destruct h as [hidecl hcdecl]. - eapply declared_inductive_closed_constructors in hidecl as h. 2: auto. - unfold type_of_constructor. simpl. - destruct cdecl as [[id t'] arity]. simpl. - destruct idecl as [na ty ke ct pr]. simpl in *. + eapply declared_inductive_closed_constructors in hidecl as h. eapply All_nth_error in h. 2: eassumption. - simpl in h. - eapply closedn_subst0. - - eapply declared_inductive_closed_inds. all: eauto. - - simpl. rewrite inds_length. rewrite arities_context_length in h. - rewrite closedn_subst_instance_constr. assumption. + move/andP: h => [/andP [hargs hindices]] hty. + apply hargs. Qed. -Lemma declared_projection_closed_type {cf:checker_flags} : - forall Σ mdecl idecl p pdecl, - wf Σ -> - declared_projection Σ mdecl idecl p pdecl -> - closedn (S (ind_npars mdecl)) pdecl.2. +Lemma declared_constructor_closed_indices {cf:checker_flags} + {Σ mdecl idecl c cdecl} {wfΣ : wf Σ} : + declared_constructor Σ c mdecl idecl cdecl -> + forallb (closedn (#|ind_bodies mdecl| + #|ind_params mdecl| + #|cstr_args cdecl|)) cdecl.(cstr_indices). Proof. - intros Σ mdecl idecl p pdecl hΣ decl. - now eapply (declared_projection_closed (Σ:=empty_ext Σ)) in decl. + intros h. + unfold declared_constructor in h. + destruct c as [i ci]. simpl in h. destruct h as [hidecl hcdecl]. + eapply declared_inductive_closed_constructors in hidecl as h. + eapply All_nth_error in h. 2: eassumption. + now move/andP: h => [/andP [hargs hindices]] hty. Qed. +Lemma declared_projection_closed_type {cf:checker_flags} + {Σ mdecl idecl p pdecl} {wfΣ : wf Σ} : + declared_projection Σ p mdecl idecl pdecl -> + closedn (S (ind_npars mdecl)) pdecl.2. +Proof. + intros decl. + now eapply declared_projection_closed in decl. +Qed. + Lemma term_closedn_list_ind : forall (P : nat -> term -> Type), (forall k (n : nat), n < k -> P k (tRel n)) -> @@ -1206,9 +1335,10 @@ Lemma term_closedn_list_ind : (forall k s (u : list Level.t), P k (tConst s u)) -> (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 (p : inductive * nat) (t : term), - P k t -> forall t0 : term, P k t0 -> forall l : list (nat * term), - tCaseBrsProp (P k) l -> P k (tCase p t t0 l)) -> + (forall k (ci : case_info) (p : predicate term), + tCasePredProp_k P k p -> + forall t0 : term, P k t0 -> forall l : list (branch term), + tCaseBrsProp_k P k l -> P k (tCase ci p t0 l)) -> (forall k (s : projection) (t : term), P k t -> P k (tProj s t)) -> (forall k (m : mfixpoint term) (n : nat), tFixProp (P k) (P (#|fix_context m| + k)) m -> P k (tFix m n)) -> (forall k (m : mfixpoint term) (n : nat), tFixProp (P k) (P (#|fix_context m| + k)) m -> P k (tCoFix m n)) -> @@ -1225,42 +1355,84 @@ Proof. 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. - 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]. - - red. - revert brs cl2. - fix auxl' 1. - destruct brs; constructor; [|apply auxl']. - simpl in cl2. move/andP: cl2 => [clt cll]. - apply auxt, clt. move/andP: cl2 => [clt cll]. - apply cll. - - red. - rewrite fix_context_length. - revert clt. - generalize (#|mfix|). - revert mfix. - fix auxm 1. - destruct mfix; intros; constructor. - simpl in clt. move/andP: clt => [clt cll]. - simpl in clt. move/andP: clt. intuition auto. - move/andP: clt => [cd cmfix]. apply auxm; auto. - - red. - rewrite fix_context_length. - revert clt. - generalize (#|mfix|). - revert mfix. - fix auxm 1. - destruct mfix; intros; constructor. - simpl in clt. move/andP: clt => [clt cll]. - simpl in clt. move/andP: clt. intuition auto. - move/andP: clt => [cd cmfix]. apply auxm; auto. + simpl in *. + + - now apply Nat.ltb_lt in clt. + - 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]. + + - red. move/andP: cl1 => /= [clpars clret]. + split. + * revert clpars. generalize (pparams p). + fix auxl' 1. + destruct l; [constructor|]. + move=> /andP []. simpl. move=> /= /andP [] clt cll clctx. + constructor; [|apply auxl']. + apply auxt => //. rewrite cll clctx //. + * move: clpars => /andP [] clpars clctx. + split. + revert clctx. + unfold onctx_k. + generalize (pcontext p). + fix auxl' 1. + destruct l; [constructor|]. simpl. + move=> /andP []. simpl. move=> /= clctx /andP [] clt cll. + destruct c as [na [b|] ty]; simpl in *; + constructor; simpl. + split; apply auxt; rewrite Nat.sub_0_r //. + eapply Alli_shift, Alli_impl; eauto. simpl. + intros n x. now replace (Nat.pred #|l| - n + k) with (#|l| - S n + k) by lia. + 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 + k) with (#|l| - S n + k) by lia. + apply auxt => //. + - unfold tCaseBrsProp_k. + revert brs cl2. clear cl1 cl1'. + rewrite /test_branch_k. + fix auxl' 1. + destruct brs; constructor; [|apply auxl']. + simpl in cl2. move/andP: cl2 => [/andP [clctx clt] cll]. + split. + move: clctx. + generalize (bcontext b). + fix auxl'' 1. + destruct l; [constructor|]. simpl. + move=> /andP []. simpl. move=> /= clctx /andP [] clt' cll'. + destruct c as [na [bod|] ty]; simpl in *; + constructor; simpl. + split; apply auxt; rewrite Nat.sub_0_r //. + eapply Alli_shift, Alli_impl; eauto. eapply auxl'' => //. simpl. + intros n x. now replace (Nat.pred #|l| - n + k) with (#|l| - S n + k) by lia. + repeat split. rewrite Nat.sub_0_r. apply auxt => //. + eapply Alli_shift, Alli_impl; eauto. eapply auxl'' => //. simpl. + intros n x. now replace (Nat.pred #|l| - n + k) with (#|l| - S n + k) by lia. + eapply auxt => //. + simpl in cl2. now move/andP: cl2 => []. + + - red. + rewrite fix_context_length. + revert clt. + generalize (#|mfix|). + revert mfix. + fix auxm 1. + destruct mfix; intros; constructor. + simpl in clt. move/andP: clt => [clt cll]. + simpl in clt. move/andP: clt. intuition auto. + move/andP: clt => [cd cmfix]. apply auxm; auto. + + - red. + rewrite fix_context_length. + revert clt. + generalize (#|mfix|). + revert mfix. + fix auxm 1. + destruct mfix; intros; constructor. + simpl in clt. move/andP: clt => [clt cll]. + simpl in clt. move/andP: clt. intuition auto. + move/andP: clt => [cd cmfix]. apply auxm; auto. Defined. Lemma term_noccur_between_list_ind : @@ -1277,9 +1449,10 @@ Lemma term_noccur_between_list_ind : (forall k n s (u : list Level.t), P k n (tConst s u)) -> (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 (p : inductive * nat) (t : term), - P k n t -> forall t0 : term, P k n t0 -> forall l : list (nat * term), - tCaseBrsProp (P k n) l -> P k n (tCase p t t0 l)) -> + (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 -> + forall l : list (branch term), + tCaseBrsProp_k (fun k' => P k' n) 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)) -> (forall k n (m : mfixpoint term) (i : nat), tFixProp (P k n) (P (#|fix_context m| + k) n) m -> P k n (tFix m i)) -> (forall k n (m : mfixpoint term) (i : nat), tFixProp (P k n) (P (#|fix_context m| + k) n) m -> P k n (tCoFix m i)) -> @@ -1307,14 +1480,47 @@ Proof. destruct l; constructor; [|apply auxl']. apply auxt. simpl in clt. now move/andP: clt => [clt cll]. now move/andP: clt => [clt cll]. - - - red. - revert brs cl2. + + - move/andP: cl1 => /= [clpars clret]. + split. + * revert clpars. generalize (pparams p). + fix auxl' 1. + destruct l; constructor; [|apply auxl']. + apply auxt. + now move/andP: clpars => [/andP [clt _] cll]. + simpl in clpars; now move/andP: clpars => [/andP [_ ->] cll]. + * split; [|now apply auxt]. + move/andP: clpars => [] _. + clear -auxt. + unfold ondecl. + generalize (pcontext p). + rewrite /onctx_k. + fix auxl' 1; destruct l; [constructor|]; simpl; rewrite ?Nat.sub_0_r. + move/andP => [] tl /andP [tdef tty]. constructor. + + rewrite Nat.sub_0_r. simpl. split; [apply auxt|]; tas. + destruct (decl_body c); simpl in *; auto. exact tt. + + eapply Alli_shift, Alli_impl; eauto. simpl. + intros n' x. + now replace (Nat.pred #|l| - n' + k) with (#|l| - S n' + k). + + - revert brs cl2. clear cl1 cl1'. + unfold test_branch_k, tCaseBrsProp_k. fix auxl' 1. destruct brs; constructor; [|apply auxl']. - simpl in cl2. move/andP: cl2 => [clt cll]. - apply auxt, clt. move/andP: cl2 => [clt cll]. - apply cll. + simpl in cl2. move/andP: cl2 => [/andP [clctx clb] cll]. + split. + * unfold onctx_k, ondecl. + revert clctx. + generalize (bcontext b). + fix auxl'' 1; destruct l; [constructor|]; simpl; rewrite ?Nat.sub_0_r. + move/andP => [] tl /andP [tdef tty]. constructor. + + rewrite Nat.sub_0_r. simpl. split; [apply auxt|]; tas. + destruct (decl_body c); simpl in *; auto. exact tt. + + eapply Alli_shift, Alli_impl; eauto. simpl. + intros n' x. + now replace (Nat.pred #|l| - n' + k) with (#|l| - S n' + k). + * eapply auxt => //. + * now simpl in cl2; move/andP: cl2 => []. - red. rewrite fix_context_length. diff --git a/pcuic/theories/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index 01a2e7fee..6c9cf1901 100644 --- a/pcuic/theories/PCUICConfluence.v +++ b/pcuic/theories/PCUICConfluence.v @@ -1,8 +1,10 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst PCUICTyping +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICTyping PCUICReduction PCUICWeakening PCUICEquality PCUICUnivSubstitution - PCUICParallelReduction PCUICParallelReductionConfluence. + PCUICContextRelation PCUICSigmaCalculus PCUICContextReduction + PCUICParallelReduction PCUICParallelReductionConfluence + PCUICRedTypeIrrelevance. Require Import ssreflect. From Equations Require Import Equations. @@ -10,7 +12,187 @@ Require Import CRelationClasses CMorphisms. Require Import Equations.Prop.DepElim. Require Import Equations.Type.Relation Equations.Type.Relation_Properties. -Ltac tc := try typeclasses eauto 10. +Instance red_Refl Σ Γ : Reflexive (red Σ Γ) := refl_red Σ Γ. +Instance red_Trans Σ Γ : Transitive (red Σ Γ) := red_trans Σ Γ. + +Instance All_decls_refl P : + Reflexive P -> + Reflexive (All_decls P). +Proof. intros hP d; destruct d as [na [b|] ty]; constructor; auto. Qed. + +Instance All_decls_sym P : + Symmetric P -> + Symmetric (All_decls P). +Proof. intros hP d d' []; constructor; now symmetry. Qed. + +Instance All_decls_trans P : + Transitive P -> + Transitive (All_decls P). +Proof. intros hP d d' d'' [] h; depelim h; constructor; now etransitivity. Qed. + +Instance All_decls_equivalence P : + Equivalence P -> + Equivalence (All_decls P). +Proof. + intros []; split; tc. +Qed. + +Instance All_decls_preorder P : + PreOrder P -> + PreOrder (All_decls P). +Proof. + intros []; split; tc. +Qed. + +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. + +Instance All_decls_alpha_sym P : + Symmetric P -> + Symmetric (All_decls_alpha P). +Proof. intros hP d d' []; constructor; now symmetry. Qed. + +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. + +Instance All_decls_alpha_equivalence P : + Equivalence P -> + Equivalence (All_decls_alpha P). +Proof. + intros []; split; tc. +Qed. + +Lemma All2_fold_refl P : + (forall Γ, Reflexive (P Γ Γ)) -> + Reflexive (All2_fold P). +Proof. + intros HR x. + apply All2_fold_refl; intros. apply HR. +Qed. + +Lemma OnOne2_prod {A} (P Q : A -> A -> Type) l l' : + OnOne2 (fun x y => P x y × Q x y) l l' -> + OnOne2 P l l' × OnOne2 Q l l'. +Proof. + induction 1; split; constructor; intuition eauto. +Qed. + +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' : + 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_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. + induction 1. + - exists p.π1. constructor; auto. exact p.π2. + - exists IHX.π1. constructor; auto. exact IHX.π2. +Qed. + +Lemma OnOne2_local_env_apply {B} {P : B -> context -> term -> term -> Type} {l l'} + (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. + intros; eapply OnOne2_local_env_impl; tea. + intros Δ x y. eapply on_one_decl_impl; intros Γ ? ?; eauto. +Qed. + +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' -> + OnOne2_local_env (on_one_decl (fun Γ x y => P Γ x y)) l l'. +Proof. + intros; eapply OnOne2_local_env_impl; tea. + intros Δ x y. eapply on_one_decl_impl; intros Γ ? ?; eauto. +Qed. + +Lemma OnOne2_exist' {A} (P Q R : A -> A -> Type) (l l' : list A) : + OnOne2 P l l' -> + (forall x y : A, P x y -> ∑ z : A, Q x z × R y z) -> + ∑ r : list A, OnOne2 Q l r × OnOne2 R l' r. +Proof. + intros o Hp. induction o. + - specialize (Hp _ _ p) as [? []]. + eexists; split; constructor; eauto. + - exists (hd :: IHo.π1). split; constructor; auto; apply IHo.π2. +Qed. + +Lemma OnOne2_local_env_exist' (P Q R : context -> term -> term -> Type) (l l' : context) : + OnOne2_local_env (on_one_decl P) l l' -> + (forall Γ x y, P Γ x y -> ∑ z : term, Q Γ x z × R Γ y z) -> + ∑ r : context, OnOne2_local_env (on_one_decl Q) l r × OnOne2_local_env (on_one_decl R) l' r. +Proof. + intros o Hp. induction o. + - destruct p; subst. specialize (Hp _ _ _ p) as [? []]. + eexists; split; constructor; red; cbn; eauto. + - destruct p; subst. + destruct s as [[p ->]|[p ->]]; specialize (Hp _ _ _ p) as [? []]; + 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) + (Q : context -> context -> context_decl -> context_decl -> Type) + (l l' : context) : + OnOne2_local_env (on_one_decl P) l l' -> + (forall Γ x y, on_one_decl P Γ x y -> Q Γ Γ x y) -> + (forall Γ Γ' d, OnOne2_local_env (on_one_decl P) Γ Γ' -> Q Γ Γ' d d) -> + (forall Γ x, Q Γ Γ x x) -> + All2_fold Q l l'. +Proof. + intros onc HP IHQ HQ. induction onc; simpl; try constructor; eauto. + now eapply All2_fold_refl. + now eapply All2_fold_refl. +Qed. + +Lemma on_one_decl_compare_decl Σ Re Rle Γ x y : + RelationClasses.Reflexive Re -> + RelationClasses.Reflexive Rle -> + on_one_decl + (fun (_ : context) (y0 v' : term) => eq_term_upto_univ Σ Re Rle y0 v') Γ x y -> + compare_decls (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) x y. +Proof. + intros heq hle. + destruct x as [na [b|] ty], y as [na' [b'|] ty']; cbn; intuition (subst; auto); + constructor; auto; reflexivity. +Qed. + +Lemma OnOne2_disj {A} (P Q : A -> A -> Type) (l l' : list A) : + OnOne2 (fun x y => P x y + Q x y)%type l l' <~> + OnOne2 P l l' + OnOne2 Q l l'. +Proof. + split. + - induction 1; [destruct p|destruct IHX]; try solve [(left + right); constructor; auto]. + - intros []; eapply OnOne2_impl; tea; eauto. +Qed. + +Notation red1_ctx_rel Σ Δ := + (OnOne2_local_env + (on_one_decl + (fun (Γ : context) (x0 y0 : term) => red1 Σ (Δ,,, Γ) x0 y0))). + +Notation eq_one_decl Σ Re Rle := + (OnOne2_local_env + (on_one_decl + (fun _ (x0 y0 : term) => + eq_term_upto_univ Σ Re Rle x0 y0))). Lemma red1_eq_context_upto_l Σ Rle Re Γ Δ u v : RelationClasses.Reflexive Rle -> @@ -42,12 +224,13 @@ Proof. all: try solve [ match goal with | r : red1 _ (?Γ ,, ?d) _ _ |- _ => - assert (e' : eq_context_upto Σ Re Rle (Γ,, d) (Δ,, d)) ; [ - constructor ; eauto ; + assert (e' : eq_context_upto Σ Re Rle (Γ,, d) (Δ,, d)) + ; [ + constructor ; [ eauto | constructor; eauto ] ; eapply eq_term_upto_univ_refl ; eauto | ] - end ; + end; destruct (IHh _ e') as [? [? ?]] ; eexists ; split ; [ solve [ econstructor ; eauto ] @@ -61,69 +244,91 @@ Proof. { induction i in Γ, Δ, H, e |- *. - destruct e. + cbn in *. discriminate. - + simpl in *. discriminate. - + simpl in *. inversion H. subst. clear H. - eexists. split ; try constructor; eauto. + + simpl in *. depelim c; noconf H. + simpl. eexists; split; eauto. - destruct e. + cbn in *. discriminate. + simpl in *. eapply IHi in H ; eauto. - + simpl in *. eapply IHi in H ; eauto. } destruct h as [b' [e1 e2]]. eexists. split. + constructor. eassumption. + eapply eq_term_upto_univ_lift ; eauto. - - destruct ind. - destruct (IHh _ e) as [? [? ?]]. + - eapply OnOne2_prod in X as [_ X]. + eapply OnOne2_apply, OnOne2_apply in X; tea. + eapply OnOne2_exist' in X as [pars' [parred pareq]]; intros; tea. + eexists. split. eapply case_red_param; tea. + econstructor; eauto. + red. intuition; eauto. reflexivity. + apply All2_same; intros. intuition eauto; reflexivity. + - eapply (OnOne2_local_env_apply (fun Γ' u v => (Δ ,,, Γ'))) in X. + cbn in X. + eapply (OnOne2_local_env_apply_dep) in X; cycle 1. + intros. eapply eq_context_upto_cat; eauto. reflexivity. + eapply (OnOne2_local_env_exist' _ (fun Γ x y => red1 Σ (Δ ,,, Γ) x y)) in X; intros; tea. + 2:{ exact X0. } + destruct X as [ocontext'' [red eq]]. eexists; split. + * eapply case_red_pcontext; tea. + * econstructor; eauto; try reflexivity. + red; intuition; simpl; eauto. + eapply OnOne2_local_env_All2_fold; tea => /= //; try reflexivity. + + intros *. now eapply on_one_decl_compare_decl. + + eapply All2_same; split; reflexivity. + - specialize (IHh (Δ ,,, pcontext p)). + forward IHh. now apply eq_context_upto_cat. + destruct IHh as [? [? ?]]. eexists. split. + solve [ econstructor ; eauto ]. - + econstructor ; eauto. - * eapply eq_term_upto_univ_refl ; eauto. - * eapply All2_same. - intros. split ; eauto. - eapply eq_term_upto_univ_refl ; eauto. - - destruct (IHh _ e) as [? [? ?]]. + + econstructor; try red; intuition (simpl; eauto); try reflexivity. + * now eapply All2_same. + * eapply All2_same. split; reflexivity. + - specialize (IHh _ e) as [? [? ?]]. eexists. split. + solve [ econstructor ; eauto ]. - + destruct ind. - econstructor ; eauto. - * eapply eq_term_upto_univ_refl ; eauto. - * eapply All2_same. - intros. split ; eauto. - eapply eq_term_upto_univ_refl ; eauto. - - destruct ind. - assert (h : ∑ brs0, - OnOne2 (on_Trel_eq (red1 Σ Δ) snd fst) brs brs0 * - All2 (fun x y => - (fst x = fst y) * - eq_term_upto_univ Σ Re Re (snd x) (snd y))%type - brs' brs0 - ). - { induction X. - - destruct p0 as [[p1 p2] p3]. - eapply p2 in e as hh. - destruct hh as [? [? ?]]. - eexists. split. - + constructor. - instantiate (1 := (_,_)). - split ; eauto. - + constructor. - * split ; eauto. - * eapply All2_same. - intros. split ; eauto. - eapply eq_term_upto_univ_refl ; eauto. - - destruct IHX as [brs0 [? ?]]. - eexists. split. - + eapply OnOne2_tl. eassumption. - + constructor. - * split ; eauto. - eapply eq_term_upto_univ_refl ; eauto. - * eassumption. - } - destruct h as [? [? ?]]. - eexists. split. - + eapply case_red_brs. eassumption. - + econstructor. all: try eapply eq_term_upto_univ_refl ; eauto. + + econstructor; try red; intuition (simpl; eauto); try reflexivity. + * now eapply All2_same. + * eapply All2_same. split; reflexivity. + - eapply OnOne2_disj in X. + destruct X as [X|X]. + * eapply (OnOne2_impl (Q:=fun x y => (∑ v', _) × bcontext x = bcontext y)) in X; tea. + 2:{ intros x y [[red IH] eq]. split; tas. + specialize (IH (Δ ,,, bcontext x)). + forward IH by now apply eq_context_upto_cat. exact IH. } + eapply (OnOne2_exist' _ (fun x y => on_Trel_eq (red1 Σ (Δ ,,, bcontext x)) bbody bcontext x y) + (fun x y => on_Trel_eq (eq_term_upto_univ Σ Re Re) bbody bcontext x y)) in X as [brr [Hred Heq]]; tea. + 2:{ intros x y [[v' [redv' eq]] eqctx]. + exists {| bcontext := bcontext x; bbody := v' |}. + intuition auto. } + eexists; split. + eapply case_red_brs. + + eapply OnOne2_disj. left; tea. + + econstructor; eauto; try reflexivity. + eapply OnOne2_All2; tea => /=; intuition eauto; try reflexivity. + now rewrite b. + * eapply (OnOne2_impl (Q:=fun x y => (∑ v', _) × bbody x = bbody y)) in X; tea. + 2:{ intros x y [red eq]. split => //. + eapply (OnOne2_local_env_apply (fun Γ' u v => (Δ ,,, Γ'))) in red. + cbn in red. + eapply (OnOne2_local_env_apply_dep) in red; cycle 1. + intros. eapply eq_context_upto_cat; eauto. now reflexivity. + eapply (OnOne2_local_env_exist' _ (fun Γ x y => red1 Σ (Δ ,,, Γ) x y)) in red; intros. + 2:{ exact X0. } + exact red. } + eapply (OnOne2_exist' _ + (fun x y => on_Trel_eq (red1_ctx_rel Σ Δ) bcontext bbody x y) + (fun x y => on_Trel_eq (eq_one_decl Σ Re Re) bcontext bbody x y)) in X as [brr [Hred Heq]]; tea. + 2:{ intros x y [[v' [redv' eqctx]] ->]. + exists {| bcontext := v'; bbody := bbody y |}. + intuition (simpl; auto). } + eexists; split. + eapply case_red_brs. + + eapply OnOne2_disj. right; tea. + + econstructor; eauto; try reflexivity. + eapply OnOne2_All2; tea => /=; intuition eauto; try reflexivity. + 2:{ now rewrite b. } + eapply OnOne2_local_env_All2_fold; tea => /= //; try reflexivity. + intros *. now eapply on_one_decl_compare_decl. + - destruct (IHh _ e) as [x [redl redr]]. exists (tApp x M2). split. constructor; auto. @@ -242,9 +447,7 @@ Proof. assert ( e' : eq_context_upto Σ Re Rle (Γ ,,, fix_context L) (Δ ,,, fix_context L) ). - { eapply eq_context_upto_cat ; eauto. - eapply eq_context_upto_refl; assumption. - } + { eapply eq_context_upto_cat ; eauto. reflexivity. } eapply p2 in e' as hh. destruct hh as [? [? ?]]. eexists. constructor. + constructor. @@ -354,9 +557,7 @@ Proof. assert ( e' : eq_context_upto Σ Re Rle (Γ ,,, fix_context L) (Δ ,,, fix_context L) ). - { eapply eq_context_upto_cat ; eauto. - eapply eq_context_upto_refl;assumption. - } + { eapply eq_context_upto_cat ; eauto. reflexivity. } eapply p2 in e' as hh. destruct hh as [? [? ?]]. eexists. constructor. + constructor. @@ -381,6 +582,122 @@ Proof. + constructor; assumption. Qed. +Lemma eq_context_gen_context_assumptions {eq leq Γ Δ} : + eq_context_gen eq leq Γ Δ -> + context_assumptions Γ = context_assumptions Δ. +Proof. + induction 1; simpl; auto; + destruct p => /= //; try lia. +Qed. + +Lemma eq_context_extended_subst {Σ Re Rle Γ Δ k} : + eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Rle) Γ Δ -> + All2 (eq_term_upto_univ Σ Re Re) (extended_subst Γ k) (extended_subst Δ k). +Proof. + intros Heq. + induction Heq in k |- *; simpl. + - constructor; auto. + - depelim p => /=. + * constructor. eauto. constructor; eauto. eauto. + * constructor. + + rewrite (eq_context_gen_context_assumptions Heq). + len. rewrite (All2_fold_length Heq). + eapply eq_term_upto_univ_substs; eauto. tc. + eapply eq_term_upto_univ_lift, e0. + + eapply IHHeq. +Qed. + +Lemma eq_context_gen_eq_context_upto Σ Re Rle Γ Γ' : + eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Rle) Γ Γ' -> + eq_context_upto Σ Re Rle Γ Γ'. +Proof. + intros. + eapply All2_fold_impl_len; tea. + intros. depelim X0; constructor; auto. +Qed. + +Lemma red1_eq_context_upto_univ_l Σ Re Rle Γ ctx ctx' ctx'' : + RelationClasses.Reflexive Re -> + RelationClasses.Reflexive Rle -> + RelationClasses.Transitive Re -> + RelationClasses.Transitive Rle -> + SubstUnivPreserving Re -> + SubstUnivPreserving Rle -> + RelationClasses.subrelation Re Rle -> + eq_context_gen (eq_term_upto_univ Σ Re Re) + (eq_term_upto_univ Σ Re Re) ctx ctx' -> + OnOne2_local_env (on_one_decl + (fun (Γ' : context) (u v : term) => + forall (Rle : Relation_Definitions.relation Universe.t) + (napp : nat) (u' : term), + RelationClasses.Reflexive Re -> + RelationClasses.Reflexive Rle -> + RelationClasses.Transitive Re -> + RelationClasses.Transitive Rle -> + SubstUnivPreserving Re -> + SubstUnivPreserving Rle -> + (forall x y : Universe.t, Re x y -> Rle x y) -> + eq_term_upto_univ_napp Σ Re Rle napp u u' -> + ∑ v' : term, + red1 Σ (Γ,,, Γ') u' v' + × eq_term_upto_univ_napp Σ Re Rle napp v v')) ctx ctx'' -> + ∑ pctx, + red1_ctx_rel Σ Γ ctx' pctx * + eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Re) ctx'' pctx. +Proof. + intros. + rename X into e, X0 into X. + induction X in e, ctx' |- *. + - red in p. simpl in p. + depelim e. depelim c. + destruct p as [-> p]. + eapply p in e1 as hh ; eauto. + destruct hh as [? [? ?]]. + eapply red1_eq_context_upto_l in r; cycle -1. + { eapply eq_context_upto_cat. + 2:{ eapply eq_context_gen_eq_context_upto; tea. } + reflexivity. } + all:try tc. + destruct r as [v' [redv' eqv']]. + eexists; split. + + constructor; tea. red. cbn. split; tea. reflexivity. + + constructor. all: eauto. constructor; auto. + now transitivity x. + - depelim e. + depelim c. + destruct p as [-> [[p ->]|[p ->]]]. + { eapply p in e2 as hh ; eauto. + destruct hh as [? [? ?]]. + eapply red1_eq_context_upto_l in r; cycle -1. + { eapply eq_context_upto_cat. + 2:{ eapply eq_context_gen_eq_context_upto; tea. } + reflexivity. } + all:try tc. + destruct r as [v' [redv' eqv']]. + eexists; split. + + constructor; tea. red. cbn. split; tea. reflexivity. + left. split; tea. reflexivity. + + constructor. all: eauto. constructor; auto. + now transitivity x. } + { eapply p in e1 as hh ; eauto. + destruct hh as [? [? ?]]. + eapply red1_eq_context_upto_l in r; cycle -1. + { eapply eq_context_upto_cat. + 2:{ eapply eq_context_gen_eq_context_upto; tea. } + reflexivity. } + all:try tc. + destruct r as [v' [redv' eqv']]. + eexists; split. + + constructor; tea. red. cbn. split; tea. reflexivity. + right. split; tea. reflexivity. + + constructor. all: eauto. constructor; auto. + now transitivity x. } + - depelim e. + destruct (IHX _ e) as [? [? ?]]. + eexists. split. + + now eapply onone2_localenv_cons_tl. + + constructor. all: eauto. +Qed. Lemma red1_eq_term_upto_univ_l Σ Re Rle napp Γ u v u' : RelationClasses.Reflexive Re -> @@ -407,7 +724,7 @@ Proof. ] ]. (* tLambda and tProd *) - 10,13:solve [ + 10,16:solve [ dependent destruction e ; edestruct IHh as [? [? ?]] ; [ .. | eassumption | ] ; eauto ; clear h; @@ -416,11 +733,11 @@ Proof. e : eq_term_upto_univ_napp _ _ _ _ ?A ?B |- _ => let hh := fresh "hh" in - eapply red1_eq_context_upto_l in r as hh ; revgoals ; [ - eapply eq_context_vass (* with (nb := na) *) ; [ - eassumption - | eassumption - | eapply eq_context_upto_refl ; eauto + eapply red1_eq_context_upto_l in r as hh ; revgoals; + [ + constructor (* with (nb := na) *) ; [ + eapply (eq_context_upto_refl _ Re Re); eauto + | constructor; tea ] | reflexivity | assumption @@ -452,17 +769,24 @@ Proof. + constructor. eassumption. + eapply eq_term_upto_univ_refl ; assumption. - dependent destruction e. - apply eq_term_upto_univ_mkApps_l_inv in e2 as [? [? [[h1 h2] h3]]]. subst. + apply eq_term_upto_univ_mkApps_l_inv in e0 as [? [? [[h1 h2] h3]]]. subst. dependent destruction h1. + eapply All2_nth_error_Some in a as [t' [hnth [eqctx eqbod]]]; tea. + have lenctxass := eq_context_gen_context_assumptions eqctx. + have lenctx := All2_fold_length eqctx. eexists. split. - + constructor. - + unfold iota_red. eapply eq_term_upto_univ_napp_mkApps. - * simpl. eapply (eq_term_upto_univ_leq _ _ _ 0). auto. auto with arith. - eapply All2_nth - with (P := fun x y => eq_term_upto_univ Σ Re Re (snd x) (snd y)). - -- solve_all. - -- cbn. eapply eq_term_upto_univ_refl ; eauto. - * eapply All2_skipn. assumption. + + constructor; tea. + epose proof (All2_length h2). rewrite !List.skipn_length in H0 |- *. + congruence. + + unfold iota_red. + eapply eq_term_upto_univ_substs => //. + { rewrite /expand_lets /expand_lets_k. + eapply eq_term_upto_univ_substs => //. + { simpl. rewrite lenctxass lenctx. + eapply eq_term_upto_univ_lift => //. + eapply eq_term_upto_univ_leq; tea. lia. } + eapply eq_context_extended_subst; tea. } + now eapply All2_rev, All2_skipn. - apply eq_term_upto_univ_napp_mkApps_l_inv in e as [? [? [[h1 h2] h3]]]. subst. dependent destruction h1. unfold unfold_fix in H. @@ -495,13 +819,11 @@ Proof. constructor. assumption. * assumption. - dependent destruction e. - apply eq_term_upto_univ_mkApps_l_inv in e2 as [? [? [[h1 h2] h3]]]. subst. + apply eq_term_upto_univ_mkApps_l_inv in e0 as [? [? [[h1 h2] h3]]]. subst. dependent destruction h1. unfold unfold_cofix in H. - case_eq (nth_error mfix idx) ; - try (intros e ; rewrite e in H ; discriminate H). - intros d e. rewrite e in H. inversion H. subst. clear H. - eapply All2_nth_error_Some in e as hh ; try eassumption. + destruct (nth_error mfix idx) eqn:hnth; noconf H. + eapply All2_nth_error_Some in a0 as hh ; tea. destruct hh as [d' [e' [[[? ?] erarg] eann]]]. eexists. split. + eapply red_cofix_case. @@ -546,7 +868,7 @@ Proof. eexists. split. + econstructor. all: eauto. + eapply (eq_term_upto_univ_leq _ _ _ 0); tas. auto. auto with arith. - now apply eq_term_upto_univ_subst_instance_constr. + now apply eq_term_upto_univ_subst_instance. - dependent destruction e. apply eq_term_upto_univ_mkApps_l_inv in e as [? [? [[h1 h2] h3]]]. subst. dependent destruction h1. @@ -566,11 +888,9 @@ Proof. |- _ => let hh := fresh "hh" in eapply red1_eq_context_upto_l in r as hh ; revgoals ; [ - eapply eq_context_vdef (* with (nb := na) *) ; [ - eassumption - | eapply e2 - | eapply e1 - | eapply eq_context_upto_refl ; eauto + constructor (* with (nb := na) *) ; [ + eapply (eq_context_upto_refl _ Re Re) ; eauto + | econstructor; tea ] | reflexivity | assumption @@ -586,33 +906,126 @@ Proof. eapply eq_term_upto_univ_trans ; eauto. eapply eq_term_upto_univ_leq ; eauto. - dependent destruction e. - assert (h : ∑ brs0, - OnOne2 (on_Trel_eq (red1 Σ Γ) snd fst) brs'0 brs0 * - All2 (fun x y => - (fst x = fst y) * - (eq_term_upto_univ Σ Re Re (snd x) (snd y)) - )%type brs' brs0 + destruct e as [? [? [? ?]]]. + eapply OnOne2_prod_inv in X as [_ X]. + assert (h : ∑ args, + OnOne2 (red1 Σ Γ) (pparams p') args * + All2 (eq_term_upto_univ Σ Re Re) params' args ). - { induction X in a, brs'0 |- *. - - destruct p0 as [[p1 p2] p3]. - dependent destruction a. destruct p0 as [h1 h2]. - eapply p2 in h2 as hh ; eauto. + { destruct p, p' as []; cbn in *. + induction X in a0, pparams, pparams0, X |- *. + - depelim a0. + eapply p in e as hh ; eauto. destruct hh as [? [? ?]]. eexists. split. - + constructor. - instantiate (1 := (_, _)). cbn. split ; eauto. + + constructor; tea. + constructor. all: eauto. - split ; eauto. cbn. transitivity (fst hd) ; eauto. - - dependent destruction a. - destruct (IHX _ a) as [? [? ?]]. + - depelim a0. + destruct (IHX _ a0) as [? [? ?]]. eexists. split. + eapply OnOne2_tl. eassumption. + constructor. all: eauto. } - destruct h as [brs0 [? ?]]. + destruct h as [pars0 [? ?]]. eexists. split. - + eapply case_red_brs. eassumption. + + eapply case_red_param. eassumption. + constructor. all: eauto. + red; intuition eauto. + - dependent destruction e. + destruct e as [? [? [? ?]]]. + destruct p, p'; cbn in *. + eapply red1_eq_context_upto_univ_l in X; tea; try tc. + destruct X as [pctx0 [? ?]]. + eexists. split. + + eapply case_red_pcontext. eassumption. + + constructor. all: eauto. + red; intuition eauto. + - depelim e. + destruct e as [? [? [? ?]]]. + eapply IHh in e => //. + destruct e as [v' [red eq]]. + eapply red1_eq_context_upto_l in red. + 7:{ eapply eq_context_upto_cat. 2:{ eapply eq_context_gen_eq_context_upto; tea. } + reflexivity. } + all:try tc. + destruct red as [ret' [redret eqret]]. + eexists; split. + + eapply case_red_return; tea. + + econstructor; eauto. + red; simpl; intuition eauto. + now transitivity v'. + + - depelim e. + eapply OnOne2_disj in X as [X|X]. + + eapply OnOne2_prod_assoc in X as [_ X]. + assert (h : ∑ brs0, + OnOne2 (fun br br' => on_Trel_eq (red1 Σ (Γ ,,, bcontext br)) bbody bcontext br br') brs' brs0 * + All2 (fun x y => + eq_context_gen (eq_term_upto_univ Σ Re Re) + (eq_term_upto_univ Σ Re Re) (bcontext x) (bcontext y) * + (eq_term_upto_univ Σ Re Re (bbody x) (bbody y)) + )%type brs'0 brs0 + ). + { induction X in a, brs' |- *. + - destruct p0 as [p2 p3]. + dependent destruction a. destruct p0 as [h1 h2]. + eapply p2 in h2 as hh ; eauto. + destruct hh as [? [? ?]]. + eapply red1_eq_context_upto_l in r; cycle -1. + { eapply eq_context_upto_cat. + 2:{ eapply eq_context_gen_eq_context_upto, h1. } + reflexivity. } + all:try tc. + destruct r as [v' [redv' eqv']]. + eexists. split. + + constructor. + instantiate (1 := {| bcontext := bcontext y; bbody := v' |}). cbn. split ; eauto. + + constructor. all: eauto. + split ; eauto. cbn. transitivity (bcontext hd) ; eauto. + now rewrite p3. simpl. now transitivity x. + - dependent destruction a. + destruct (IHX _ a) as [? [? ?]]. + eexists. split. + + eapply OnOne2_tl. eassumption. + + constructor. all: eauto. + } + destruct h as [brs0 [? ?]]. + eexists. split. + * eapply case_red_brs. eapply OnOne2_disj. left; tea. + * constructor. all: eauto. + + + assert (h : ∑ brs0, + OnOne2 (fun br br' => on_Trel_eq (red1_ctx_rel Σ Γ) bcontext bbody br br') brs' brs0 * + All2 (fun x y => + eq_context_gen (eq_term_upto_univ Σ Re Re) + (eq_term_upto_univ Σ Re Re) (bcontext x) (bcontext y) * + eq_term_upto_univ Σ Re Re (bbody x) (bbody y) + )%type brs'0 brs0 + ). + { induction X in a, brs' |- *. + - destruct p0 as [p2 p3]. + dependent destruction a. destruct p0 as [h1 h2]. + eapply red1_eq_context_upto_univ_l in p2; tea; try tc. + destruct p2 as [pctx [pred peq]]. + eexists. split. + + constructor. split. + instantiate (1 := {| bcontext := pctx; bbody := bbody y |}); tea. + reflexivity. + + constructor. split; eauto. simpl. + transitivity (bbody hd); eauto. + now rewrite -p3. + auto. + - dependent destruction a. + destruct (IHX _ a) as [? [? ?]]. + eexists. split. + + eapply OnOne2_tl. eassumption. + + constructor. all: eauto. + } + destruct h as [brs0 [? ?]]. + eexists. split. + * eapply case_red_brs. eapply OnOne2_disj. right; tea. + * constructor. all: eauto. + - dependent destruction e. assert (h : ∑ args, OnOne2 (red1 Σ Γ) args' args * @@ -976,7 +1389,7 @@ Lemma eq_context_upto_flip {Σ Re Rle Γ Δ} eq_context_upto Σ Re Rle Γ Δ -> eq_context_upto Σ Re (flip Rle) Δ Γ. Proof. - induction 1; constructor; auto. + induction 1; constructor; auto; depelim p; constructor; auto. - now symmetry. - now eapply eq_term_upto_univ_napp_flip; try typeclasses eauto. - now symmetry. @@ -1084,36 +1497,33 @@ Polymorphic Derive Signature for Relation.clos_refl_trans. Derive Signature for red1. Lemma local_env_telescope P Γ Γ' Δ Δ' : - All2_telescope (on_decl P) Γ Γ' Δ Δ' -> - All2_local_env_over P Γ Γ' (List.rev Δ) (List.rev Δ'). + All2_telescope (on_decls P) Γ Γ' Δ Δ' -> + All2_fold_over P Γ Γ' (List.rev Δ) (List.rev Δ'). Proof. induction 1. simpl. constructor. - - simpl. eapply All2_local_env_over_app. constructor. constructor. reflexivity. - simpl. apply p. + - depelim p. simpl. eapply All2_fold_over_app. repeat constructor => //. + simpl. revert IHX. generalize (List.rev Δ) (List.rev Δ'). induction 1. constructor. - constructor; auto. red in p0. red. red. red. red in p0. - rewrite !app_context_assoc. cbn. apply p0. - constructor; auto. destruct p0. unfold on_decl_over in *. simpl. - rewrite !app_context_assoc. cbn. intuition. - - simpl. eapply All2_local_env_over_app. constructor. 2:auto. constructor. - simpl. unfold on_decl_over, on_decl in *. destruct p. split; intuition auto. + constructor; auto. depelim p0; constructor; auto; + unfold on_decls_over in *; + now rewrite !app_context_assoc. + - simpl. eapply All2_fold_over_app. constructor. 2:auto. constructor. + simpl. unfold on_decls_over in *. depelim p. revert IHX. generalize (List.rev Δ) (List.rev Δ'). induction 1. constructor. - constructor; auto. red in p0. red. red. red. red in p0. - rewrite !app_context_assoc. cbn. apply p0. - constructor; auto. destruct p0. unfold on_decl_over in *. simpl. - rewrite !app_context_assoc. cbn. intuition. + constructor; auto. depelim p1; constructor; auto; unfold on_decls_over in *; + now rewrite !app_context_assoc. Qed. Lemma All_All2_telescopei_gen P (Γ Γ' Δ Δ' : context) (m m' : mfixpoint term) : (forall Δ Δ' x y, - All2_local_env_over P Γ Γ' Δ Δ' -> + All2_fold_over P Γ Γ' Δ Δ' -> P Γ Γ' x y -> P (Γ ,,, Δ) (Γ' ,,, Δ') (lift0 #|Δ| x) (lift0 #|Δ'| y)) -> All2 (on_Trel_eq (P Γ Γ') dtype dname) m m' -> - All2_local_env_over P Γ Γ' Δ Δ' -> - All2_telescope_n (on_decl P) (fun n : nat => lift0 n) + All2_fold_over P Γ Γ' Δ Δ' -> + All2_telescope_n (on_decls P) (fun n : nat => lift0 n) (Γ ,,, Δ) (Γ' ,,, Δ') #|Δ| (map (fun def : def term => vass (dname def) (dtype def)) m) (map (fun def : def term => vass (dname def) (dtype def)) m'). @@ -1121,24 +1531,24 @@ Proof. intros weakP. induction 1 in Δ, Δ' |- *; cbn. constructor. intros. destruct r. rewrite e. constructor. - red. - rewrite {2}(All2_local_env_length X0). + constructor. + rewrite {2}(All2_fold_length X0). now eapply weakP. specialize (IHX (vass (dname y) (lift0 #|Δ| (dtype x)) :: Δ) (vass (dname y) (lift0 #|Δ'| (dtype y)) :: Δ')). forward IHX. - constructor; auto. now eapply weakP. simpl in IHX. - rewrite {2}(All2_local_env_length X0). + constructor; auto. constructor. now eapply weakP. simpl in IHX. + rewrite {2}(All2_fold_length X0). apply IHX. Qed. Lemma All_All2_telescopei P (Γ Γ' : context) (m m' : mfixpoint term) : (forall Δ Δ' x y, - All2_local_env_over P Γ Γ' Δ Δ' -> + All2_fold_over P Γ Γ' Δ Δ' -> P Γ Γ' x y -> P (Γ ,,, Δ) (Γ' ,,, Δ') (lift0 #|Δ| x) (lift0 #|Δ'| y)) -> All2 (on_Trel_eq (P Γ Γ') dtype dname) m m' -> - All2_telescope_n (on_decl P) (fun n => lift0 n) + All2_telescope_n (on_decls P) (fun n => lift0 n) Γ Γ' 0 (map (fun def => vass (dname def) (dtype def)) m) (map (fun def => vass (dname def) (dtype def)) m'). @@ -1147,13 +1557,13 @@ Proof. intros. specialize (X X0 X1). apply X; constructor. Qed. -Lemma All2_All2_local_env_fix_context P (Γ Γ' : context) (m m' : mfixpoint term) : +Lemma All2_All2_fold_fix_context P (Γ Γ' : context) (m m' : mfixpoint term) : (forall Δ Δ' x y, - All2_local_env_over P Γ Γ' Δ Δ' -> + All2_fold_over P Γ Γ' Δ Δ' -> P Γ Γ' x y -> P (Γ ,,, Δ) (Γ' ,,, Δ') (lift0 #|Δ| x) (lift0 #|Δ'| y)) -> All2 (on_Trel_eq (P Γ Γ') dtype dname) m m' -> - All2_local_env (on_decl (on_decl_over P Γ Γ')) (fix_context m) (fix_context m'). + All2_fold (on_decls (on_decls_over P Γ Γ')) (fix_context m) (fix_context m'). Proof. intros Hweak a. unfold fix_context. eapply local_env_telescope. @@ -1208,8 +1618,8 @@ Section RedPred. apply nth_error_assumption_context in H0 => //; rewrite H0 //. case e: (decl_body d) => [b|] //. eexists x, _; intuition eauto. rewrite nth_error_app_ge in H0 |- *; try lia. - eapply All2_local_env_app in X0 as [_ X0] => //. - pose proof (All2_local_env_length X0). + eapply All2_fold_app_inv in X0 as [_ X0] => //. + pose proof (All2_fold_length X0). rewrite nth_error_app_ge. lia. now rewrite -H1 H0 /= e. } forward X1. red. intros x; split. eapply pred1_refl_gen; auto. @@ -1227,7 +1637,7 @@ Section RedPred. Proof. intros Hlen X H H' X0. assert(lenΔ : #|Δ| = #|Δ'|). - { eapply pred1_pred1_ctx in X. eapply All2_local_env_length in X. + { eapply pred1_pred1_ctx in X. eapply All2_fold_length in X. rewrite !app_context_length in X. lia. } pose proof (strong_substitutivity _ wfΣ _ _ (Γ ,,, Δ) (Γ' ,,, Δ) _ _ ids ids X). forward X1. @@ -1245,8 +1655,8 @@ Section RedPred. apply nth_error_assumption_context in H0 => //; rewrite H0 //. case e: (decl_body d) => [b|] //. eexists x, _; intuition eauto. rewrite nth_error_app_ge in H0 |- *; try lia. - eapply All2_local_env_app in X0 as [_ X0] => //. - pose proof (All2_local_env_length X0). + eapply All2_fold_app_inv in X0 as [_ X0] => //. + pose proof (All2_fold_length X0). rewrite nth_error_app_ge. lia. now rewrite lenΔ H0 /= e. } forward X1. red. intros x; split. eapply pred1_refl_gen; auto. @@ -1257,18 +1667,58 @@ Section RedPred. Ltac noconf H := repeat (DepElim.noconf H; simpl NoConfusion in * ). Hint Extern 1 (eq_binder_annot _ _) => reflexivity : pcuic. - Hint Extern 2 (All2_local_env _ _ _) => apply localenv2_cons_abs : pcuic. - Hint Extern 2 (All2_local_env _ _ _) => apply localenv2_cons_def : pcuic. - + Hint Resolve pred1_refl_gen : pcuic. + Hint Extern 4 (All_decls _ _ _) => constructor : pcuic. + Hint Extern 4 (All2_fold _ _ _) => constructor : pcuic. + Hint Unfold on_decls_over : pcuic. + + Lemma OnOne2_local_env_pred1_ctx_over Γ Δ Δ' : + OnOne2_local_env (on_one_decl (fun Δ M N => pred1 Σ (Γ ,,, Δ) (Γ ,,, Δ) M N)) Δ Δ' -> + pred1_ctx_over Σ Γ Γ Δ Δ'. + Proof. + induction 1. + 1-2:constructor; destruct p; subst; intuition eauto. + - eapply pred1_pred1_ctx in p. pcuic. + - now constructor. + - eapply pred1_pred1_ctx in a0. pcuic. + - eapply pred1_pred1_ctx in a. pcuic. + - constructor; unfold on_decls_over; simpl; subst; intuition auto. + eapply pred1_refl. + - constructor; unfold on_decls_over; simpl; subst; intuition auto. + eapply pred1_refl. + - eapply (All2_fold_app _ _ [d] _ [_]); pcuic. + destruct d as [na [b|] ty]; constructor; pcuic. + constructor; unfold on_decls_over; simpl; subst; auto; intuition pcuic. + eapply pred1_refl_gen. eapply All2_fold_app; pcuic. + eapply pred1_refl_gen. eapply All2_fold_app; pcuic. + unfold on_decls_over; simpl; subst; intuition pcuic. + constructor. + eapply pred1_refl_gen. eapply All2_fold_app; pcuic. + Qed. + + Lemma red1_pred1 Γ : forall M N, red1 Σ Γ M N -> pred1 Σ Γ Γ M N. Proof with pcuic. induction 1 using red1_ind_all; intros; pcuic. - constructor; pcuic. eapply OnOne2_All2... + - constructor; pcuic. + red. simpl. now eapply OnOne2_local_env_pred1_ctx_over in X. + eapply pred1_refl_gen. + eapply OnOne2_local_env_pred1_ctx_over in X. + eapply All2_fold_app; pcuic. - constructor; pcuic. eapply OnOne2_All2... + simpl. intros x y [[[? ?] ?]|?]; unfold on_Trel; intuition pcuic; rewrite -?e; auto. + eapply pred1_ctx_over_refl. + now eapply OnOne2_local_env_pred1_ctx_over in a. + eapply OnOne2_local_env_pred1_ctx_over in a. rewrite b; pcuic. + eapply pred1_refl_gen; eauto. + now apply All2_fold_app; pcuic. - constructor; pcuic. - + apply All2_All2_local_env_fix_context. + eapply OnOne2_All2... + - constructor; pcuic. + + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. eapply OnOne2_All2... intros. @@ -1277,8 +1727,8 @@ Section RedPred. unfold on_Trel; simpl; intros; intuition auto. noconf b; noconf H. rewrite H0. pcuic. apply pred1_refl_gen. - eapply All2_local_env_app_inv; pcuic. - apply All2_All2_local_env_fix_context. + eapply All2_fold_app; pcuic. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. eapply OnOne2_All2... intros. @@ -1288,8 +1738,8 @@ Section RedPred. pcuic. apply pred1_refl_gen; pcuic. - eapply All2_local_env_app_inv; pcuic. - apply All2_All2_local_env_fix_context. + eapply All2_fold_app; pcuic. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. eapply OnOne2_All2... intros. @@ -1297,7 +1747,7 @@ Section RedPred. simpl in *. intuition auto. congruence. - constructor; pcuic. - apply All2_All2_local_env_fix_context. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. + eapply OnOne2_All2... intros. @@ -1326,7 +1776,7 @@ Section RedPred. rewrite -H. pcuic. - constructor; pcuic. - apply All2_All2_local_env_fix_context. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. + eapply OnOne2_All2... intros. @@ -1339,8 +1789,8 @@ Section RedPred. rewrite -H0; pcuic. eapply pred1_ctx_pred1; pcuic. apply fix_context_assumption_context. - apply All2_local_env_over_app. pcuic. - apply All2_All2_local_env_fix_context. + apply All2_fold_over_app. pcuic. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. eapply OnOne2_All2... unfold on_Trel. @@ -1349,15 +1799,15 @@ Section RedPred. simpl in *. intuition pcuic. eapply pred1_ctx_pred1; pcuic. apply fix_context_assumption_context. - apply All2_local_env_over_app. pcuic. - apply All2_All2_local_env_fix_context. + apply All2_fold_over_app. pcuic. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. eapply OnOne2_All2... unfold on_Trel. simpl in *. intuition pcuic. congruence. - constructor; pcuic. - apply All2_All2_local_env_fix_context. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. + eapply OnOne2_All2... unfold on_Trel. @@ -1376,8 +1826,8 @@ Section RedPred. simpl in *. intuition pcuic. eapply pred1_ctx_pred1; pcuic. apply fix_context_assumption_context. - apply All2_local_env_over_app. pcuic. - apply All2_All2_local_env_fix_context. + apply All2_fold_over_app. pcuic. + apply All2_All2_fold_fix_context. now intros; eapply weakening_pred1_pred1. eapply OnOne2_All2... unfold on_Trel. @@ -1392,53 +1842,23 @@ Section PredRed. Context {Σ : global_env}. Context (wfΣ : wf Σ). - Lemma weakening_red_0 Γ Γ' M N n : - n = #|Γ'| -> - red Σ Γ M N -> - red Σ (Γ ,,, Γ') (lift0 n M) (lift0 n N). - Proof. now move=> ->; apply (weakening_red Σ Γ [] Γ'). Qed. - - Lemma red_abs_alt Γ na M M' N N' : red Σ Γ M M' -> red Σ (Γ ,, vass na M) N N' -> - red Σ Γ (tLambda na M N) (tLambda na M' N'). - Proof. - intros. eapply (transitivity (y := tLambda na M N')). - now eapply (red_ctx (tCtxLambda_r _ _ tCtxHole)). - now eapply (red_ctx (tCtxLambda_l _ tCtxHole _)). - Qed. - - Lemma red_letin_alt Γ na d0 d1 t0 t1 b0 b1 : - red Σ Γ d0 d1 -> red Σ Γ t0 t1 -> red Σ (Γ ,, vdef na d0 t0) b0 b1 -> - red Σ Γ (tLetIn na d0 t0 b0) (tLetIn na d1 t1 b1). - Proof. - intros; eapply (transitivity (y := tLetIn na d0 t0 b1)). - now eapply (red_ctx (tCtxLetIn_r _ _ _ tCtxHole)). - eapply (transitivity (y := tLetIn na d0 t1 b1)). - now eapply (red_ctx (tCtxLetIn_b _ _ tCtxHole _)). - now apply (red_ctx (tCtxLetIn_l _ tCtxHole _ _)). - Qed. - - Lemma red_prod_alt Γ na M M' N N' : - red Σ Γ M M' -> red Σ (Γ ,, vass na M') N N' -> - red Σ Γ (tProd na M N) (tProd na M' N'). + (* Lemma red_red_decls Γ Γ' Δ Δ' : + All2_fold_over (fun (Γ _ : context) (t t0 : term) => red Σ Γ t t0) Γ Γ' Δ Δ' -> + All2_fold (fun Δ Δ' : context => red_decls Σ (Γ,,, Δ) (Γ,,, Δ')) Δ Δ'. Proof. - intros. eapply (transitivity (y := tProd na M' N)). - now eapply (red_ctx (tCtxProd_l _ tCtxHole _)). - now eapply (red_ctx (tCtxProd_r _ _ tCtxHole)). - Qed. + induction 1; constructor; auto; + unfold on_decls, on_decls_over in *. + constructor. + simpl. *) (** Parallel reduction is included in the reflexive transitive closure of 1-step reduction *) Lemma pred1_red Γ Γ' : forall M N, pred1 Σ Γ Γ' M N -> red Σ Γ M N. Proof. revert Γ Γ'. eapply (@pred1_ind_all_ctx Σ _ - (fun Γ Γ' => - All2_local_env (on_decl (fun Γ Γ' M N => pred1 Σ Γ Γ' M N -> red Σ Γ M N)) Γ Γ')%type); - intros; try reflexivity; pcuic. - eapply All2_local_env_impl; eauto. - - (* Contexts *) - unfold on_decl => Δ Δ' t T U Hlen. - destruct t; auto. - destruct p; auto. intuition. - + (fun Γ Γ' => All2_fold (on_decls (fun Γ Γ' M N => red Σ Γ M N)) Γ Γ')%type); + (* (fun Γ Γ' Δ Δ' => All2_fold_over (on_decls (fun Γ Γ' M N => pred1 Σ Γ Γ' M N -> red Σ Γ M N)) Γ Γ')%type); *) + intros; try reflexivity; pcuic. + - (* Beta *) apply red_trans with (tApp (tLambda na t0 b1) a0). eapply (@red_app Σ); [apply red_abs|]; auto with pcuic. @@ -1459,7 +1879,6 @@ Section PredRed. eapply red_trans with (lift0 (S i) body'). eapply red1_red; constructor; auto. eapply nth_error_pred1_ctx_all_defs in H; eauto. - specialize (Hpred H). rewrite -(firstn_skipn (S i) Γ). eapply weakening_red_0 => //. rewrite firstn_length_le //. @@ -1467,10 +1886,18 @@ Section PredRed. eapply nth_error_Some_length in Heq. lia. noconf Hnth. - (* Iota *) - transitivity (tCase (ind, pars) p (mkApps (tConstruct ind c u) args1) brs1). - eapply red_case; auto. - eapply red_mkApps. auto. solve_all. red in X2; solve_all. - eapply red1_red. constructor. + transitivity (tCase ci p0 (mkApps (tConstruct ci.(ci_ind) c u) args1) brs1). + etransitivity. + { eapply red_case_c. eapply red_mkApps. auto. solve_all. } + etransitivity. + { eapply red_case_brs. red. solve_all; + unfold on_Trel in *; intuition auto. + eapply red_ctx_rel_red_context_rel; eauto. + red. + eapply PCUICEnvironment.All2_fold_impl; tea. + intros. depelim X2; constructor; auto. } + reflexivity. + eapply red1_red. constructor => //. - move: H H0. move => unf isc. @@ -1480,12 +1907,24 @@ Section PredRed. eapply red_step. econstructor; eauto. 2:eauto. eapply (is_constructor_pred1 Σ). eapply (All2_impl X4); intuition eauto. auto. - - transitivity (tCase ip p1 (mkApps (tCoFix mfix1 idx) args1) brs1). + - transitivity (tCase ci p1 (mkApps (tCoFix mfix1 idx) args1) brs1). + destruct p1; unfold on_Trel in *; cbn in *. + subst puinst. eapply red_case; eauto. - eapply red_mkApps; [|solve_all]. - eapply red_cofix_congr. red in X3; solve_all. eapply a0. - red in X7; solve_all. - eapply red_step. econstructor; eauto. eauto. + * eapply red_ctx_rel_red_context_rel => //. + red. + eapply PCUICEnvironment.All2_fold_impl; tea => /=. + intros ? ? ? ? []; constructor; auto. + * solve_all. + * red. solve_all. + eapply red_mkApps; [|solve_all]. + etransitivity. eapply red_cofix_congr. red in X3; solve_all. + eapply a. reflexivity. + * red. solve_all. + eapply red_ctx_rel_red_context_rel => //. + red. eapply PCUICEnvironment.All2_fold_impl; tea => /=. + intros ???? []; constructor; auto. + * constructor. econstructor; eauto. - transitivity (tProj p (mkApps (tCoFix mfix1 idx) args1)). eapply red_proj_c; eauto. @@ -1501,7 +1940,17 @@ Section PredRed. - now eapply red_abs_alt. - now eapply red_app. - now eapply red_letin_alt => //. - - eapply red_case => //. red in X3; solve_all. + - unfold on_Trel in *; destruct p1; cbn in *. subst puinst. + eapply red_case => //. + * eapply red_ctx_rel_red_context_rel => //. + eapply PCUICEnvironment.All2_fold_impl; tea => //. + now intros ???? []; constructor. + * solve_all. + * red. solve_all. + eapply red_ctx_rel_red_context_rel => //. + eapply PCUICEnvironment.All2_fold_impl; tea => //. + now intros ???? []; constructor. + - now eapply red_proj_c. - eapply red_fix_congr. red in X3; solve_all. eapply a. - eapply red_cofix_congr. red in X3; solve_all. eapply a. @@ -1509,45 +1958,17 @@ Section PredRed. - eapply red_evar; auto. solve_all. Qed. - Lemma All2_local_env_mix P Q x y : All2_local_env P x y -> All2_local_env Q x y -> - All2_local_env (fun Γ Γ' d t T => - (P Γ Γ' d t T) * (Q Γ Γ' d t T))%type x y. + Lemma All2_fold_mix P Q x y : All2_fold P x y -> All2_fold Q x y -> + All2_fold (fun Γ Γ' t T => + (P Γ Γ' t T) * (Q Γ Γ' t T))%type x y. Proof. intros HP HQ; induction HP; depelim HQ; try (simpl in H; noconf H); try (simpl in H0; noconf H0); constructor; intuition eauto. Qed. - Lemma pred1_red_r_gen_fix_context Γ0 Γ'0 Δ Δ' mfix0 mfix1 : - pred1_ctx Σ (Γ'0 ,,, Δ) (Γ'0 ,,, Δ') -> - All2_local_env - (on_decl - (on_decl_over - (fun (Γ Γ' : context) (t t0 : term) => - forall Γ0 Γ'0 Δ Δ' : context, - Γ = Γ0 ,,, Δ - -> Γ' = Γ'0 ,,, Δ' - -> pred1_ctx Σ (Γ'0 ,,, Δ) (Γ'0 ,,, Δ') - -> pred1 Σ (Γ'0 ,,, Δ) (Γ'0 ,,, Δ') t t0) - (Γ0 ,,, Δ) (Γ'0 ,,, Δ'))) (fix_context mfix0) - (fix_context mfix1) -> - All2_local_env (on_decl (on_decl_over (pred1 Σ) (Γ'0 ,,, Δ) (Γ'0 ,,, Δ'))) - (fix_context mfix0) (fix_context mfix1). - Proof. - intros H. - generalize (fix_context mfix0), (fix_context mfix1). - induction 1; constructor; auto. - red. red in p. - unfold on_decl_over in *. - rewrite - !app_context_assoc; eapply p; rewrite !app_context_assoc; try reflexivity. - eapply All2_local_env_app_inv; auto. - destruct p; repeat red in o, o0 |- *; intuition auto; red. - rewrite - !app_context_assoc; eapply o; rewrite !app_context_assoc; try reflexivity. - eapply All2_local_env_app_inv; auto. - rewrite - !app_context_assoc; eapply o0; rewrite !app_context_assoc; try reflexivity. - eapply All2_local_env_app_inv; auto. - Qed. - - Lemma pred1_red_r_gen Γ Γ' Δ Δ' : forall M N, pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') M N -> + Lemma pred1_red_r_gen Γ Γ' Δ Δ' : forall M N, + pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') M N -> + #|Γ| = #|Γ'| -> pred1_ctx Σ (Γ' ,,, Δ) (Γ' ,,, Δ') -> pred1 Σ (Γ' ,,, Δ) (Γ' ,,, Δ') M N. Proof. @@ -1558,106 +1979,98 @@ Section PredRed. revert Γ Γ' Δ Δ' e e'. revert Γ0 Γ'0 M N p. refine (@pred1_ind_all_ctx Σ _ - (fun Γ Γ' => - All2_local_env (on_decl (fun Γ0 Γ'0 M N => - forall Γ Γ' Δ Δ' : context, - Γ0 = Γ ,,, Δ -> Γ'0 = Γ' ,,, Δ' -> - pred1 Σ Γ0 Γ'0 M N -> - pred1_ctx Σ (Γ' ,,, Δ) (Γ' ,,, Δ') -> - pred1 Σ (Γ' ,,, Δ) (Γ' ,,, Δ') M N)) Γ Γ')%type - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); + (fun Γ0 Γ'0 => + forall Γ Γ' Δ Δ' : context, + Γ0 = Γ ,,, Δ -> Γ'0 = Γ' ,,, Δ' -> + #|Γ| = #|Γ'| -> + pred1_ctx Σ (Γ' ,,, Δ) (Γ' ,,, Δ')) + (fun Γ0 Γ'0 ctx ctx' => + forall Γ Γ' Δ Δ' : context, + Γ0 = Γ ,,, Δ -> Γ'0 = Γ' ,,, Δ' -> + #|Γ| = #|Γ'| -> + pred1_ctx_over Σ (Γ' ,,, Δ) (Γ' ,,, Δ') ctx ctx') + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros; subst; try solve [econstructor; eauto]. - - eapply (All2_local_env_impl _ _ _ _ X0). clear X0; intros. - red in X0 |- *. - destruct t as [[t t']|]. - intuition subst. specialize (a Γ1 Γ'0 Δ0 Δ' eq_refl eq_refl). eauto. - eapply b; eauto. intros; subst. eapply X0; eauto. - + - eapply All2_fold_app => //. eapply pred1_ctx_refl. + eapply All2_fold_app_inv in X0 as [] => //. + eapply (All2_fold_impl_ind a0). clear a0; intros; eauto. + red. eapply X1; eauto. eapply All2_fold_app => //. + apply pred1_ctx_refl. + - eapply (All2_fold_impl_ind X3); unfold on_decls_over. intros. + specialize (X5 Γ0 Γ'0 (Δ0 ,,, par) (Δ'0 ,,, par') + ltac:(now rewrite app_context_assoc) ltac:(now rewrite app_context_assoc)). + rewrite !app_context_assoc in X5. apply X5 => //. + eapply All2_fold_app. eapply X1. 2:eauto. all:eauto. + - econstructor; eauto. specialize (X0 Γ0 Γ'0 (Δ ,, vass na t0) (Δ' ,, vass na t1) eq_refl). - apply X0. reflexivity. simpl. constructor; auto. eapply X2; eauto. + apply X0 => //. simpl. constructor; auto. now constructor. - econstructor; eauto. - eapply (X4 Γ0 Γ'0 (Δ ,, vdef na d0 t0) (Δ' ,, vdef na d1 t1) eq_refl eq_refl). - simpl; constructor; auto. red. split. eapply X2; auto. eapply X0; auto. + eapply (X4 Γ0 Γ'0 (Δ ,, vdef na d0 t0) (Δ' ,, vdef na d1 t1) eq_refl eq_refl H). + simpl; constructor; auto. constructor; eauto. - econstructor; eauto. - solve_all. red in X2. solve_all. - - - econstructor; eauto. - eapply pred1_red_r_gen_fix_context; eauto. - red. red in X3. - solve_all. red in a |- *. - intuition auto. eapply b1; eauto. - rewrite - !app_context_assoc; eapply b; - rewrite !app_context_assoc; try reflexivity. - apply All2_local_env_app_inv; eauto. - eapply pred1_red_r_gen_fix_context; eauto. + * solve_all. + * unfold on_Trel in *. solve_all. + rewrite - !app_context_assoc. + eapply b1; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app; eauto. + + - econstructor; eauto. red. red in X3. + unfold on_Trel in *; solve_all. + rewrite - !app_context_assoc. + eapply b; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //. + eapply X2; eauto. solve_all. - - econstructor; eauto. - eapply pred1_red_r_gen_fix_context; eauto. - red. red in X3. - solve_all. red in a0 |- *. - intuition auto. eapply b2; eauto. - rewrite - !app_context_assoc; eapply b0; - rewrite !app_context_assoc; try reflexivity. - apply All2_local_env_app_inv; eauto. - eapply pred1_red_r_gen_fix_context; eauto. - solve_all. - solve_all. - red in X7. solve_all. + - econstructor; eauto; unfold on_Trel in *; solve_all. + red in X3 |- *. unfold on_Trel in *; solve_all. + rewrite - !app_context_assoc; eapply b; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //. eapply X2; eauto. + rewrite - !app_context_assoc; eapply X9; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //. eapply X7; eauto. + rewrite - !app_context_assoc; eapply b1; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //. eapply b0; eauto. - econstructor; eauto. - eapply pred1_red_r_gen_fix_context; eauto. - red in X3 |- *. - solve_all. red in a |- *. - intuition auto. eapply b1; eauto. - rewrite - !app_context_assoc; eapply b; - rewrite !app_context_assoc; try reflexivity. - apply All2_local_env_app_inv; eauto. - eapply pred1_red_r_gen_fix_context; eauto. + red in X3 |- *. unfold on_Trel in *; solve_all. + rewrite - !app_context_assoc; eapply b; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //. eapply X2; eauto. solve_all. - econstructor; eauto. solve_all. - econstructor; eauto. - eapply (X2 _ _ (Δ ,, vass na M) (Δ' ,, vass na M')); try reflexivity. - simpl; constructor; eauto. - red. eapply X0; eauto. + eapply (X2 _ _ (Δ ,, vass na M) (Δ' ,, vass na M')); eauto; try reflexivity => //. + simpl; constructor; eauto. now constructor. - econstructor; eauto. - eapply (X4 _ _ (Δ ,, vdef na d0 t0) (Δ' ,, vdef na d1 t1)); try reflexivity. - simpl; constructor; eauto. - red. split. eapply X0; eauto. eapply X2; eauto. + eapply (X4 _ _ (Δ ,, vdef na d0 t0) (Δ' ,, vdef na d1 t1)); eauto; try reflexivity. + simpl; constructor; eauto. now constructor. - - econstructor; eauto. - red in X3. solve_all. + - unfold on_Trel in *; econstructor; eauto; unfold on_Trel; solve_all. + rewrite - !app_context_assoc; eapply X5; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //; eapply X3; eauto. + rewrite - !app_context_assoc; eapply b1; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //; eapply b0; eauto. - econstructor; eauto. - eapply pred1_red_r_gen_fix_context; eauto. - red in X3 |- *; solve_all. - eapply a; eauto. - rewrite - !app_context_assoc; eapply b; - rewrite !app_context_assoc; try reflexivity. - apply All2_local_env_app_inv; eauto. - eapply pred1_red_r_gen_fix_context; eauto. + red in X3 |- *. unfold on_Trel in *; solve_all. + rewrite - !app_context_assoc; eapply b; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //. eapply X2; eauto. - econstructor; eauto. - eapply pred1_red_r_gen_fix_context; eauto. - red in X3 |- *; solve_all. - eapply a; eauto. - rewrite - !app_context_assoc; eapply b; - rewrite !app_context_assoc; try reflexivity. - apply All2_local_env_app_inv; eauto. - eapply pred1_red_r_gen_fix_context; eauto. + red in X3 |- *. unfold on_Trel in *; solve_all. + rewrite - !app_context_assoc; eapply b; rewrite ?app_context_assoc; eauto. + eapply All2_fold_app => //. eapply X2; eauto. - econstructor; eauto. - eapply (X2 _ _ (Δ ,, vass na M0) (Δ' ,, vass na M1)); try reflexivity. - simpl; constructor; eauto. - red. eapply X0; eauto. + eapply (X2 _ _ (Δ ,, vass na M0) (Δ' ,, vass na M1)); try reflexivity; auto. + simpl; constructor; eauto. now constructor. - econstructor; eauto. solve_all. Qed. @@ -1667,6 +2080,7 @@ Section PredRed. Proof. intros M N pred. apply (pred1_red_r_gen _ _ [] [] M N pred). + eapply pred1_pred1_ctx in pred. apply (length_of pred). simpl. eapply pred1_ctx_refl. Qed. @@ -1928,28 +2342,6 @@ Section RedConfluence. econstructor 2; eauto. Qed. - Definition on_one_decl (P : context -> term -> term -> Type) (Γ : context) (b : option (term × term)) (t t' : term) := - match b with - | Some (b0, b') => ((P Γ b0 b' * (t = t')) + (P Γ t t' * (b0 = b')))%type - | None => P Γ t t' - end. - - Section OnOne_local_2. - Context (P : forall (Γ : context), option (term * term) -> term -> term -> Type). - - (** We allow alpha-conversion *) - Inductive OnOne2_local_env : context -> context -> Type := - | localenv2_cons_abs Γ na t t' : - P Γ None t t' -> - OnOne2_local_env (Γ ,, vass na t) (Γ ,, vass na t') - | localenv2_cons_def Γ na b b' t t' : - P Γ (Some (b, b')) t t' -> - OnOne2_local_env (Γ ,, vdef na b t) (Γ ,, vdef na b' t') - | localenv2_cons_tl Γ Γ' d : - OnOne2_local_env Γ Γ' -> - OnOne2_local_env (Γ ,, d) (Γ' ,, d). - End OnOne_local_2. - 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) -> @@ -1957,29 +2349,11 @@ Section RedConfluence. | 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. - Inductive eq_context_upto_names : context -> context -> Type := - | eq_context_nil : eq_context_upto_names [] [] - | eq_context_decl x y Γ Γ' : - eq_binder_annot x.(decl_name) y.(decl_name) -> decl_body x = decl_body y -> decl_type x = decl_type y -> - eq_context_upto_names Γ Γ' -> - eq_context_upto_names (Γ ,, x) (Γ' ,, y). - - Derive Signature for eq_context_upto_names. + Definition eq_context_upto_names := eq_context_gen eq eq. - Global Instance eq_context_upto_names_refl : Reflexive eq_context_upto_names. - Proof. intros Γ; induction Γ; constructor; auto. Qed. - - Global Instance eq_context_upto_names_sym : Symmetric eq_context_upto_names. - Proof. intros Γ Γ' H; induction H; constructor; auto. now symmetry. Qed. - - Global Instance eq_context_upto_names_trans : Transitive eq_context_upto_names. - Proof. - intros Γ0 Γ1 Γ2 H. - induction H in Γ2 |- *; intros H2; depelim H2; econstructor; auto. - etransitivity; eauto. - etransitivity; eauto. - etransitivity; eauto. - Qed. + Global Instance eq_context_upto_names_refl : Reflexive eq_context_upto_names := _. + Global Instance eq_context_upto_names_sym : Symmetric eq_context_upto_names := _. + Global Instance eq_context_upto_names_trans : Transitive eq_context_upto_names := _. Inductive clos_refl_trans_ctx (R : relation context) (x : context) : context -> Type := | rt_ctx_step : forall y, R x y -> clos_refl_trans_ctx R x y @@ -1995,36 +2369,28 @@ Section RedConfluence. intros x y z; econstructor 3; eauto. Qed. - Definition red1_ctx := (OnOne2_local_env (on_one_decl (fun Δ t t' => red1 Σ Δ t t'))). - Definition red1_rel : relation (context * term) := relation_disjunction (fun '(Γ, t) '(Δ, u) => (red1 Σ Γ t u * (Γ = Δ)))%type - (fun '(Γ, t) '(Δ, u) => (red1_ctx Γ Δ * (t = u)))%type. + (fun '(Γ, t) '(Δ, u) => (red1_ctx Σ Γ Δ * (t = u)))%type. Definition red_ctx : relation context := - All2_local_env (on_decl (fun Γ Δ t u => red Σ Γ t u)). + All2_fold (on_decls (fun Γ Δ => red Σ Γ)). - Lemma red1_ctx_pred1_ctx Γ Γ' : red1_ctx Γ Γ' -> pred1_ctx Σ Γ Γ'. + Lemma red1_ctx_pred1_ctx Γ Γ' : red1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ Γ'. Proof. - intros. induction X; try constructor. pcuic. red. pcuic. - now eapply red1_pred1. pcuic. reflexivity. - destruct p as [[redb ->]|[redt ->]]; try reflexivity. - - split; pcuic. now eapply red1_pred1. - - split; pcuic. now eapply red1_pred1. - - destruct d as [na [b|] ty]. - * constructor; intuition auto. red. - split; now eapply pred1_refl_gen. - * constructor; intuition auto. red. - now eapply pred1_refl_gen. + intros. induction X; try constructor; auto. pcuic. + cbn in p. destruct p as [-> p]. constructor. + now eapply red1_pred1. pcuic. + destruct p as [-> p]; constructor; auto; + destruct p as [[redb ->]|[redt ->]]; try reflexivity; pcuic; now eapply red1_pred1. + - eapply All_decls_refl. intro. now eapply pred1_refl_gen. Qed. Lemma pred1_ctx_red_ctx Γ Γ' : pred1_ctx Σ Γ Γ' -> red_ctx Γ Γ'. Proof. intros. induction X; try constructor; pcuic. - now eapply pred1_red in p. - destruct p as [redb redt]. - split. now apply pred1_red in redb. - now apply pred1_red in redt. + eapply All_decls_impl; tea. + now eapply pred1_red. Qed. Definition red_rel_ctx := @@ -2039,25 +2405,23 @@ Section RedConfluence. now eapply pred1_ctx_red_ctx. Qed. - Lemma clos_rt_OnOne2_local_env_incl R : inclusion (OnOne2_local_env (on_one_decl (fun Δ => clos_refl_trans (R Δ)))) (clos_refl_trans (OnOne2_local_env (on_one_decl R))). Proof. intros x y H. - induction H; firstorder. - - red in p. - induction p. repeat constructor. pcuicfo. + induction H; firstorder; try subst na'. + - induction b. repeat constructor. pcuicfo. constructor 2. econstructor 3 with (Γ ,, vass na y); auto. - subst. - induction a. repeat constructor. pcuicfo. - constructor 2. - econstructor 3 with (Γ ,, vdef na y t'); auto. - - subst. - induction a. constructor. constructor. red. right. pcuicfo. + induction a0. repeat constructor. pcuicfo. constructor 2. econstructor 3 with (Γ ,, vdef na b' y); auto. + - subst t'. + induction a0. constructor. constructor. red. simpl. pcuicfo. + constructor 2. + econstructor 3 with (Γ ,, vdef na y t); auto. - clear H. induction IHOnOne2_local_env. constructor. now constructor 3. constructor 2. eapply transitivity. eauto. auto. @@ -2070,40 +2434,27 @@ Section RedConfluence. intros x y H. induction H; firstorder; try solve[econstructor; eauto]. Qed. - - Lemma OnOne2_local_env_impl R S : - (forall Δ, inclusion (R Δ) (S Δ)) -> - inclusion (OnOne2_local_env (on_one_decl R)) - (OnOne2_local_env (on_one_decl S)). - Proof. - intros H x y H'. - induction H'; try solve [econstructor; firstorder]. - Qed. - - Lemma red_ctx_clos_rt_red1_ctx : inclusion red_ctx (clos_refl_trans_ctx red1_ctx). + + Lemma red_ctx_clos_rt_red1_ctx : inclusion red_ctx (clos_refl_trans_ctx (red1_ctx Σ)). Proof. intros x y H. induction H; try firstorder. - red in p. - transitivity (Γ ,, vass na t'). - eapply clos_rt_OnOne2_local_env_ctx_incl, clos_rt_OnOne2_local_env_incl. constructor. red. - eassumption. - clear p H. - transitivity (Γ ,, vass na' t'). - { constructor 2. repeat constructor; auto. simpl. reflexivity. } - induction IHAll2_local_env; try solve[repeat constructor; auto]. - etransitivity; eauto. - transitivity (Γ ,, vdef na b t'). - - eapply clos_rt_OnOne2_local_env_ctx_incl, clos_rt_OnOne2_local_env_incl. constructor 2. red. - right. split; auto. - - transitivity (Γ ,, vdef na b' t'). - eapply clos_rt_OnOne2_local_env_ctx_incl, clos_rt_OnOne2_local_env_incl. - constructor 2. red. left; split; auto. - clear -e IHAll2_local_env. - transitivity (Γ ,, vdef na' b' t'). - { constructor 2. repeat constructor; auto. simpl. reflexivity. } - induction IHAll2_local_env; try solve[repeat constructor; auto]. + destruct p. + - transitivity (Γ ,, vass na t'). + eapply clos_rt_OnOne2_local_env_ctx_incl, clos_rt_OnOne2_local_env_incl. constructor. + cbn. split; auto. + clear r H. + induction IHAll2_fold; try solve[repeat constructor; auto]. etransitivity; eauto. + - transitivity (Γ ,, vdef na b t'). + * eapply clos_rt_OnOne2_local_env_ctx_incl, clos_rt_OnOne2_local_env_incl. constructor 2. + cbn. split; auto. + * transitivity (Γ ,, vdef na b' t'). + + eapply clos_rt_OnOne2_local_env_ctx_incl, clos_rt_OnOne2_local_env_incl. + constructor 2. cbn. split; auto. + + clear -IHAll2_fold. + induction IHAll2_fold; try solve[repeat constructor; auto]. + etransitivity; eauto. Qed. Inductive clos_refl_trans_ctx_t (R : relation (context * term)) (x : context * term) : context * term -> Type := @@ -2169,26 +2520,16 @@ Section RedConfluence. induction redt. induction redctx; try solve [constructor; eauto]. - constructor 2; simpl; apply reflexivity. - - red in p. - etransitivity. + - etransitivity. * eapply clos_rt_ctx_t_disjunction_right. - instantiate (1:= (Γ',, vass na' t', x)). + instantiate (1:= (Γ',, d', x)). eapply clos_refl_trans_ctx_t_prod_l. intros. split; eauto. - transitivity (Γ ,, vass na' t). + transitivity (Γ ,, d). constructor 2. repeat constructor. simpl. auto. reflexivity. + reflexivity. apply red_ctx_clos_rt_red1_ctx. constructor; auto. * clear p. eapply clos_rt_ctx_t_disjunction_right. constructor 2; simpl; reflexivity. - - red in p. destruct p. etransitivity. - * eapply clos_rt_ctx_t_disjunction_right. - instantiate (1:= (Γ',, vdef na b' t', x)). - eapply clos_refl_trans_ctx_t_prod_l. intros. split; eauto. - apply red_ctx_clos_rt_red1_ctx. constructor; auto. - red. split; auto. - * clear r r0. - eapply clos_rt_ctx_t_disjunction_right. - eapply clos_refl_trans_ctx_t_prod_l. intros. split; eauto. - constructor 2. constructor; auto. apply reflexivity. - transitivity (Γ, y). * eapply clos_rt_ctx_t_disjunction_left. eapply clos_refl_trans_ctx_t_prod_r. intros. split; eauto. @@ -2196,10 +2537,14 @@ Section RedConfluence. * apply IHredt. Qed. + Definition pred1_rel_alpha : (context * term) -> (context * term) -> Type := + fun t u => (pred1 Σ (fst t) (fst u) (snd t) (snd u) + + (eq_context_upto_names (fst t) (fst u) × snd t = snd u))%type. + Definition red1_rel_alpha : relation (context * term) := relation_disjunction (fun '(Γ, t) '(Δ, u) => (red1 Σ Γ t u * (Γ = Δ)))%type (relation_disjunction - (fun '(Γ, t) '(Δ, u) => ((red1_ctx Γ Δ * (t = u)))) + (fun '(Γ, t) '(Δ, u) => ((red1_ctx Σ Γ Δ * (t = u)))) (fun '(Γ, t) '(Δ, u) => ((eq_context_upto_names Γ Δ * (t = u)))))%type. Lemma clos_rt_red1_rel_rt_ctx : inclusion (clos_refl_trans red1_rel) (clos_refl_trans_ctx_t red1_rel). @@ -2211,47 +2556,135 @@ Section RedConfluence. - econstructor 3; eauto. Qed. - Lemma red1_rel_alpha_pred1_rel : inclusion red1_rel_alpha pred1_rel. + Lemma red1_rel_alpha_pred1_rel_alpha : inclusion red1_rel_alpha pred1_rel_alpha. Proof. intros [ctx t] [ctx' t']. - rewrite /red1_rel_alpha /pred1_rel /=. + rewrite /red1_rel_alpha /pred1_rel_alpha /=. intros [[l <-]|[[r <-]|[r <-]]]. - - now eapply red1_pred1. - - eapply pred1_refl_gen. now apply red1_ctx_pred1_ctx. - - eapply pred1_refl_gen. - induction r. - * constructor. - * destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl in *; noconf e; try noconf e0. - constructor; auto. red. split. now apply pred1_refl_gen. subst. - eapply pred1_refl_gen; eauto. - constructor; auto. red. subst; apply pred1_refl_gen; auto. + - left; now eapply red1_pred1. + - left. eapply pred1_refl_gen. now apply red1_ctx_pred1_ctx. + - right; split; auto. Qed. - Lemma pred1_rel_red1_rel_alpha : inclusion pred1_rel (clos_refl_trans red1_rel_alpha). + Lemma pred1_rel_alpha_red1_rel_alpha : inclusion pred1_rel_alpha (clos_refl_trans red1_rel_alpha). Proof. intros x y pred. red in pred. - eapply pred1_red' in pred; auto. - destruct pred. - destruct x, y. simpl in *. - transitivity (c, t0). - - eapply clos_rt_disjunction_left. - eapply clos_refl_trans_prod_r; tea. intros. split; eauto. - - eapply clos_rt_disjunction_right. - eapply (clos_refl_trans_prod_l (fun x y => red1_ctx x y + eq_context_upto_names x y))%type. - intros. red. destruct X; intuition auto. - clear r. - apply red_ctx_clos_rt_red1_ctx in r0. - induction r0. constructor; auto. - constructor. auto. - now transitivity y. + destruct pred as [pred|[pctx eq]]. + - eapply pred1_red' in pred; auto. + destruct pred. + destruct x, y. simpl in *. + transitivity (c, t0). + + eapply clos_rt_disjunction_left. + eapply clos_refl_trans_prod_r; tea. intros. split; eauto. + + eapply clos_rt_disjunction_right. + eapply (clos_refl_trans_prod_l (fun x y => red1_ctx Σ x y + eq_context_upto_names x y))%type. + intros. red. destruct X; intuition auto. + clear r. + apply red_ctx_clos_rt_red1_ctx in r0. + induction r0. constructor; auto. + constructor. auto. + now transitivity y. + - constructor. right. right. destruct x, y; cbn in *; auto. + Qed. + + Lemma pred1_upto_names_gen {Γ Γ' Δ Δ' t u} : + pred1 Σ Γ Δ t u -> + eq_context_upto_names Γ Γ' -> + eq_context_upto_names Δ Δ' -> + pred1_ctx Σ Γ' Δ' -> + pred1 Σ Γ' Δ' t u. + Proof. + intros pr eqctx eqctx' predctx. + epose proof (strong_substitutivity Σ wfΣ Γ Δ Γ' Δ' t u ids ids pr). + forward X. + { intros x d hnth. destruct d as [na [b|] ty] => /= //. + exists x, b. split; auto. + eapply All2_fold_nth in hnth as [d' [hnth' [eqctx'' eqd]]]. 2:exact eqctx. + sigma. split; auto. + simpl in *. depelim eqd. subst. + now rewrite hnth' /=. } + forward X. + { intros x d hnth. destruct d as [na [b|] ty] => /= //. + exists x, b. split; auto. + eapply All2_fold_nth in hnth as [d' [hnth' [eqctx'' eqd]]]. 2:exact eqctx'. + sigma. split; auto. + simpl in *. depelim eqd. subst. + now rewrite hnth' /=. } + forward X. { + intros x; split. now constructor. + destruct option_map => //. destruct o => //. + } + now rewrite !subst_ids in X. + Qed. + + Lemma pred1_ctx_upto_names {Γ Γ' Δ} : + pred1_ctx Σ Γ Δ -> + eq_context_upto_names Γ Γ' -> + ∑ Δ', pred1_ctx Σ Γ' Δ' × eq_context_upto_names Δ Δ'. + Proof. + intros pr eqctx. + induction eqctx in Δ, pr |- *; depelim pr. + - exists []; split; auto; pcuic. + - depelim a. + * depelim p0. subst. + destruct (IHeqctx _ pr) as [Δ' [pred' eq']]. + exists (vass na' t' :: Δ'). + split. constructor. apply pred'. constructor. + eapply pred1_upto_names_gen; tea. + constructor => //. constructor => //. + * destruct (IHeqctx _ pr) as [Δ' [pred' eq']]. + depelim p1; subst. + exists (vdef na' b' t' :: Δ'). + split. constructor. apply pred'. constructor. + eapply pred1_upto_names_gen; tea. + eapply pred1_upto_names_gen; tea. + constructor => //. constructor => //. + Qed. + + Lemma pred1_upto_names {Γ Γ' Δ t u} : + pred1 Σ Γ Δ t u -> + eq_context_upto_names Γ Γ' -> + ∑ Δ', pred1 Σ Γ' Δ' t u × eq_context_upto_names Δ Δ'. + Proof. + intros pr eqctx. + pose proof (pred1_pred1_ctx _ pr). + destruct (pred1_ctx_upto_names X eqctx) as [Δ' [pred' eq']]. + exists Δ'; split; auto. + now eapply pred1_upto_names_gen. + Qed. + + Lemma diamond_pred1_rel_alpha : diamond pred1_rel_alpha. + Proof. + move=> t u v tu tv. + destruct tu as [tu|[tu eq]], tv as [tv|[tv eq']]. + - destruct (pred1_diamond wfΣ tu tv). + eexists (rho_ctx Σ (fst t), rho Σ (rho_ctx Σ (fst t)) (snd t)). + split; left; auto. + - destruct t as [ctxt t], u as [ctxu u], v as [ctxv v]; cbn in *; subst v. + eapply pred1_upto_names in tu as [Δ' [pred eqctx]]; tea. + exists (Δ', u). unfold pred1_rel_alpha; cbn. + firstorder. + - destruct t as [ctxt t], u as [ctxu u], v as [ctxv v]; cbn in *; subst u. + eapply pred1_upto_names in tv as [Δ' [pred eqctx]]; tea. + exists (Δ', v). unfold pred1_rel_alpha; cbn. + firstorder. + - destruct t as [ctxt t], u as [ctxu u], v as [ctxv v]; cbn in *; subst u v. + exists (ctxt, t). unfold pred1_rel_alpha; cbn. + split. right; split; auto. now symmetry. + right. split; auto. now symmetry. + Qed. + + Lemma pred1_rel_alpha_confluent : confluent pred1_rel_alpha. + Proof. + eapply diamond_confluent. apply diamond_pred1_rel_alpha. Qed. Lemma pred_rel_confluent : confluent red1_rel_alpha. Proof. notypeclasses refine (fst (sandwich _ _ _ _) _). - 3:eapply pred1_rel_confluent; eauto. - - apply red1_rel_alpha_pred1_rel. - - apply pred1_rel_red1_rel_alpha. + 3:eapply pred1_rel_alpha_confluent; eauto. + - apply red1_rel_alpha_pred1_rel_alpha. + - apply pred1_rel_alpha_red1_rel_alpha. Qed. Lemma clos_refl_trans_out Γ x y : @@ -2262,83 +2695,6 @@ Section RedConfluence. econstructor 3; eauto. Qed. - Lemma red_red_ctx Γ Δ t u : - red Σ Γ t u -> - red_ctx Δ Γ -> - red Σ Δ t u. - Proof. - move=> H Hctx. induction H. - revert Δ Hctx. - induction r using red1_ind_all; intros Δ Hctx; try solve [eapply red_step; repeat (constructor; eauto)]. - - red in Hctx. - eapply nth_error_pred1_ctx in Hctx; eauto. - destruct Hctx as [x' [? ?]]. - eapply red_step. constructor. eauto. - rewrite -(firstn_skipn (S i) Δ). - eapply weakening_red_0; auto. - rewrite firstn_length_le //. - destruct (nth_error Δ) eqn:Heq => //. - eapply nth_error_Some_length in Heq. lia. - - repeat econstructor; eassumption. - - repeat econstructor; eassumption. - - repeat econstructor; eassumption. - - repeat econstructor; eassumption. - - eapply red_abs_alt. eauto. eauto. - - eapply red_abs_alt. eauto. apply (IHr (Δ ,, vass na N)). - constructor; auto. red. auto. - - eapply red_letin; eauto. - - eapply red_letin; eauto. - - eapply red_letin_alt; eauto. - eapply (IHr (Δ ,, vdef na b t)). constructor; eauto. - red. split; eauto. - - eapply red_case; eauto. unfold on_Trel; pcuic. - - eapply red_case; eauto. unfold on_Trel; pcuic. - - eapply red_case; eauto. unfold on_Trel; pcuic. - eapply OnOne2_All2; eauto. simpl. intuition eauto. - - eapply red_proj_c; eauto. - - eapply red_app; eauto. - - eapply red_app; eauto. - - eapply red_prod_alt; eauto. - - eapply red_prod_alt; eauto. apply (IHr (Δ ,, vass na M1)); constructor; auto. - red; eauto. - - eapply red_evar. - eapply OnOne2_All2; simpl; eauto. simpl. intuition eauto. - - eapply red_fix_one_ty. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - - eapply red_fix_one_body. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - eapply ih. - clear - Hctx. induction (fix_context mfix0). - + assumption. - + simpl. destruct a as [na [b|] ty]. - * constructor ; pcuicfo (hnf ; auto). - * constructor ; pcuicfo (hnf ; auto). - - eapply red_cofix_one_ty. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - - eapply red_cofix_one_body. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - eapply ih. - clear - Hctx. induction (fix_context mfix0). - + assumption. - + simpl. destruct a as [na [b|] ty]. - * constructor ; pcuicfo (hnf ; auto). - * constructor ; pcuicfo (hnf ; auto). - - auto. - - eapply red_trans; eauto. - Qed. - Lemma clos_red_rel_out x y : clos_refl_trans red1_rel x y -> clos_refl_trans pred1_rel x y. @@ -2401,26 +2757,31 @@ Section RedConfluence. Global Instance red_ctx_refl : Reflexive red_ctx. Proof. - move=> x. - induction x as [|[na [b|] ty] ctx]; constructor; intuition (try red; auto). + move=> x. eapply All2_fold_refl; intros; apply All_decls_refl; auto. Qed. + Hint Transparent context : typeclass_instances. + + Lemma red_ctx_red_context Γ Δ : red_ctx Γ Δ <~> red_context Σ Γ Δ. + Proof. + split; intros. + - red. eapply PCUICEnvironment.All2_fold_impl; tea. + intros ???? []; constructor; auto. + - red in X |- *. + eapply PCUICEnvironment.All2_fold_impl; tea. + intros ???? []; constructor; auto. + Qed. + Global Instance red_ctx_trans : Transitive red_ctx. Proof. move=> Γ Γ' Γ'' H1 H2. - unfold red_ctx in *. - induction H1 in Γ'', H2 |- *; depelim H2; try (hnf in H; noconf H); - constructor; auto. transitivity na'; eauto. - red in o, p. red. - transitivity t'; eauto. - eapply red_red_ctx; eauto. - now transitivity na'. - destruct p, o. red. - split. - transitivity b'; eauto. - eapply red_red_ctx; eauto. - transitivity t'; eauto. + unfold red_ctx in *. + eapply All2_fold_trans; tea. + intros. transitivity y => //. + eapply All_decls_impl; tea. + intros t t' r. eapply red_red_ctx; eauto. + now eapply red_ctx_red_context. Qed. Lemma clos_rt_red1_rel_red1 x y : @@ -2431,8 +2792,7 @@ Section RedConfluence. intros H. eapply clos_rt_rt1n_iff in H. induction H. - - split. red. induction (fst x) as [|[na [b|] ty] tl]; try constructor; hnf; eauto. - constructor 2. + - split; reflexivity. - destruct x as [Γ t], y as [Δ u], z as [Δ' u']; simpl in *. destruct IHclos_refl_trans_1n. red in r. destruct r. @@ -2444,7 +2804,8 @@ Section RedConfluence. etransitivity; eauto. eapply red_red_ctx; eauto. apply red1_ctx_pred1_ctx in r. - now apply pred1_ctx_red_ctx in r. + apply pred1_ctx_red_ctx in r. + now eapply red_ctx_red_context. Qed. Lemma decl_body_eq_context_upto_names Γ Γ' n d : @@ -2453,8 +2814,8 @@ Section RedConfluence. option_map decl_body (nth_error Γ' n) = Some d. Proof. move: Γ' n d; induction Γ; destruct n; simpl; intros; try congruence. - noconf H. depelim X. simpl. now rewrite -e0. - depelim X. simpl. apply IHΓ; auto. + noconf H. depelim X. depelim c; subst; simpl => //. + depelim X. apply IHΓ; auto. Qed. Lemma decl_type_eq_context_upto_names Γ Γ' n d : @@ -2463,7 +2824,7 @@ Section RedConfluence. option_map decl_type (nth_error Γ' n) = Some d. Proof. move: Γ' n d; induction Γ; destruct n; simpl; intros; try congruence. - noconf H. depelim X. simpl. now rewrite -e1. + noconf H. depelim X. depelim c; subst; simpl => //. depelim X. simpl. apply IHΓ; auto. Qed. @@ -2471,7 +2832,8 @@ Section RedConfluence. eq_context_upto_names Γ Γ' -> eq_context_upto_names (Γ ,,, Δ) (Γ' ,,, Δ). Proof. - induction Δ; auto. constructor; auto. + intros. + induction Δ; auto. constructor; auto. reflexivity. Qed. Lemma red1_eq_context_upto_names Γ Γ' t u : @@ -2479,24 +2841,10 @@ Section RedConfluence. red1 Σ Γ t u -> red1 Σ Γ' t u. Proof. - move=> Hctx H. - revert Γ' Hctx. - induction H using red1_ind_all; intros Δ Hctx; try solve [repeat (econstructor; eauto)]. - - constructor. - now eapply decl_body_eq_context_upto_names. - - constructor. apply (IHred1 (Δ ,, vass na N)). constructor; auto. - - constructor. apply (IHred1 (Δ ,, vdef na b t)). constructor; auto. - - constructor. solve_all. - - constructor. apply (IHred1 (Δ ,, vass na M1)). constructor; auto. - - constructor. solve_all. - - constructor. solve_all. - - eapply fix_red_body; solve_all. - eapply (b0 (Δ ,,, fix_context mfix0)). - now apply eq_context_upto_names_app. - - eapply cofix_red_ty; solve_all. - - eapply cofix_red_body; solve_all. - eapply (b0 (Δ ,,, fix_context mfix0)). - now apply eq_context_upto_names_app. + move=> Hctx. + eapply context_pres_let_bodies_red1. + eapply PCUICEnvironment.All2_fold_impl; tea => /= _ _ ? ? [] /=; + rewrite /pres_let_bodies /= //; intros; congruence. Qed. Lemma clos_rt_red1_eq_context_upto_names Γ Γ' t u : @@ -2516,75 +2864,98 @@ 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 Σ Γ)). Lemma eq_context_upto_names_red_ctx Γ Δ Γ' Δ' : eq_context_upto_names Γ Γ' -> eq_context_upto_names Δ Δ' -> red_ctx Γ Δ -> - red_ctx Γ' Δ'. + red_ctx_alpha Γ' Δ'. Proof. intros. induction X in X0, Δ, Δ', X1 |- *. depelim X1. depelim X0. constructor. - destruct x as [na b ty], y as [na' b' ty']; simpl in *. - subst. - depelim X1. depelim X0. - red in o. simpl in *. subst. - destruct y as [? [b'|] ?]; noconf e1. simpl. - constructor; auto. eapply IHX; eauto. - transitivity na. now symmetry. - transitivity na'0; auto. - red. eapply red_eq_context_upto_names; eauto. - destruct o. depelim X0. simpl in *. - destruct y as [? [b'|] ?]; noconf e1; subst; simpl in *. - constructor; auto. - eapply IHX; eauto. - transitivity na. now symmetry. - transitivity na'0; auto. - red. - split; eauto using red_eq_context_upto_names. + depelim X1. depelim X0. + constructor. eapply IHX; tea. + depelim p; depelim c; subst; depelim a; try constructor; eauto. + 1,3:now etransitivity. + all:eapply red_eq_context_upto_names; eauto. + Qed. + + Lemma eq_context_upto_names_red_ctx_alpha Γ Δ Γ' Δ' : + eq_context_upto_names Γ Γ' -> + eq_context_upto_names Δ Δ' -> + red_ctx_alpha Γ Δ -> + red_ctx_alpha Γ' Δ'. + Proof. + intros. + induction X in X0, Δ, Δ', X1 |- *. depelim X1. depelim X0. constructor. + depelim X1. depelim X0. + constructor. eapply IHX; tea. + depelim p; depelim c; subst; depelim a; try constructor; eauto. + 1,3:now etransitivity. + all:eapply red_eq_context_upto_names; eauto. Qed. Instance proper_red_ctx : - Proper (eq_context_upto_names ==> eq_context_upto_names ==> iffT) red_ctx. + Proper (eq_context_upto_names ==> eq_context_upto_names ==> iffT) red_ctx_alpha. Proof. reduce_goal. split. - intros. eapply eq_context_upto_names_red_ctx; eauto. - intros. symmetry in X, X0. eapply eq_context_upto_names_red_ctx; eauto. + intros. eapply eq_context_upto_names_red_ctx_alpha; eauto. + intros. symmetry in X, X0. eapply eq_context_upto_names_red_ctx_alpha; eauto. + Qed. + + Instance red_ctx_alpha_refl : Reflexive red_ctx_alpha. + Proof. + rewrite /red_ctx_alpha. + intros x; apply All2_fold_refl; tc. + Qed. + + Lemma red_ctx_red_ctx_alpha_trans Γ Δ Δ' : + red_ctx Γ Δ -> red_ctx_alpha Δ Δ' -> red_ctx_alpha Γ Δ'. + Proof. + intros r r'. + induction r in Δ', r' |- *; depelim r'; constructor; auto. + now eapply IHr. + depelim p; depelim a; constructor; auto. + all:etransitivity; tea. + all:eapply red_red_ctx; tea; now eapply red_ctx_red_context. Qed. Lemma clos_rt_red1_alpha_out x y : clos_refl_trans red1_rel_alpha x y -> - red_ctx (fst x) (fst y) * + red_ctx_alpha (fst x) (fst y) * clos_refl_trans (red1 Σ (fst x)) (snd x) (snd y). Proof. intros H. eapply clos_rt_rt1n_iff in H. induction H. - - split. red. induction (fst x) as [|[na [b|] ty] tl]; try constructor; hnf; eauto. - constructor 2. + - split; reflexivity. - destruct x as [Γ t], y as [Δ u], z as [Δ' u']; simpl in *. destruct IHclos_refl_trans_1n. red in r. destruct r. * destruct p. subst. split. auto. transitivity u; auto. - * destruct r. destruct p. subst. split. + * destruct r. destruct p. subst. split; auto. apply red1_ctx_pred1_ctx in r. apply pred1_ctx_red_ctx in r. - etransitivity; eauto. + eapply red_ctx_red_ctx_alpha_trans; tea. eapply red_red_ctx; eauto. apply red1_ctx_pred1_ctx in r. - now apply pred1_ctx_red_ctx in r. + apply pred1_ctx_red_ctx in r. + now eapply red_ctx_red_context. destruct p. subst. split; auto. - eapply eq_context_upto_names_red_ctx. 3:eauto. now symmetry in e. reflexivity. + eapply eq_context_upto_names_red_ctx_alpha. 3:eauto. now symmetry in e. reflexivity. eapply clos_rt_red1_eq_context_upto_names; eauto. now symmetry in e. Qed. Lemma red1_red1_ctx_inv Γ Δ Δ' t u : red1 Σ (Γ ,,, Δ) t u -> assumption_context Δ -> - red1_ctx (Γ ,,, Δ) (Γ ,,, Δ') -> + red1_ctx Σ (Γ ,,, Δ) (Γ ,,, Δ') -> red Σ (Γ ,,, Δ') t u. Proof. intros redt assΔ redΔ. @@ -2597,7 +2968,7 @@ Section RedConfluence. Lemma red_red1_ctx_inv Γ Δ Δ' t u : red Σ (Γ ,,, Δ) t u -> assumption_context Δ -> - red1_ctx (Γ ,,, Δ) (Γ ,,, Δ') -> + red1_ctx Σ (Γ ,,, Δ) (Γ ,,, Δ') -> red Σ (Γ ,,, Δ') t u. Proof. intros redt assΔ redΔ. induction redt. @@ -2612,7 +2983,7 @@ Section RedConfluence. Lemma clos_refl_trans_ctx_to_1n (x y : context) : - clos_refl_trans_ctx red1_ctx x y <~> clos_refl_trans_ctx_1n red1_ctx x y. + clos_refl_trans_ctx (red1_ctx Σ) x y <~> clos_refl_trans_ctx_1n (red1_ctx Σ) x y. Proof. split. induction 1. econstructor 2. eauto. constructor; auto. @@ -2770,5 +3141,40 @@ End ConfluenceFacts. Arguments red_confluence {cf} {Σ} wfΣ {Γ t u v}. -(** We can now derive transitivity of the conversion relation, - see [PCUICConversion.v] *) +(** We can now derive transitivity of the conversion relation *) + +Instance conv_trans {cf:checker_flags} (Σ : global_env_ext) {Γ} : + wf Σ -> Transitive (conv Σ Γ). +Proof. + intros wfΣ t u v X0 X1. + eapply conv_alt_red in X0 as [t' [u' [[tt' uu'] eq]]]. + eapply conv_alt_red in X1 as [u'' [v' [[uu'' vv'] eq']]]. + eapply conv_alt_red. + destruct (red_confluence wfΣ uu' uu'') as [u'nf [ul ur]]. + eapply red_eq_term_upto_univ_r in ul as [tnf [redtnf ?]]; tea; try tc. + eapply red_eq_term_upto_univ_l in ur as [unf [redunf ?]]; tea; try tc. + exists tnf, unf. + intuition auto. + - now transitivity t'. + - now transitivity v'. + - now transitivity u'nf. +Qed. + +Instance cumul_trans {cf:checker_flags} (Σ : global_env_ext) Γ : + wf Σ -> Transitive (cumul Σ Γ). +Proof. + intros wfΣ t u v X X0. + eapply cumul_alt in X as [v' [v'' [[redl redr] eq]]]. + eapply cumul_alt in X0 as [w [w' [[redl' redr'] eq']]]. + destruct (red_confluence wfΣ redr redl') as [nf [nfl nfr]]. + eapply cumul_alt. + eapply red_eq_term_upto_univ_r in eq. all:tc;eauto with pcuic. + destruct eq as [v'0 [red'0 eq2]]. + eapply red_eq_term_upto_univ_l in eq';tc;eauto with pcuic. + destruct eq' as [v'1 [red'1 eq1]]. + exists v'0, v'1. + split. 1: split. + - transitivity v' ; auto. + - transitivity w' ; auto. + - eapply leq_term_trans with nf; eauto. +Qed. diff --git a/pcuic/theories/PCUICContextConversion.v b/pcuic/theories/PCUICContextConversion.v index c226a00bd..0ee238985 100644 --- a/pcuic/theories/PCUICContextConversion.v +++ b/pcuic/theories/PCUICContextConversion.v @@ -1,10 +1,11 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst - PCUICLiftSubst PCUICTyping PCUICWeakening +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils + PCUICLiftSubst PCUICTyping PCUICWeakening PCUICCases PCUICCumulativity PCUICReduction PCUICParallelReduction PCUICEquality PCUICUnivSubstitution - PCUICParallelReductionConfluence PCUICConfluence. + PCUICParallelReductionConfluence PCUICConfluence + PCUICContextReduction. From MetaCoq.PCUIC Require Export PCUICContextRelation. @@ -61,28 +62,46 @@ Section ContextReduction. eapply H; auto. Qed. - Lemma All2_local_env_over_red_refl {Γ Δ} : - All2_local_env (on_decl (fun (Δ _ : context) (t u : term) => red Σ (Γ ,,, Δ) t u)) Δ Δ. - Proof. induction Δ as [|[na [b|] ty]]; econstructor; try red; auto. Qed. + Lemma All2_fold_over_red_refl {Γ Δ} : + All2_fold (on_decls (fun (Δ _ : context) (t u : term) => red Σ (Γ ,,, Δ) t u)) Δ Δ. + Proof. induction Δ as [|[na [b|] ty]]; econstructor; try red; auto. + constructor; reflexivity. constructor; reflexivity. + Qed. - Lemma All2_local_env_red_refl {Δ} : - All2_local_env (on_decl (fun (Δ _ : context) (t u : term) => red Σ Δ t u)) Δ Δ. - Proof. induction Δ as [|[na [b|] ty]]; econstructor; try red; auto. Qed. + Lemma All2_fold_red_refl {Δ} : + All2_fold (on_decls (fun (Δ _ : context) (t u : term) => red Σ Δ t u)) Δ Δ. + Proof. + induction Δ as [|[na [b|] ty]]; econstructor; try red; auto; + constructor; reflexivity. + Qed. Derive Signature for assumption_context. - Lemma red1_red_ctxP_ass {Γ Γ' Δ} : assumption_context Δ -> + Lemma red1_red_ctxP_app {Γ Γ' Δ} : red1_red_ctxP Γ Γ' -> red1_red_ctxP (Γ ,,, Δ) (Γ' ,,, Δ). Proof. induction Δ as [|[na [b|] ty] Δ]; intros; auto. - - elimtype False. depelim H. - - case; move => n b b' //. eapply IHΔ. now depelim H. apply X. + - case. + * move=> bod bod' => /= [=] -> [=] ->. rewrite !skipn_S !skipn_0. exists bod'. + split; reflexivity. + * move=> /= n bod b' hn hn' r. + specialize (IHΔ X n bod b' hn hn' r) as [t [redl redr]]. + exists t. rewrite !skipn_S in r |- *. split; auto. + - case; move => n b b' //. eapply IHΔ. apply X. Qed. Ltac t := split; [eapply red1_red; try econstructor; eauto|try constructor]; eauto with pcuic. Ltac u := intuition eauto with pcuic. + Lemma red_ctx_app Γ Γ' Δ : + red_ctx Σ Γ Γ' -> red_ctx Σ (Γ ,,, Δ) (Γ' ,,, Δ). + Proof. + intros h; eapply All2_fold_app => //. + eapply All2_fold_refl. reflexivity. + Qed. + Hint Resolve red_ctx_app : pcuic. + Lemma red1_red_ctx_aux {Γ Γ' T U} : red1 Σ Γ T U -> @red_ctx Σ Γ Γ' -> @@ -97,14 +116,13 @@ Section ContextReduction. eapply nth_error_pred1_ctx_l in H as [body' [? ?]]; eauto. rewrite -(firstn_skipn (S i) Γ'). assert (i < #|Γ'|). destruct (nth_error Γ' i) eqn:Heq; noconf e. eapply nth_error_Some_length in Heq. lia. - move: (All2_local_env_length H0) => Hlen. - specialize (X _ _ _ H1 e). forward X. eapply All2_local_env_app. + move: (All2_fold_length H0) => Hlen. + specialize (X _ _ _ H1 e). forward X. eapply All2_fold_app_inv. instantiate (1 := firstn (S i) Γ'). instantiate (1 := firstn (S i) Γ). + rewrite !firstn_length. lia. rewrite [_ ,,, _](firstn_skipn (S i) _). now rewrite [_ ,,, _](firstn_skipn (S i) _). - rewrite !skipn_length; try lia. - destruct X as [x' [bt b't]]. exists (lift0 (S i) x'). split; eauto with pcuic. etransitivity. eapply red1_red. constructor. @@ -114,31 +132,72 @@ Section ContextReduction. - exists (tLambda na x N). split; apply red_abs; auto. - - destruct (IHr (Γ' ,, vass na N)). constructor; pcuic. + - destruct (IHr (Γ' ,, vass na N)). constructor; pcuic. constructor; pcuic. case => n b b' /= //. apply X. exists (tLambda na N x). split; apply red_abs; u. - exists (tLetIn na x t b'). split; eapply red_letin; auto. - specialize (IHr (Γ' ,, vdef na b t)). - forward IHr. constructor; eauto. red. eauto. + forward IHr. constructor; eauto. constructor; auto. destruct IHr as [? [? ?]]. case. move=> b0 b1 [] <- [] <- H'. exists b; auto. apply X. exists (tLetIn na b t x). split; eapply red_letin; auto. - - exists (tCase ind x c brs). u; now apply red_case_p. + - eapply (OnOne2_exist _ (red Σ Γ')) in X as [pars' [ol or]]. + exists (tCase ci (set_pparams p pars') c brs). u. + apply red_case_pars. eapply OnOne2_All2; tea => /= //. + change (set_pparams p pars') with (set_pparams (set_pparams p params') pars'). + apply red_case_pars => /=. eapply OnOne2_All2; tea => /= //. + intros; u. + - eapply (OnOne2_local_env_exist' _ (fun Δ => red Σ (Γ' ,,, Δ)) (fun Δ => red Σ (Γ' ,,, Δ))) in X as [pars' [ol or]]. + exists (tCase ci (set_pcontext p pars') c brs). u. + apply red_case_pcontext => //. + change (set_pcontext p pars') with (set_pcontext (set_pcontext p pcontext') pars'). + apply red_case_pcontext => /= //. + move=> /= Δ x y IH. apply (IH (Γ' ,,, Δ)). + { eapply All2_fold_app => //. eapply All2_fold_refl; reflexivity. } + { now apply red1_red_ctxP_app. } + - destruct (IHr (Γ' ,,, pcontext p)). + now eapply red_ctx_app => //. + now eapply red1_red_ctxP_app. + destruct p0. + eexists. split. eapply red_case_p; tea. + change (set_preturn p x) with (set_preturn (set_preturn p preturn') x). + eapply red_case_p; tea. - exists (tCase ind p x brs). u; now apply red_case_c. - - eapply (OnOne2_exist _ (on_Trel_eq (red Σ Γ') snd fst)) in X. - destruct X as [brs'' [? ?]]. - eexists. split; eapply red_case_one_brs; eauto. - intros. intuition eauto. - destruct (b1 _ H X0) as [? [? ?]]. - eexists (x.1, x0); intuition eauto. + - eapply OnOne2_disj in X. destruct X as [X|X]. + * eapply (OnOne2_exist _ + (fun br br' => on_Trel_eq (red Σ (Γ' ,,, bcontext br)) bbody bcontext br br')) in X. + destruct X as [brs'' [? ?]]. + eexists. split; eapply red_case_one_brs; eauto; + solve_all. + intros. intuition eauto. + specialize (b0 (Γ' ,,, bcontext x)) as [body' [rl rr]]. + + now eapply red_ctx_app => //. + + now eapply red1_red_ctxP_app. + + exists {| bcontext := bcontext x; bbody := body' |}; cbn; split; rewrite -?b; + intuition eauto. + * eapply (OnOne2_exist _ + (fun br br' => on_Trel_eq (red_ctx_rel Σ Γ') bcontext bbody br br')) in X. + destruct X as [brsr [redl redr]]. + exists (tCase ci p c brsr). split. + eapply red_case_one_brs. eapply OnOne2_disj. right => //. + eapply red_case_one_brs. eapply OnOne2_disj. right => //. + u. + eapply (OnOne2_local_env_exist' _ (fun Δ => red Σ (Γ' ,,, Δ)) (fun Δ => red Σ (Γ' ,,, Δ))) in a as [pars' [ol or]]. + exists {| bcontext := pars' ; bbody := bbody x |}; rewrite -b /=; intuition eauto. + eapply red_one_decl_red_ctx_rel => //. + eapply red_one_decl_red_ctx_rel => //. + intros. specialize (X1 (Γ' ,,, Γ0)). + apply X1. + now eapply red_ctx_app. + now eapply red1_red_ctxP_app. - exists (tProj p x). u; now eapply red_proj_c. - exists (tApp x M2). u; now eapply red_app. - exists (tApp M1 x). u; now eapply red_app. - exists (tProd na x M2). u; now eapply red_prod. - specialize (IHr (Γ' ,, vass na M1)) as [? [? ?]]. - constructor; pcuic. case => //. + constructor; pcuic. constructor; auto. case => //. exists (tProd na M1 x). u; now eapply red_prod. - eapply (OnOne2_exist _ (red Σ Γ')) in X. destruct X as [rl [l0 l1]]. @@ -167,8 +226,8 @@ Section ContextReduction. intros. intuition auto. specialize (b0 (Γ' ,,, fix_context mfix0)). forward b0. - eapply All2_local_env_app_inv. apply H. apply All2_local_env_over_red_refl. - forward b0. eapply red1_red_ctxP_ass. apply fix_context_assumption_context. auto. + eapply All2_fold_app => //. apply All2_fold_over_red_refl. + forward b0. now eapply red1_red_ctxP_app. destruct b0 as [t [? ?]]. refine (existT _ {| dbody := t |} _); simpl; eauto. - eapply (OnOne2_exist _ (on_Trel_eq (red Σ Γ') dtype (fun x => (dname x, dbody x, rarg x)))) in X. @@ -191,8 +250,8 @@ Section ContextReduction. intros. intuition auto. specialize (b0 (Γ' ,,, fix_context mfix0)). forward b0. - eapply All2_local_env_app_inv. apply H. apply All2_local_env_over_red_refl. - forward b0. eapply red1_red_ctxP_ass. apply fix_context_assumption_context. auto. + eapply All2_fold_app => //. apply All2_fold_over_red_refl. + forward b0. eapply red1_red_ctxP_app => //. destruct b0 as [t [? ?]]. refine (existT _ {| dbody := t |} _); simpl; eauto. Qed. @@ -220,12 +279,12 @@ Section ContextReduction. induction Γ in Γ', X |- *. - depelim X. intros n t t'. rewrite nth_error_nil //. - - depelim X; red in o. + - depelim X. + depelim a0. + specialize (IHΓ _ X). case => n b b' /= //. simpl. apply IHΓ. + specialize (IHΓ _ X). - destruct o. case. * move=> b0 b1 [] <- [] <- H. rewrite skipn_S /skipn /= in H. @@ -248,28 +307,8 @@ Section ContextConversion. Context (Σ : global_env_ext). Context {wfΣ : wf Σ}. - Notation conv_context Γ Γ' := (context_relation (conv_decls Σ) Γ Γ'). - Notation cumul_context Γ Γ' := (context_relation (cumul_decls Σ) Γ Γ'). - - Global Instance conv_ctx_refl : Reflexive (context_relation (conv_decls Σ)). - Proof. - intro Γ; induction Γ; try econstructor. - destruct a as [na [b|] ty]; econstructor; eauto; - constructor; pcuic. - Qed. - - Global Instance cumul_ctx_refl : Reflexive (context_relation (cumul_decls Σ)). - Proof. - intro Γ; induction Γ; try econstructor. - destruct a as [na [b|] ty]; econstructor; eauto; - constructor; pcuic; eapply cumul_refl'. - Qed. - - Definition conv_ctx_refl' Γ : conv_context Γ Γ - := conv_ctx_refl Γ. - - Definition cumul_ctx_refl' Γ : cumul_context Γ Γ - := cumul_ctx_refl Γ. + Notation conv_context := (All2_fold (conv_decls Σ)). + Notation cumul_context := (All2_fold (cumul_decls Σ)). Hint Resolve conv_ctx_refl' cumul_ctx_refl' : pcuic. @@ -278,11 +317,10 @@ Section ContextConversion. ∑ t'' u'', red Σ Γ t' t'' * red Σ Γ u' u'' * leq_term Σ Σ t'' u''. Proof. intros tu tt' uu'. - pose proof tu as tu2. - eapply red_eq_term_upto_univ_l in tu; try exact tt'; tc. + eapply red_eq_term_upto_univ_l in tu; try exact tt'. all:try tc. destruct tu as [u'' [uu'' t'u'']]. destruct (red_confluence wfΣ uu' uu'') as [unf [ul ur]]. - eapply red_eq_term_upto_univ_r in t'u''; try exact ur; tc. + eapply red_eq_term_upto_univ_r in t'u''; try exact ur; try tc. destruct t'u'' as [t'' [t't'' t''unf]]. exists t'', unf. intuition auto. Qed. @@ -293,13 +331,33 @@ Section ContextConversion. Proof. intros tu tt' uu'. pose proof tu as tu2. - eapply red_eq_term_upto_univ_l in tu; try exact tt'; tc. + eapply red_eq_term_upto_univ_l in tu; try exact tt'; try tc. destruct tu as [u'' [uu'' t'u'']]. destruct (red_confluence wfΣ uu' uu'') as [unf [ul ur]]. - eapply red_eq_term_upto_univ_r in t'u''; try exact ur; tc. + eapply red_eq_term_upto_univ_r in t'u''; try exact ur; try tc. destruct t'u'' as [t'' [t't'' t''unf]]. exists t'', unf. intuition auto. Qed. + + Lemma red_ctx_conv_context Γ Γ' : + red_ctx Σ Γ Γ' -> + conv_context Γ Γ'. + Proof. + intros r. + induction r; constructor; auto. + depelim p; constructor; auto. + all: apply red_conv; auto. + Qed. + + Lemma red_ctx_cumul_context Γ Γ' : + red_ctx Σ Γ Γ' -> + cumul_context Γ Γ'. + Proof. + intros r. + induction r; constructor; auto. + depelim p; constructor; auto. + all: try apply red_cumul; try apply red_conv; auto. + Qed. Lemma cumul_red_ctx Γ Γ' T U : Σ ;;; Γ |- T <= U -> @@ -310,7 +368,7 @@ Section ContextConversion. apply cumul_alt in H as [v [v' [[redl redr] leq]]]. destruct (red_red_ctx Σ wfΣ redl Hctx) as [lnf [redl0 redr0]]. apply cumul_alt. - eapply red_eq_term_upto_univ_l in leq; tea; tc. + eapply red_eq_term_upto_univ_l in leq; tea; try tc. destruct leq as [? [? ?]]. destruct (red_red_ctx _ wfΣ redr Hctx) as [rnf [redl1 redr1]]. destruct (red_confluence wfΣ r redr1). destruct p. @@ -319,6 +377,14 @@ Section ContextConversion. now transitivity rnf. Qed. + Lemma red_red_ctx_inv {Γ Δ : context} {t u : term} : + red Σ Γ t u -> red_ctx Σ Δ Γ -> red Σ Δ t u. + Proof. + intros r rc. + eapply red_ctx_red_context in rc. + eapply PCUICContextReduction.red_red_ctx; tea. + Qed. + Lemma cumul_red_ctx_inv Γ Γ' T U : Σ ;;; Γ |- T <= U -> @red_ctx Σ Γ' Γ -> @@ -326,12 +392,13 @@ Section ContextConversion. Proof. intros H Hctx. apply cumul_alt in H as [v [v' [[redl redr] leq]]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ redl Hctx). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ redr Hctx). + epose proof (red_red_ctx_inv redl Hctx). + epose proof (red_red_ctx_inv redr Hctx). apply cumul_alt. exists v, v'. split. pcuic. auto. Qed. + (* Lemma conv_red_ctx {Γ Γ' T U} : Σ ;;; Γ |- T = U -> @@ -369,7 +436,7 @@ Section ContextConversion. - exists x. split; auto. reflexivity. - destruct IHr1 as [v' [? ?]]. destruct IHr2 as [v'' [? ?]]. - unshelve eapply (red_eq_term_upto_univ_l Σ _ (u:=y) (v:=v'') (u':=v')) in e; tc. all:pcuic. + eapply (red_eq_term_upto_univ_l Σ _ (u:=y) (v:=v'') (u':=v')) in e; try tc. all:pcuic. destruct e as [? [? ?]]. exists x0; split; eauto. now transitivity v'. @@ -412,9 +479,9 @@ Section ContextConversion. eapply cumul_alt in X as [t0 [u0 [[redl redr] eq]]]. eapply cumul_alt in X0 as [u1 [v0 [[redl' redr'] eq']]]. destruct (red_confluence wfΣ redr redl') as [unf [nfl nfr]]. - eapply red_eq_term_upto_univ_r in eq; tc;eauto with pcuic. + eapply red_eq_term_upto_univ_r in eq; try tc;eauto with pcuic. destruct eq as [t1 [red'0 eq2]]. - eapply red_eq_term_upto_univ_l in eq'; tc;eauto with pcuic. + eapply red_eq_term_upto_univ_l in eq'; try tc;eauto with pcuic. destruct eq' as [v1 [red'1 eq1]]. exists t1, unf, v1. repeat split. @@ -521,10 +588,11 @@ Section ContextConversion. eq_context_upto Σ Re' Rle' Γ Δ. Proof. induction 1; constructor; auto. - eapply eq_term_upto_univ_impl. 5:eauto. all:(tc || auto). - transitivity Re'; auto. - eapply eq_term_upto_univ_impl. 5:eauto. all:(tc || auto). - eapply eq_term_upto_univ_impl. 5:eauto. all:(tc || auto). + eapply compare_decls_impl; eauto. + intros x y h. + eapply eq_term_upto_univ_impl. 5:eauto. all:try tc || auto. + intros x y h. + eapply eq_term_upto_univ_impl. 5:eauto. all:try tc || auto. transitivity Re'; auto. Qed. @@ -568,8 +636,8 @@ Section ContextConversion. Proof. intros H Hctx. apply conv_alt_red in H as [v [v' [[redl redr] leq]]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ redl Hctx). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ redr Hctx). + pose proof (red_red_ctx_inv redl Hctx). + pose proof (red_red_ctx_inv redr Hctx). apply conv_alt_red. exists v, v'. split. pcuic. auto. @@ -600,8 +668,8 @@ Section ContextConversion. Proof. intros H Hctx. apply cumul_alt in H as [v [v' [[redl redr] leq]]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ redl Hctx). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ redr Hctx). + pose proof (red_red_ctx_inv redl Hctx). + pose proof (red_red_ctx_inv redr Hctx). apply cumul_alt. exists v, v'. split. pcuic. auto. @@ -613,46 +681,45 @@ Section ContextConversion. Proof. intros Hctx. induction Hctx. - - exists [], []; intuition pcuic. constructor. - - destruct IHHctx as [Δ [Δ' [[? ?] ?]]]. - depelim p. - pose proof (cumul_alt_red_ctx c r). - eapply cumul_alt in X. - destruct X as [T' [U' [[? ?] ?]]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r1 r). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r2 r). - destruct (red_eq_context_upto_l r1 e0). destruct p. - destruct (red_eq_context_upto_l r2 e0). destruct p. - exists (Δ ,, vass na' T'), (Δ' ,, vass na' x0). - split; [split|]; constructor; auto. - + red. - eapply PCUICConfluence.red_red_ctx; eauto. - + eapply eq_term_upto_univ_trans with U'; eauto; tc. - now apply eq_term_leq_term. + - exists [], []; intuition pcuic. - destruct IHHctx as [Δ [Δ' [[? ?] ?]]]. depelim p. - pose proof (conv_alt_red_ctx c r). - eapply conv_alt_red in X. - destruct X as [t' [u' [[? ?] ?]]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r1 r). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r2 r). - destruct (red_eq_context_upto_l r1 e0) as [t'' [? ?]]. - destruct (red_eq_context_upto_l r2 e0) as [u'' [? ?]]. - pose proof (cumul_alt_red_ctx c0 r) as hTU. - eapply cumul_alt in hTU. - destruct hTU as [T' [U' [[rT rU] eTU']]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ rT r). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ rU r). - destruct (red_eq_context_upto_l rT e0) as [T'' [? ?]]. - destruct (red_eq_context_upto_l rU e0) as [U'' [? ?]]. - exists (Δ ,, vdef na' t' T'), (Δ' ,, vdef na' u'' U''). - split; [split|]. all: constructor ; auto. - * red. split; auto. - * red. split. - -- eapply PCUICConfluence.red_red_ctx; eauto. - -- eapply PCUICConfluence.red_red_ctx; eauto. - * eapply eq_term_upto_univ_trans with u'; eauto; tc. - * transitivity U'; eauto. now apply eq_term_leq_term. + { pose proof (cumul_alt_red_ctx c r). + eapply cumul_alt in X. + destruct X as [T'' [U' [[? ?] ?]]]. + pose proof (red_red_ctx_inv r1 r). + pose proof (red_red_ctx_inv r2 r). + destruct (red_eq_context_upto_l r1 a). destruct p. + destruct (red_eq_context_upto_l r2 a). destruct p. + exists (Δ ,, vass na T''), (Δ' ,, vass na' x0). + split; [split|]; constructor; try constructor; auto. + + eapply red_red_ctx_inv; eauto. + + eapply eq_term_upto_univ_trans with U'; eauto; try tc. + now apply eq_term_leq_term. } + { pose proof (conv_alt_red_ctx c r). + eapply conv_alt_red in X. + destruct X as [t' [u' [[? ?] ?]]]. + pose proof (red_red_ctx_inv r1 r). + pose proof (red_red_ctx_inv r2 r). + destruct (red_eq_context_upto_l r1 a) as [t'' [? ?]]. + destruct (red_eq_context_upto_l r2 a) as [u'' [? ?]]. + pose proof (cumul_alt_red_ctx c0 r) as hTU. + eapply cumul_alt in hTU. + destruct hTU as [T'' [U' [[rT rU] eTU']]]. + pose proof (red_red_ctx_inv rT r). + pose proof (red_red_ctx_inv rU r). + destruct (red_eq_context_upto_l rT a) as [T''' [? ?]]. + destruct (red_eq_context_upto_l rU a) as [U''' [? ?]]. + exists (Δ ,, vdef na t' T''), (Δ' ,, vdef na' u'' U'''). + split; [split|]. all: constructor ; auto. + * constructor; auto. + * constructor. + -- eapply red_red_ctx_inv; eauto. + -- eapply red_red_ctx_inv; eauto. + * constructor; auto. + eapply eq_term_upto_univ_trans with u'; eauto; tc. + eapply eq_term_upto_univ_trans with U'; eauto; try tc. + now eapply eq_term_leq_term. } Qed. Lemma conv_context_red_context Γ Γ' : @@ -661,45 +728,43 @@ Section ContextConversion. Proof. intros Hctx. induction Hctx. - - exists [], []; intuition pcuic. constructor. - - destruct IHHctx as [Δ [Δ' [[? ?] ?]]]. - depelim p. - pose proof (conv_alt_red_ctx c r). - eapply conv_alt_red in X. - destruct X as [T' [U' [[? ?] ?]]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r1 r). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r2 r). - destruct (red_eq_context_upto_l r1 e0). destruct p. - destruct (red_eq_context_upto_l r2 e0). destruct p. - exists (Δ ,, vass na' T'), (Δ' ,, vass na' x0). - split; [split|]; constructor; auto. - + red. - eapply PCUICConfluence.red_red_ctx; eauto. - + eapply eq_term_upto_univ_trans with U'; eauto; tc. + - exists [], []; intuition pcuic. - destruct IHHctx as [Δ [Δ' [[? ?] ?]]]. depelim p. - pose proof (conv_alt_red_ctx c r). - eapply conv_alt_red in X. - destruct X as [t' [u' [[? ?] ?]]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r1 r). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ r2 r). - destruct (red_eq_context_upto_l r1 e0) as [t'' [? ?]]. - destruct (red_eq_context_upto_l r2 e0) as [u'' [? ?]]. - pose proof (conv_alt_red_ctx c0 r) as hTU. - eapply conv_alt_red in hTU. - destruct hTU as [T' [U' [[rT rU] eTU']]]. - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ rT r). - pose proof (PCUICConfluence.red_red_ctx wfΣ _ _ _ _ rU r). - destruct (red_eq_context_upto_l rT e0) as [T'' [? ?]]. - destruct (red_eq_context_upto_l rU e0) as [U'' [? ?]]. - exists (Δ ,, vdef na' t' T'), (Δ' ,, vdef na' u'' U''). - split; [split|]. all: constructor ; auto. - * red. split; auto. - * red. split. - -- eapply PCUICConfluence.red_red_ctx; eauto. - -- eapply PCUICConfluence.red_red_ctx; eauto. - * eapply eq_term_upto_univ_trans with u'; eauto; tc. - * transitivity U'; eauto. + { pose proof (conv_alt_red_ctx c r). + eapply conv_alt_red in X. + destruct X as [T'' [U' [[? ?] ?]]]. + pose proof (red_red_ctx_inv r1 r). + pose proof (red_red_ctx_inv r2 r). + destruct (red_eq_context_upto_l r1 a). destruct p. + destruct (red_eq_context_upto_l r2 a). destruct p. + exists (Δ ,, vass na T''), (Δ' ,, vass na' x0). + split; [split|]; constructor; try constructor; auto. + + eapply red_red_ctx_inv; eauto. + + eapply eq_term_upto_univ_trans with U'; eauto; tc. } + { pose proof (conv_alt_red_ctx c r). + eapply conv_alt_red in X. + destruct X as [t' [u' [[? ?] ?]]]. + pose proof (red_red_ctx_inv r1 r). + pose proof (red_red_ctx_inv r2 r). + destruct (red_eq_context_upto_l r1 a) as [t'' [? ?]]. + destruct (red_eq_context_upto_l r2 a) as [u'' [? ?]]. + pose proof (conv_alt_red_ctx c0 r) as hTU. + eapply conv_alt_red in hTU. + destruct hTU as [T'' [U' [[rT rU] eTU']]]. + pose proof (red_red_ctx_inv rT r). + pose proof (red_red_ctx_inv rU r). + destruct (red_eq_context_upto_l rT a) as [T''' [? ?]]. + destruct (red_eq_context_upto_l rU a) as [U'' [? ?]]. + exists (Δ ,, vdef na t' T''), (Δ' ,, vdef na' u'' U''). + split; [split|]. all: constructor ; auto. + * constructor; auto. + * constructor. + -- eapply red_red_ctx_inv; eauto. + -- eapply red_red_ctx_inv; eauto. + * constructor; auto. + transitivity u'; eauto; tc. + transitivity U'; eauto. } Qed. Lemma conv_cumul_ctx Γ Γ' T U : @@ -749,6 +814,24 @@ Section ContextConversion. Qed. Hint Resolve conv_cumul_context : pcuic. + #[global] + Instance conv_decls_sym Γ Γ' : Symmetric (conv_decls Σ Γ Γ'). + Proof. + intros x y []; constructor; now symmetry. + Qed. + + #[global] + Instance conv_decls_trans Γ Γ' : Transitive (conv_decls Σ Γ Γ'). + Proof. + intros x y z [] h; depelim h; constructor; etransitivity; eauto. + Qed. + + #[global] + Instance cumul_decls_trans Γ Γ' : Transitive (cumul_decls Σ Γ Γ'). + Proof. + intros x y z [] h; depelim h; constructor; etransitivity; eauto. + Qed. + #[global] Instance conv_context_sym : Symmetric (fun Γ Γ' => conv_context Γ Γ'). Proof. @@ -759,9 +842,9 @@ Section ContextConversion. depelim X; constructor; pcuic. - depelim c. constructor. now symmetry. eapply conv_sym. eapply conv_conv_ctx; eauto. - - depelim c; constructor; auto. now symmetry. - eapply conv_sym, conv_conv_ctx; eauto. + constructor. now symmetry. eapply conv_sym, conv_conv_ctx; eauto. + eapply conv_sym, conv_conv_ctx; eauto. Qed. Lemma cumul_cumul_ctx Γ Γ' T U : @@ -777,7 +860,8 @@ Section ContextConversion. eapply cumul_leq_context_upto; eauto. Qed. - (** Again, this is only the case because conversion is untyped *) + (** Again, this is only the case because conversion is untyped. We require + nothing on Γ or Γ'. *) Local Remark cumul_cumul_ctx_inv Γ Γ' T U : Σ ;;; Γ |- T <= U -> cumul_context Γ Γ' -> @@ -790,12 +874,49 @@ Section ContextConversion. eapply cumul_red_ctx in l; eauto. eapply cumul_leq_context_upto_inv; eauto. Qed. + + #[global] + Instance conv_context_trans : Transitive (fun Γ Γ' => conv_context Γ Γ'). + Proof. + eapply All2_fold_trans. + intros. + depelim X2; depelim X3; try constructor; auto. + * etransitivity; eauto. + * etransitivity. + + eapply conv_trans; eauto. + + eapply conv_conv_ctx => //. + - apply c0. + - apply conv_context_sym => //. + * etransitivity; eauto. + * eapply conv_trans; eauto. + eapply conv_conv_ctx => //. + + apply c1. + + apply conv_context_sym => //. + * etransitivity; eauto. + apply conv_context_sym in X; auto. + eapply conv_conv_ctx; eauto. + Qed. + + #[global] + Instance cumul_context_trans : Transitive cumul_context. + Proof. + eapply All2_fold_trans. + intros. + depelim X2; depelim X3; try constructor; auto. + * etransitivity; eauto. + * etransitivity; eauto. + eapply cumul_cumul_ctx; eauto. + * etransitivity; eauto. + * eapply conv_trans; eauto. + eapply conv_cumul_ctx => //. + + apply c1. + + assumption. + * etransitivity; eauto. + eapply cumul_cumul_ctx; eauto. + Qed. End ContextConversion. -Notation conv_context Σ Γ Γ' := (context_relation (conv_decls Σ) Γ Γ'). -Notation cumul_context Σ Γ Γ' := (context_relation (cumul_decls Σ) Γ Γ'). - Hint Resolve conv_ctx_refl' cumul_ctx_refl' : pcuic. Hint Constructors conv_decls cumul_decls : pcuic. @@ -806,13 +927,8 @@ Proof. intros HRe Γ Δ h. induction h. - constructor. - constructor; tas. - constructor; tas. eapply conv_refl. - eapply eq_term_upto_univ_impl; tea. auto. - - constructor; tas. - constructor; tas. eapply conv_refl. - eapply eq_term_upto_univ_impl; tea. auto. - eapply conv_refl. - eapply eq_term_upto_univ_impl => //; tea. + depelim p; constructor; auto; constructor; tas; + eapply eq_term_upto_univ_impl; tea; auto. Qed. Lemma eq_context_upto_cumul_context {cf:checker_flags} (Σ : global_env_ext) Re Rle : @@ -824,14 +940,12 @@ Proof. intros HRe HRle hR Γ Δ h. induction h. - constructor. - constructor; tas. - constructor; tas. eapply cumul_refl. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. now transitivity Rle. auto. - - constructor; tas. - constructor; tas. eapply conv_refl. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. auto. - eapply cumul_refl. - eapply eq_term_upto_univ_impl => //; tea. - now transitivity Rle. + depelim p; constructor; auto; constructor; tas. + 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. + now transitivity Rle. auto. Qed. Instance eq_subrel_eq_univ {cf:checker_flags} Σ : RelationClasses.subrelation eq (eq_universe Σ). @@ -843,13 +957,8 @@ Proof. intros Γ Δ h. induction h. - constructor. - constructor; tas. - constructor; tas. eapply conv_refl. - eapply eq_term_upto_univ_empty_impl; tea; try typeclasses eauto. - - constructor; tas. - constructor; tas. eapply conv_refl. - eapply eq_term_upto_univ_empty_impl; tea; try typeclasses eauto. - eapply conv_refl. - eapply eq_term_upto_univ_empty_impl; tea; try typeclasses eauto. + depelim p; constructor; auto; constructor. + all:eapply eq_term_upto_univ_empty_impl; tea; try typeclasses eauto. Qed. Lemma eq_context_upto_univ_conv_context {cf:checker_flags} {Σ : global_env_ext} Γ Δ : @@ -900,33 +1009,106 @@ Axiom cofix_guard_context_cumulativity : forall {cf:checker_flags} Σ Γ Γ' mfi cofix_guard Σ Γ mfix -> cofix_guard Σ Γ' mfix. +(* Definition on_decl (P : context -> term -> term -> Type) + (Γ : context) (t : term) (t' : option term) := + match t' with + | Some (b, b') => (P Γ b b' * P Γ Γ' t t')%type + | None => P Γ Γ' t t' + end. *) +Definition on_local_decl (P : context -> term -> option term -> Type) (Γ : context) (d : context_decl) := + match decl_body d with + | Some b => P Γ b (Some (decl_type d)) * P Γ (decl_type d) None + | None => P Γ (decl_type d) None + end. + +Lemma nth_error_All_local_env {P Γ n} (isdecl : n < #|Γ|) : + All_local_env P Γ -> + on_some (on_local_decl P (skipn (S n) Γ)) (nth_error Γ n). +Proof. + induction 1 in n, isdecl |- *. red; simpl. + - destruct n; simpl; inv isdecl. + - destruct n. red; simpl. red. simpl. apply t0. + simpl. apply IHX. simpl in isdecl. lia. + - destruct n; simpl in *. + * rewrite skipn_S skipn_0. red; cbn. + split; auto. + * rewrite !skipn_S. apply IHX. lia. +Qed. + +Lemma context_cumulativity_wf_app {cf:checker_flags} Σ Γ Γ' Δ : + cumul_context Σ Γ' Γ -> + wf_local Σ Γ' -> + All_local_env + (lift_typing + (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + forall Γ' : context, + cumul_context Σ Γ' Γ -> wf_local Σ Γ' -> Σ;;; Γ' |- t : T) Σ) + (Γ,,, Δ) -> + wf_local Σ (Γ' ,,, Δ). +Proof. + intros. + eapply wf_local_app => //. + eapply All_local_env_app_inv in X1 as []. + eapply All_local_env_impl_ind; tea => /=. + rewrite /lift_typing => Γ'' t' [t wf IH|wf [s IH]]; try exists s; eauto; red. + eapply IH. eapply All2_fold_app => //. + eapply All2_fold_refl. intros. eapply cumul_decls_refl. + eapply All_local_env_app; split; auto. + eapply IH. + eapply All2_fold_app => //. + eapply All2_fold_refl. intros. eapply cumul_decls_refl. + eapply All_local_env_app; split; auto. +Qed. + +Lemma context_cumulativity_app {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Δ Δ'} : + cumul_context Σ Γ' Γ -> + conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ') -> + conv_context Σ (Γ' ,,, Δ) (Γ' ,,, Δ'). +Proof. + intros cum conv. + pose proof (length_of conv). len in H. + eapply All2_fold_app; eauto. lia. + reflexivity. + eapply All2_fold_app_inv in conv as []. 2:lia. + eapply All2_fold_impl_ind; tea. + intros. simpl in X1. + depelim X1; constructor; auto. + eapply conv_cumul_ctx; tea. + now eapply cumul_context_app_same. + eapply conv_cumul_ctx; tea. + now eapply cumul_context_app_same. + eapply conv_cumul_ctx; tea. + now eapply cumul_context_app_same. +Qed. + Lemma context_cumulativity_prop {cf:checker_flags} : env_prop (fun Σ Γ t T => forall Γ', cumul_context Σ Γ' Γ -> wf_local Σ Γ' -> Σ ;;; Γ' |- t : T) - (fun Σ Γ wfΓ => - All_local_env_over typing - (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ) (t T : term) (_ : Σ;;; Γ |- t : T) => - forall Γ' : context, cumul_context Σ Γ' Γ -> wf_local Σ Γ' -> Σ;;; Γ' |- t : T) Σ Γ wfΓ). + (fun Σ Γ => + All_local_env + (lift_typing (fun Σ (Γ : context) (t T : term) => + forall Γ' : context, cumul_context Σ Γ' Γ -> wf_local Σ Γ' -> Σ;;; Γ' |- t : T) Σ) Γ). Proof. apply typing_ind_env; intros Σ wfΣ Γ wfΓ; intros **; rename_all_hyps; try solve [econstructor; eauto]. - - auto. + - induction X; constructor; auto. + destruct tu as [s Hs]. exists s; eauto. + destruct tu as [s Hs]. exists s; eauto. - pose proof heq_nth_error. - eapply (context_relation_nth_r X0) in H as [d' [Hnth [Hrel Hconv]]]. - unshelve eapply nth_error_All_local_env_over in X. 3:eapply heq_nth_error. - destruct X as [onctx ondecl]. - destruct lookup_wf_local_decl. red in ondecl. + eapply (All2_fold_nth_r X0) in H as [d' [Hnth [Hrel Hconv]]]. + unshelve eapply nth_error_All_local_env in X; tea. 2:eapply nth_error_Some_length in heq_nth_error; lia. + rewrite heq_nth_error /= in X. destruct decl as [na [b|] ty] => /=. - + specialize ondecl as [Hb Hty]. - simpl in Hty. specialize (Hty _ Hrel). + + red in X. cbn in X. destruct X as [Hb Hty]. + destruct Hty as [s Hty]. specialize (Hty _ Hrel). forward Hty by now eapply All_local_env_skipn. - eapply type_Cumul with _ o.2.π1. + eapply type_Cumul with _ s. * econstructor. auto. eauto. * rewrite -(firstn_skipn (S n) Γ'). - change (tSort o.2.π1) with (lift0 (S n) (tSort o.2.π1)). + change (tSort s) with (lift0 (S n) (tSort s)). eapply weakening_length. auto. rewrite firstn_length_le. eapply nth_error_Some_length in Hnth. lia. auto. now rewrite /app_context firstn_skipn. @@ -936,13 +1118,14 @@ Proof. eapply weakening_cumul0; auto. pose proof (nth_error_Some_length Hnth). rewrite firstn_length_le; lia. - + specialize (ondecl _ Hrel). + + cbn in X. destruct X as [s ondecl]. + specialize (ondecl _ Hrel). depelim Hconv. forward ondecl by now eapply All_local_env_skipn. - eapply type_Cumul with _ o.π1. + eapply type_Cumul with _ s. * econstructor. auto. eauto. * rewrite -(firstn_skipn (S n) Γ'). - change (tSort o.π1) with (lift0 (S n) (tSort o.π1)). + change (tSort s) with (lift0 (S n) (tSort s)). eapply weakening_length. auto. rewrite firstn_length_le. eapply nth_error_Some_length in Hnth. lia. auto. now rewrite /app_context firstn_skipn. @@ -958,9 +1141,27 @@ Proof. eapply forall_Γ'0; repeat (constructor; pcuic). - econstructor; pcuic. eapply forall_Γ'1; repeat (constructor; pcuic). - - econstructor; pcuic. intuition auto. eapply isdecl. eapply isdecl. - eauto. solve_all. - destruct b0 as [? [? ?]]; eauto. + - econstructor; eauto. + * eapply context_cumulativity_wf_app; tea. + * eapply context_cumulativity_app; tea. + * eapply IHp0. rewrite /predctx. + eapply All2_fold_app => //. eapply All2_fold_refl; reflexivity. + eapply context_cumulativity_wf_app; tea. + * eapply context_cumulativity_wf_app; tea. + * revert X6. + clear -Γ' X10 X11. induction 1; constructor; eauto. + * eapply All2i_impl; tea => i cdecl br. cbv beta. + set (brctxty := case_branch_type _ _ _ _ _ _ _ _). + cbn. intros [[hbctx convbctx] [[bbody Hbody] [IH [brctxty' IHbrctxty]]]]. + intuition eauto; solve_all. + eapply context_cumulativity_wf_app; tea. + eapply context_cumulativity_wf_app; tea. + eapply context_cumulativity_app; tea. + eapply IH. eapply All2_fold_app => //. eapply All2_fold_refl; reflexivity. + eauto using context_cumulativity_app, context_cumulativity_wf_app. + eapply IHbrctxty. + eapply All2_fold_app => //. eapply All2_fold_refl; reflexivity. + eapply context_cumulativity_wf_app; tea. - econstructor. eapply fix_guard_context_cumulativity; eauto. all:pcuic. eapply (All_impl X0). diff --git a/pcuic/theories/PCUICContextReduction.v b/pcuic/theories/PCUICContextReduction.v new file mode 100644 index 000000000..b7b1801c3 --- /dev/null +++ b/pcuic/theories/PCUICContextReduction.v @@ -0,0 +1,263 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import CRelationClasses. +From MetaCoq.Template Require Import config utils. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils + PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICInduction + PCUICContextRelation PCUICReduction PCUICCases PCUICWeakening + PCUICTyping. + +Require Import ssreflect. +Require Import Equations.Prop.DepElim. +From Equations.Type Require Import Relation Relation_Properties. +From Equations Require Import Equations. +Set Equations Transparent. +Set Default Goal Selector "!". + +Section CtxReduction. + Context {cf : checker_flags}. + Context {Σ : global_env}. + Context (wfΣ : wf Σ). + + Lemma red_abs_alt Γ na M M' N N' : red Σ Γ M M' -> red Σ (Γ ,, vass na M) N N' -> + red Σ Γ (tLambda na M N) (tLambda na M' N'). + Proof. + intros. eapply (transitivity (y := tLambda na M N')). + * now eapply (red_ctx_congr (tCtxLambda_r _ _ tCtxHole)). + * now eapply (red_ctx_congr (tCtxLambda_l _ tCtxHole _)). + Qed. + + Lemma red_letin_alt Γ na d0 d1 t0 t1 b0 b1 : + red Σ Γ d0 d1 -> red Σ Γ t0 t1 -> red Σ (Γ ,, vdef na d0 t0) b0 b1 -> + red Σ Γ (tLetIn na d0 t0 b0) (tLetIn na d1 t1 b1). + Proof. + intros; eapply (transitivity (y := tLetIn na d0 t0 b1)). + * now eapply (red_ctx_congr (tCtxLetIn_r _ _ _ tCtxHole)). + * eapply (transitivity (y := tLetIn na d0 t1 b1)). + + now eapply (red_ctx_congr (tCtxLetIn_b _ _ tCtxHole _)). + + now apply (red_ctx_congr (tCtxLetIn_l _ tCtxHole _ _)). + Qed. + + Lemma red_prod_alt Γ na M M' N N' : + red Σ Γ M M' -> red Σ (Γ ,, vass na M') N N' -> + red Σ Γ (tProd na M N) (tProd na M' N'). + Proof. + intros. eapply (transitivity (y := tProd na M' N)). + * now eapply (red_ctx_congr (tCtxProd_l _ tCtxHole _)). + * now eapply (red_ctx_congr (tCtxProd_r _ _ tCtxHole)). + Qed. + + Lemma red_decls_refl Γ Δ d : red_decls Σ Γ Δ d d. + Proof. + destruct d as [na [b|] ty]; constructor; auto. + Qed. + + Lemma red_context_refl Γ : red_context Σ Γ Γ. + Proof. + apply All2_fold_refl => ? ?. + apply red_decls_refl. + Qed. + + Lemma red_context_app_same {Γ Δ Γ'} : + red_context Σ Γ Δ -> + red_context Σ (Γ ,,, Γ') (Δ ,,, Γ'). + Proof. + intros r. + eapply All2_fold_app => //. + apply All2_fold_refl. + intros; apply red_decls_refl. + Qed. + + Lemma red1_red_ctx Γ Δ t u : + red1 Σ Γ t u -> + red_context Σ Δ Γ -> + red Σ Δ t u. + Proof. + move=> r Hctx. + revert Δ Hctx. + induction r using red1_ind_all; intros Δ Hctx; try solve [eapply red_step; repeat (constructor; eauto)]. + - red in Hctx. + destruct nth_error eqn:hnth => //; simpl in H; noconf H. + eapply All2_fold_nth_r in Hctx; eauto. + destruct Hctx as [x' [? ?]]. + destruct p as [cr rd]. destruct c => //; simpl in *. + depelim rd => //. noconf H. + eapply red_step. + * constructor. rewrite e => //. + * rewrite -(firstn_skipn (S i) Δ). + eapply weakening_red_0; auto. + rewrite firstn_length_le //. + eapply nth_error_Some_length in e. lia. + - repeat econstructor; eassumption. + - repeat econstructor; eassumption. + - repeat econstructor; eassumption. + - repeat econstructor; eassumption. + - eapply red_abs_alt; eauto. + - eapply red_abs_alt; eauto. apply (IHr (Δ ,, vass na N)). + constructor; auto. constructor; auto. + - eapply red_letin; eauto. + - eapply red_letin; eauto. + - eapply red_letin_alt; eauto. + eapply (IHr (Δ ,, vdef na b t)). constructor; eauto. + constructor; auto. + - eapply red_case_pars; eauto; pcuic. + eapply OnOne2_All2; tea => /=; intuition eauto. + - eapply red_case_pcontext; eauto. + eapply OnOne2_local_env_impl; tea. + intros Δ' x y. + eapply on_one_decl_impl => Γ' t t' IH. + apply IH. + now eapply red_context_app_same. + - eapply red_case_p. eapply IHr. + now apply red_context_app_same. + - eapply red_case_c; eauto. + - eapply red_case_brs. + unfold on_Trel; pcuic. + unfold on_Trel. + eapply OnOne2_All2; eauto. + * simpl. intuition eauto. + + apply b0. now apply red_context_app_same. + + rewrite -b. reflexivity. + + rewrite -b0. now reflexivity. + + eapply red_one_decl_red_ctx_rel. + eapply OnOne2_local_env_impl; tea. + intros Δ' x' y'. + eapply on_one_decl_impl => Γ' t t' IH. + apply IH. + now eapply red_context_app_same. + * intros x. split; pcuic. + - eapply red_proj_c; eauto. + - eapply red_app; eauto. + - eapply red_app; eauto. + - eapply red_prod_alt; eauto. + - eapply red_prod_alt; eauto. apply (IHr (Δ ,, vass na M1)); constructor; auto. + now constructor. + - eapply red_evar. + eapply OnOne2_All2; simpl; eauto. simpl. intuition eauto. + - eapply red_fix_one_ty. + eapply OnOne2_impl ; eauto. + intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. + inversion e. subst. clear e. + split ; auto. + - eapply red_fix_one_body. + eapply OnOne2_impl ; eauto. + intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. + inversion e. subst. clear e. + split ; auto. + eapply ih. + clear - Hctx. induction (fix_context mfix0). + + assumption. + + simpl. destruct a as [na [b|] ty]. + * constructor ; pcuicfo (constructor ; auto). + * constructor ; pcuicfo (constructor ; auto). + - eapply red_cofix_one_ty. + eapply OnOne2_impl ; eauto. + intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. + inversion e. subst. clear e. + split ; auto. + - eapply red_cofix_one_body. + eapply OnOne2_impl ; eauto. + intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. + inversion e. subst. clear e. + split ; auto. + eapply ih. + clear - Hctx. induction (fix_context mfix0). + + assumption. + + simpl. destruct a as [na [b|] ty]. + * constructor ; pcuicfo (constructor ; auto). + * constructor ; pcuicfo (constructor ; auto). + Qed. + + Lemma red_red_ctx Γ Δ t u : + red Σ Γ t u -> + red_context Σ Δ Γ -> + red Σ Δ t u. + Proof. + induction 1; eauto using red1_red_ctx. + intros H. + now transitivity y. + Qed. + + Lemma red_context_app {Γ Γ' Δ Δ'} : + red_context Σ Γ Δ -> + red_context_rel Σ Γ Γ' Δ' -> + red_context Σ (Γ ,,, Γ') (Δ ,,, Δ'). + Proof. + intros r r'. + eapply All2_fold_app => //. + * now rewrite (All2_fold_length r'). + * eapply All2_fold_impl; tea => /= Γ0 Γ'0 d d'. + intros h; depelim h; constructor; auto. + Qed. + + Lemma red_context_app_same_left {Γ Γ' Δ'} : + red_context_rel Σ Γ Γ' Δ' -> + red_context Σ (Γ ,,, Γ') (Γ ,,, Δ'). + Proof. + intros h. + eapply All2_fold_app => //. + * now rewrite (All2_fold_length h). + * apply red_context_refl. + Qed. + + Lemma red_context_app_right {Γ Γ' Δ Δ'} : + red_context Σ Γ Δ -> + red_context_rel Σ Δ Γ' Δ' -> + red_context Σ (Γ ,,, Γ') (Δ ,,, Δ'). + Proof. + intros r r'. + eapply All2_fold_app => //. + * now rewrite (All2_fold_length r'). + * eapply All2_fold_impl; tea => /= Γ0 Γ'0 d d'. + intros h; depelim h; constructor; auto; eapply red_red_ctx; tea; + now eapply red_context_app_same. + Qed. + + 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. + intros onc HPQ HQ. + induction onc; try constructor; auto. + - apply All2_fold_refl => //. + - apply All2_fold_refl => //. + Qed. + + Lemma red_ctx_rel_red_context_rel Γ : + CRelationClasses.relation_equivalence (red_ctx_rel Σ Γ) (red_context_rel Σ Γ). + Proof. + split. + - rewrite /red_ctx_rel /red_context_rel; induction 1. + * eapply OnOne2_local_env_All2_fold; tea => ? d d'. + 2:{ eapply red_decls_refl. } + destruct d as [na [b|] ty], d' as [na' [b'|] ty']; cbn; intuition auto; + subst; constructor; auto. + * eapply All2_fold_refl => Δ [na [b|] ty]; constructor; auto; constructor 2. + * eapply All2_fold_trans; eauto. + intros. + depelim X4; depelim X5; constructor; etransitivity; + eauto; eapply red_red_ctx; tea; eauto using red_context_app_same_left. + - induction 1; try solve [constructor]. + depelim p. + * transitivity (vass na T' :: Γ0). + { eapply red_one_decl_red_ctx_rel. + do 2 constructor; auto. } + clear -IHX. + induction IHX; try now do 2 constructor. + econstructor 3; tea. + * transitivity (vdef na b' T :: Γ0). + + eapply red_one_decl_red_ctx_rel. + do 2 constructor; auto. + + transitivity (vdef na b' T' :: Γ0). + ++ eapply red_one_decl_red_ctx_rel. + do 2 constructor; auto. + ++ clear -IHX. + induction IHX; try now do 2 constructor. + econstructor 3; tea. + Qed. + +End CtxReduction. + + + diff --git a/pcuic/theories/PCUICContextRelation.v b/pcuic/theories/PCUICContextRelation.v index 8b50b070b..6541d353e 100644 --- a/pcuic/theories/PCUICContextRelation.v +++ b/pcuic/theories/PCUICContextRelation.v @@ -1,6 +1,6 @@ From Equations Require Import Equations. From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICTyping PCUICLiftSubst PCUICReduction. +From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst. From Coq Require Import CRelationClasses. @@ -8,8 +8,15 @@ Ltac pcuic := try repeat red; cbn in *; try (solve [ intuition auto; eauto with pcuic || (try lia || congruence) ]). -Lemma context_relation_refl P : (forall Δ x, P Δ Δ x x) -> - forall Δ, context_relation P Δ Δ. +Lemma All2_fold_All2 (P : context_decl -> context_decl -> Type) Γ Δ : + All2_fold (fun _ _ => P) Γ Δ <~> + All2 P Γ Δ. +Proof. + split; induction 1; simpl; constructor; auto. +Qed. + +Lemma All2_fold_refl P : (forall Δ x, P Δ Δ x x) -> + forall Δ, All2_fold P Δ Δ. Proof. intros HP. induction Δ. @@ -17,88 +24,34 @@ Proof. destruct a as [? [?|] ?]; constructor; auto. Qed. -Lemma context_relation_nth {P n Γ Γ' d} : - context_relation P Γ Γ' -> nth_error Γ n = Some d -> - { d' & ((nth_error Γ' n = Some d') * - let Γs := skipn (S n) Γ in - let Γs' := skipn (S n) Γ' in - context_relation P Γs Γs' * - P Γs Γs' d d')%type }. -Proof. - induction n in Γ, Γ', d |- *; destruct Γ; intros Hrel H; noconf H. - - depelim Hrel. - simpl. eexists; intuition eauto. - eexists; intuition eauto. - - depelim Hrel. - destruct (IHn _ _ _ Hrel H). - cbn -[skipn] in *. - eexists; intuition eauto. - destruct (IHn _ _ _ Hrel H). - eexists; intuition eauto. -Qed. - -Lemma context_relation_nth_ass {P n Γ Γ' d} : - context_relation P Γ Γ' -> nth_error Γ n = Some d -> - assumption_context Γ -> - { d' & ((nth_error Γ' n = Some d') * - let Γs := skipn (S n) Γ in - let Γs' := skipn (S n) Γ' in - context_relation P Γs Γs' * - (d.(decl_body) = None) * - P Γs Γs' d d')%type }. -Proof. - induction n in Γ, Γ', d |- *; destruct Γ; intros Hrel H; noconf H. - - depelim Hrel. intro ass. - simpl. eexists; intuition eauto. - eexists; intuition eauto. - depelim H. - - intros ass. depelim Hrel. - destruct (IHn _ _ _ Hrel H). - now depelim ass. - cbn -[skipn] in *. - eexists; intuition eauto. - destruct (IHn _ _ _ Hrel H). - now depelim ass. - eexists; intuition eauto. -Qed. - -Lemma context_relation_nth_r {P n Γ Γ' d'} : - context_relation P Γ Γ' -> nth_error Γ' n = Some d' -> - { d & ((nth_error Γ n = Some d) * - let Γs := skipn (S n) Γ in - let Γs' := skipn (S n) Γ' in - context_relation P Γs Γs' * - P Γs Γs' d d')%type }. -Proof. - induction n in Γ, Γ', d' |- *; destruct Γ'; intros Hrel H; noconf H. - - depelim Hrel. - simpl. eexists; intuition eauto. - eexists; intuition eauto. - - depelim Hrel. - destruct (IHn _ _ _ Hrel H). - cbn -[skipn] in *. - eexists; intuition eauto. - destruct (IHn _ _ _ Hrel H). - eexists; intuition eauto. -Qed. - -Lemma context_relation_trans P : +Lemma All2_fold_trans P : (forall Γ Γ' Γ'' x y z, - context_relation P Γ Γ' -> - context_relation P Γ' Γ'' -> - context_relation P Γ Γ'' -> + All2_fold P Γ Γ' -> + All2_fold P Γ' Γ'' -> + All2_fold P Γ Γ'' -> P Γ Γ' x y -> P Γ' Γ'' y z -> P Γ Γ'' x z) -> - Transitive (context_relation P). + Transitive (All2_fold P). Proof. intros HP x y z H. induction H in z |- *; auto; intros H'; unfold context in *; depelim H'; try constructor; eauto; hnf in H0; noconf H0; eauto. Qed. -Lemma context_relation_app {P} Γ Γ' Δ Δ' : +Lemma All2_fold_sym P : + (forall Γ Γ' x y, + All2_fold P Γ Γ' -> + All2_fold P Γ' Γ -> + P Γ Γ' x y -> P Γ' Γ y x) -> + Symmetric (All2_fold P). +Proof. + intros HP x y H. + induction H; constructor; auto. +Qed. + +Lemma All2_fold_app_inv {P} Γ Γ' Δ Δ' : #|Δ| = #|Δ'| -> - context_relation P (Γ ,,, Δ) (Γ' ,,, Δ') -> - context_relation P Γ Γ' * context_relation (fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ')) Δ Δ'. + All2_fold P (Γ ,,, Δ) (Γ' ,,, Δ') -> + All2_fold P Γ Γ' * All2_fold (fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ')) Δ Δ'. Proof. intros H. induction Δ in H, Δ', Γ, Γ' |- *; @@ -110,168 +63,135 @@ Proof. constructor; auto. Qed. -Lemma context_relation_app_inv {P} Γ Γ' Δ Δ' : +Lemma All2_fold_app_inv_l {P} Γ Γ' Δ Δ' : + #|Γ| = #|Γ'| -> + All2_fold P (Γ ,,, Δ) (Γ' ,,, Δ') -> + All2_fold P Γ Γ' * All2_fold (fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ')) Δ Δ'. +Proof. + intros H. + induction Δ in H, Δ', Γ, Γ' |- *; + destruct Δ'; try discriminate. + intuition auto. constructor. + intros H'; generalize (All2_fold_length H'). simpl. len. lia. + intros H'; generalize (All2_fold_length H'). simpl. len. lia. + intros H'. simpl in H. + specialize (IHΔ Γ Γ' Δ' ltac:(lia)). + depelim H'; specialize (IHΔ H'); intuition auto; + constructor; auto. +Qed. + +Lemma All2_fold_app {P} Γ Γ' Δ Δ' : #|Δ| = #|Δ'| -> - context_relation P Γ Γ' -> context_relation (fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ')) Δ Δ' -> - context_relation P (Γ ,,, Δ) (Γ' ,,, Δ'). + All2_fold P Γ Γ' -> All2_fold (fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ')) Δ Δ' -> + All2_fold P (Γ ,,, Δ) (Γ' ,,, Δ'). Proof. intros H. induction 2; simpl; auto. constructor. apply IHX0. simpl in H. lia. apply p. - constructor. apply IHX0. simpl in H; lia. - apply p. Qed. -Section ContextChangeTypesReduction. - Context {cf : checker_flags}. - Context (Σ : global_env). +Lemma All2_fold_impl_onctx P P' Γ Δ Q : + onctx Q Γ -> + All2_fold P Γ Δ -> + (forall Γ Δ d d', + All2_fold P Γ Δ -> + P Γ Δ d d' -> + ondecl Q d -> + P' Γ Δ d d') -> + All2_fold P' Γ Δ. +Proof. + intros onc cr Hcr. + induction cr; depelim onc; constructor; intuition eauto. +Qed. + +Lemma All2_fold_impl_ind P P' Γ Δ : + All2_fold P Γ Δ -> + (forall Γ Δ d d', + All2_fold P Γ Δ -> + All2_fold P' Γ Δ -> + P Γ Δ d d' -> + P' Γ Δ d d') -> + All2_fold P' Γ Δ. +Proof. + intros cr Hcr. + induction cr; constructor; intuition eauto. +Qed. - Inductive change_decl_type : context_decl -> context_decl -> Type := - | change_vass_type : forall (na na' : aname) (T T' : term), - change_decl_type (vass na T) (vass na' T') - | change_vdef_type : forall (na na' : aname) (b T T' : term), - change_decl_type (vdef na b T) (vdef na' b T'). - - Derive Signature for change_decl_type. - - Global Instance change_decl_type_refl : Reflexive change_decl_type. - Proof. intros [? [|]]; constructor; reflexivity. Qed. +Lemma All2_fold_mapi P Γ Δ f g : + All2_fold (fun Γ Δ d 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. + split. + - induction 1; simpl; constructor; intuition auto; + now rewrite <-(All2_fold_length X). + - induction Γ as [|d Γ] in Δ |- *; destruct Δ as [|d' Δ]; simpl; intros H; + depelim H; constructor; simpl in *; auto. + pose proof (All2_fold_length H). len in H0. + now rewrite <- H0 in p. +Qed. - Global Instance change_decl_type_sym : Symmetric change_decl_type. - Proof. - intros x y rel. - depelim rel; constructor; now symmetry. - Qed. +Lemma All2_fold_map P Γ Δ 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 Δ). +Proof. + split. + - induction 1; simpl; constructor; intuition auto; + now rewrite <-(All2_fold_length X). + - induction Γ as [|d Γ] in Δ |- *; destruct Δ as [|d' Δ]; simpl; intros H; + depelim H; constructor; auto. +Qed. - Global Instance change_decl_type_trans : Transitive change_decl_type. - Proof. - intros x y z xy yz. - depelim xy; depelim yz; constructor; now etransitivity. - Qed. - - Global Instance change_decl_type_equiv : Equivalence change_decl_type. - Proof. constructor; typeclasses eauto. Qed. +Lemma All2_fold_cst_map P Γ Δ f g : + All2_fold (fun _ _ d d' => P (f d) (g d')) Γ Δ <~> + All2_fold (fun _ _ => P) (map f Γ) (map g Δ). +Proof. + split. + - induction 1; simpl; constructor; intuition auto; + now rewrite <-(All2_fold_length X). + - induction Γ as [|d Γ] in Δ |- *; destruct Δ as [|d' Δ]; simpl; intros H; + depelim H; constructor; auto. +Qed. - Lemma context_change_decl_types_red1 Γ Γ' s t : - context_relation (fun _ _ => change_decl_type) Γ Γ' -> red1 Σ Γ s t -> red Σ Γ' s t. - Proof. - intros HT X0. induction X0 using red1_ind_all in Γ', HT |- *; eauto. - all:pcuic. - - econstructor. econstructor. - rewrite <- H. - induction HT in i |- *; destruct i; eauto. - now inv p. - - - eapply PCUICReduction.red_abs. eapply IHX0; eauto. eauto. - - - eapply PCUICReduction.red_abs. eauto. eapply IHX0. eauto. - eauto. econstructor. eauto. econstructor. - - - eapply PCUICReduction.red_letin. eapply IHX0; eauto. - all:eauto. - - - eapply PCUICReduction.red_letin; eauto. - - - eapply PCUICReduction.red_letin; eauto. eapply IHX0; eauto. - econstructor. eauto. econstructor. - - - eapply PCUICReduction.red_case; eauto. clear. - eapply All_All2_refl. induction brs; eauto. - - eapply PCUICReduction.red_case; eauto. clear. - eapply All_All2_refl. induction brs; eauto. - - destruct ind. - eapply red_case; eauto. - clear - X HT. - induction X. - + econstructor. destruct p. destruct p. - split; eauto. - eapply All_All2_refl. - induction tl; eauto. - + econstructor. now split. - eassumption. - - - eapply PCUICReduction.red_proj_c. eauto. - - - eapply PCUICReduction.red_app; eauto. - - eapply PCUICReduction.red_app; eauto. - - - eapply PCUICReduction.red_prod; eauto. - - - eapply PCUICReduction.red_prod; eauto. eapply IHX0. eauto. eauto. - econstructor. - eauto. econstructor. - - eapply PCUICReduction.red_evar; eauto. - induction X; eauto. econstructor. eapply p; eauto. - induction tl; eauto. - - eapply PCUICReduction.red_fix_one_ty. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - - eapply PCUICReduction.red_fix_one_body. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - eapply ih ; auto. - clear - HT. - induction (fix_context mfix0) as [| [na [b|] ty] Δ ihΔ]. - + auto. - + simpl. constructor ; eauto. - constructor. - + simpl. constructor ; eauto. - constructor. - - eapply PCUICReduction.red_cofix_one_ty. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - - eapply PCUICReduction.red_cofix_one_body. - eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[r ih] e]. simpl in *. - inversion e. subst. clear e. - split ; auto. - eapply ih ; auto. - clear - HT. - induction (fix_context mfix0) as [| [na [b|] ty] Δ ihΔ]. - + auto. - + simpl. constructor ; eauto. - constructor. - + simpl. constructor ; eauto. - constructor. - Qed. +Lemma All2_fold_forallb2 (P : context_decl -> context_decl -> bool) Γ Δ : + All2_fold (fun _ _ => P) Γ Δ -> + forallb2 P Γ Δ. +Proof. + induction 1; simpl; auto; now rewrite p, IHX. +Qed. - Lemma context_change_decl_types_red Γ Γ' s t : - context_relation (fun _ _ => change_decl_type) Γ Γ' -> red Σ Γ s t -> red Σ Γ' s t. - Proof. - intros. induction X0 using red_rect'; eauto. - etransitivity. eapply IHX0. - eapply context_change_decl_types_red1; eauto. - Qed. -End ContextChangeTypesReduction. +Lemma All2_fold_nth {P n Γ Γ' d} : + All2_fold P Γ Γ' -> nth_error Γ n = Some d -> + { d' & ((nth_error Γ' n = Some d') * + let Γs := skipn (S n) Γ in + let Γs' := skipn (S n) Γ' in + All2_fold P Γs Γs' * + P Γs Γs' d d')%type }. +Proof. + induction n in Γ, Γ', d |- *; destruct Γ; intros Hrel H; noconf H. + - depelim Hrel. + simpl. eexists; intuition eauto. + - depelim Hrel. + destruct (IHn _ _ _ Hrel H). + cbn -[skipn] in *. + eexists; intuition eauto. +Qed. -Lemma fix_context_change_decl_types Γ mfix mfix' : - #|mfix| = #|mfix'| -> - context_relation (fun _ _ => change_decl_type) (Γ,,, fix_context mfix) (Γ,,, fix_context mfix'). +Lemma All2_fold_nth_r {P n Γ Γ' d'} : + All2_fold P Γ Γ' -> nth_error Γ' n = Some d' -> + { d & ((nth_error Γ n = Some d) * + let Γs := skipn (S n) Γ in + let Γs' := skipn (S n) Γ' in + All2_fold P Γs Γs' * + P Γs Γs' d d')%type }. Proof. - intros len. - apply context_relation_app_inv. - - now rewrite !fix_context_length. - - apply context_relation_refl. - intros. - destruct x. - destruct decl_body; constructor; - reflexivity. - - unfold fix_context, mapi. - generalize 0 at 2 4. - induction mfix in mfix', len |- *; intros n. - + destruct mfix'; [|cbn in *; discriminate len]. - constructor. - + destruct mfix'; cbn in *; [discriminate len|]. - apply context_relation_app_inv. - * now rewrite !List.rev_length, !mapi_rec_length. - * constructor; [constructor|]. - constructor. - * apply IHmfix; lia. + induction n in Γ, Γ', d' |- *; destruct Γ'; intros Hrel H; noconf H. + - depelim Hrel. + simpl. eexists; intuition eauto. + - depelim Hrel. + destruct (IHn _ _ _ Hrel H). + cbn -[skipn] in *. + eexists; intuition eauto. Qed. diff --git a/pcuic/theories/PCUICContextSubst.v b/pcuic/theories/PCUICContextSubst.v new file mode 100644 index 000000000..97218d2bd --- /dev/null +++ b/pcuic/theories/PCUICContextSubst.v @@ -0,0 +1,259 @@ +(* Distributed under the terms of the MIT license. *) +From MetaCoq.Template Require Import utils config. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction + PCUICLiftSubst. + +Require Import ssreflect. +From Equations Require Import Equations. + +(** * Substitution lemmas for typing derivations. *) + +Local Set Keyed Unification. + +Set Default Goal Selector "!". + +Hint Rewrite @app_context_length : wf. + +Generalizable Variables Σ Γ t T. + + +(** Linking a context (with let-ins), an instance (reversed substitution) + for its assumptions and a well-formed substitution for it. *) + +Inductive context_subst : context -> list term -> list term -> Type := +| context_subst_nil : context_subst [] [] [] +| context_subst_ass Γ args s na t a : + context_subst Γ args s -> + context_subst (vass na t :: Γ) (args ++ [a]) (a :: s) +| context_subst_def Γ args s na b t : + context_subst Γ args s -> + context_subst (vdef na b t :: Γ) args (subst s 0 b :: s). +Derive Signature for context_subst. + +(** Promoting a substitution for the non-let declarations of ctx into a + substitution for the whole context *) + +Fixpoint make_context_subst ctx args s := + match ctx with + | [] => match args with + | [] => Some s + | a :: args => None + end + | d :: ctx => + match d.(decl_body) with + | Some body => make_context_subst ctx args (subst0 s body :: s) + | None => match args with + | a :: args => make_context_subst ctx args (a :: s) + | [] => None + end + end + end. + +Lemma context_subst_length {Γ a s} : context_subst Γ a s -> #|Γ| = #|s|. +Proof. induction 1; simpl; congruence. Qed. + +Lemma context_subst_assumptions_length {Γ a s} : context_subst Γ a s -> context_assumptions Γ = #|a|. +Proof. induction 1; simpl; try congruence. rewrite app_length /=. lia. Qed. + +(* Lemma context_subst_app {cf:checker_flags} Γ Γ' a s : *) +(* context_subst (Γ' ++ Γ) a s -> *) +(* { a0 & { a1 & { s0 & { s1 & (context_subst Γ a0 s0 * context_subst (subst_context s0 0 Γ') a1 s1 *) +(* * (a = a0 ++ a1) * (s = s1 ++ s0))%type } } } }. *) +(* Proof. *) +(* induction Γ' in Γ, a, s |- *. simpl. *) +(* exists a, [], s, []. rewrite app_nil_r; intuition. constructor. *) + +(* simpl. intros Hs. *) +(* inv Hs. *) +(* - specialize (IHΓ' _ _ _ H). *) +(* destruct IHΓ' as (a0' & a1' & s1 & s2 & ((sa0 & sa1) & eqargs) & eqs0). *) +(* subst. exists a0', (a1' ++ [a1]), s1, (a1 :: s2). intuition eauto. *) +(* rewrite subst_context_snoc. constructor. auto. now rewrite app_assoc. *) +(* - specialize (IHΓ' _ _ _ H). *) +(* destruct IHΓ' as (a0' & a1' & s1 & s2 & ((sa0 & sa1) & eqargs) & eqs0). *) +(* subst. exists a0', a1', s1, (subst s2 0 (subst s1 #|Γ'| b) :: s2). intuition eauto. *) +(* rewrite -> subst_context_snoc, Nat.add_0_r. *) +(* unfold subst_decl; simpl. unfold map_decl. simpl. *) +(* econstructor. auto. simpl. f_equal. *) +(* rewrite -> subst_app_simpl; auto. simpl. *) +(* pose proof(context_subst_length _ _ _ sa1) as Hs1. *) +(* rewrite subst_context_length in Hs1. rewrite -> Hs1. auto. *) +(* Qed. *) + + + +Lemma make_context_subst_rec_spec ctx args s tele args' s' : + context_subst ctx args s -> + make_context_subst tele args' s = Some s' -> + context_subst (List.rev tele ++ ctx) (args ++ args') s'. +Proof. + induction tele in ctx, args, s, args', s' |- *. + - move=> /= Hc. case: args'. + + move => [= <-]. + now rewrite app_nil_r. + + move=> a l //. + - move=> Hc /=. case: a => [na [body|] ty] /=. + -- specialize (IHtele (vdef na body ty :: ctx) args (subst0 s body :: s) args' s'). + move=> /=. rewrite <- app_assoc. + move/(IHtele _). move=> H /=. apply H. + constructor. auto. + -- case: args' => [|a args']; try congruence. + specialize (IHtele (vass na ty :: ctx) (args ++ [a]) (a :: s) args' s'). + move=> /=. rewrite <- app_assoc. + move/(IHtele _). move=> H /=. simpl in H. rewrite <- app_assoc in H. apply H. + constructor. auto. +Qed. + +Lemma make_context_subst_spec tele args s' : + make_context_subst tele args [] = Some s' -> + context_subst (List.rev tele) args s'. +Proof. + move/(make_context_subst_rec_spec [] [] [] _ _ _ context_subst_nil). + rewrite app_nil_r /= //. +Qed. + +Lemma subst_telescope_cons s k d Γ : + subst_telescope s k (d :: Γ) = + map_decl (subst s k) d :: subst_telescope s (S k) Γ. +Proof. + simpl. + unfold subst_telescope, mapi. simpl. f_equal. + rewrite mapi_rec_Sk. apply mapi_rec_ext. + intros. simpl. now rewrite Nat.add_succ_r. +Qed. + +Lemma subst_telescope_comm_rec s k s' k' Γ: + subst_telescope (map (subst s' k) s) k' (subst_telescope s' (#|s| + k' + k) Γ) = + subst_telescope s' (k' + k) (subst_telescope s k' Γ). +Proof. + induction Γ in k, k' |- *; rewrite ?subst_telescope_cons; simpl; auto. + f_equal. + * unfold map_decl. simpl. + f_equal. + + destruct a as [na [b|] ty]; simpl; auto. + f_equal. now rewrite distr_subst_rec. + + now rewrite distr_subst_rec. + * specialize (IHΓ k (S k')). now rewrite Nat.add_succ_r in IHΓ. +Qed. + +Lemma subst_telescope_comm s k s' Γ: + subst_telescope (map (subst s' k) s) 0 (subst_telescope s' (#|s| + k) Γ) = + subst_telescope s' k (subst_telescope s 0 Γ). +Proof. + now rewrite -(subst_telescope_comm_rec _ _ _ 0) Nat.add_0_r. +Qed. + +Lemma decompose_prod_n_assum_extend_ctx {ctx n t ctx' t'} ctx'' : + decompose_prod_n_assum ctx n t = Some (ctx', t') -> + decompose_prod_n_assum (ctx ++ ctx'') n t = Some (ctx' ++ ctx'', t'). +Proof. + induction n in ctx, t, ctx', t', ctx'' |- *. + - simpl. intros [= -> ->]. eauto. + - simpl. + destruct t; simpl; try congruence. + + intros H. eapply (IHn _ _ _ _ ctx'' H). + + intros H. eapply (IHn _ _ _ _ ctx'' H). +Qed. + +Lemma context_subst_length2 {ctx args s} : context_subst ctx args s -> #|args| = context_assumptions ctx. +Proof. + induction 1; simpl; auto. + rewrite app_length; simpl; lia. +Qed. + +Lemma context_subst_fun {ctx args s s'} : context_subst ctx args s -> context_subst ctx args s' -> s = s'. +Proof. + induction 1 in s' |- *; intros H'; depelim H'; auto. + - eapply app_inj_tail in H. intuition subst. + now specialize (IHX _ H'). + - now specialize (IHX _ H'). +Qed. + +Lemma context_subst_fun' {ctx args args' s s'} : context_subst ctx args s -> context_subst ctx args' s' -> #|args| = #|args'|. +Proof. + induction 1 as [ | ? ? ? ? ? ? ? IHX | ? ? ? ? ? ? ? IHX ] in args', s' |- *; intros H'; depelim H'; auto. + - now rewrite !app_length; specialize (IHX _ _ H'). + - now specialize (IHX _ _ H'). +Qed. + +Hint Constructors context_subst : core. + +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. + revert ctx' args s. + induction ctx; intros ctx' args s; simpl. + - intros Hc. + rewrite - !(context_subst_length2 Hc). + now rewrite firstn_all skipn_all. + - intros Hc. + depelim Hc. + * rewrite skipn_S. + specialize (IHctx _ _ _ Hc) as [IHctx IHctx']. + 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 firstn_app. rewrite (firstn_0 [a0]). + { rewrite firstn_length_le in H0; lia. } + rewrite app_nil_r. split; auto. + rewrite skipn_app_le; try lia. + rewrite subst_context_snoc. + now constructor. + + * specialize (IHctx _ _ _ Hc). + split; try now rewrite skipn_S. + pose proof (context_subst_length2 Hc). + rewrite context_assumptions_app in H. + destruct IHctx as [IHctx _]. + pose proof (context_subst_length IHctx). + rewrite subst_context_snoc. rewrite !skipn_S. + rewrite /subst_decl /map_decl /= Nat.add_0_r. + rewrite -{4}(firstn_skipn #|ctx| s0). + rewrite subst_app_simpl. simpl. + rewrite subst_context_length in H0. rewrite -H0. + now constructor. +Qed. + +Lemma make_context_subst_recP ctx args s tele args' s' : + context_subst ctx args s -> + (make_context_subst tele args' s = Some s') <~> + context_subst (List.rev tele ++ ctx) (args ++ args') s'. +Proof. + induction tele in ctx, args, s, args', s' |- *. + - move=> /= Hc. case: args'. + * split. + + move => [= <-]. + now rewrite app_nil_r. + + rewrite app_nil_r. + move/context_subst_fun => Hs. now specialize (Hs _ Hc). + * intros. split; try discriminate. + intros H2. pose proof (context_subst_fun' Hc H2). + rewrite app_length /= in H. now lia. + - move=> Hc /=. case: a => [na [body|] ty] /=. + * specialize (IHtele (vdef na body ty :: ctx) args (subst0 s body :: s) args' s'). + move=> /=. rewrite <- app_assoc. + now forward IHtele by (constructor; auto). + * destruct args' as [|a args']. + + split; [congruence | ]. intros Hc'. + 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 /=. + rewrite -app_assoc in IHtele. apply IHtele. +Qed. + +Lemma make_context_subst_spec_inv : forall (tele : list context_decl) (args s' : list term), + context_subst (List.rev tele) args s' -> + make_context_subst tele args [] = Some s'. +Proof. + intros. assert (H:=make_context_subst_recP [] [] [] tele args s'). + forward H by constructor. + rewrite app_nil_r in H. destruct H. + simpl in *. auto. +Qed. diff --git a/pcuic/theories/PCUICContexts.v b/pcuic/theories/PCUICContexts.v index 1a5a648e9..e5d968a1a 100644 --- a/pcuic/theories/PCUICContexts.v +++ b/pcuic/theories/PCUICContexts.v @@ -1,55 +1,25 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. From Coq Require Import CRelationClasses ProofIrrelevance. -From MetaCoq.Template Require Import config Universes utils BasicAst - AstUtils UnivSubst. +From MetaCoq.Template Require Import config Universes utils BasicAst. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction PCUICReflect PCUICLiftSubst PCUICUnivSubst PCUICTyping - PCUICCumulativity PCUICPosition PCUICEquality PCUICNameless PCUICInversion PCUICCumulativity PCUICReduction PCUICConfluence PCUICConversion PCUICContextConversion + PCUICContextSubst PCUICParallelReductionConfluence PCUICWeakeningEnv - PCUICClosed PCUICSubstitution PCUICUnivSubstitution PCUICSigmaCalculus - PCUICWeakening PCUICGeneration PCUICUtils PCUICCtxShape. + PCUICClosed PCUICSigmaCalculus PCUICSubstitution PCUICUnivSubstitution + PCUICWeakening PCUICGeneration PCUICUtils. From Equations Require Import Equations. Require Import Equations.Prop.DepElim. Require Import Equations.Type.Relation_Properties. Require Import ssreflect ssrbool. - -Derive Signature for context_subst. +Implicit Types (cf : checker_flags) (Σ : global_env_ext). Hint Rewrite Nat.add_0_r : len. -Lemma ctx_length_ind (P : context -> Type) (p0 : P []) - (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (d :: Γ)) - Γ : P Γ. -Proof. - generalize (le_n #|Γ|). - generalize #|Γ| at 2. - induction n in Γ |- *. - destruct Γ; [|simpl; intros; elimtype False; lia]. - intros. apply p0. - intros. - destruct Γ; simpl in *. - apply p0. apply pS. intros. apply IHn. simpl. lia. -Qed. - -Lemma ctx_length_rev_ind (P : context -> Type) (p0 : P []) - (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (Γ ++ [d])) - Γ : P Γ. -Proof. - generalize (le_n #|Γ|). - generalize #|Γ| at 2. - induction n in Γ |- *. - destruct Γ using rev_ind; [|simpl; rewrite app_length /=; intros; elimtype False; try lia]. - intros. apply p0. - destruct Γ using rev_ind; simpl in *; rewrite ?app_length /=; intros Hlen. - intros. apply p0. - apply pS. intros. apply IHn. simpl. lia. -Qed. - Lemma smash_context_subst_empty s n Γ : smash_context [] (subst_context s n Γ) = subst_context s n (smash_context [] Γ). @@ -57,12 +27,12 @@ Proof. apply: (smash_context_subst []). Qed. Lemma conv_context_smash {cf:checker_flags} Σ Γ Δ Δ' : assumption_context Δ -> - context_relation (fun Δ Δ' => conv_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ' -> + All2_fold (fun Δ Δ' => conv_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ' -> assumption_context Δ'. Proof. intros Hass Hconv. induction Hass in Δ', Hconv |- *. depelim Hconv. constructor. - depelim Hconv; constructor; auto. + depelim Hconv. depelim c; constructor; auto. Qed. Lemma smash_context_assumption_context {Γ Δ} : @@ -84,113 +54,12 @@ Hint Resolve smash_context_assumption_context : pcuic. Lemma assumption_context_length ctx : assumption_context ctx -> context_assumptions ctx = #|ctx|. -Proof. induction 1; simpl; auto. Qed. +Proof. induction 1; simpl; auto; lia. Qed. Hint Resolve assumption_context_length : pcuic. -Lemma context_subst_length2 {ctx args s} : context_subst ctx args s -> #|args| = context_assumptions ctx. -Proof. - induction 1; simpl; auto. - rewrite app_length; simpl; lia. -Qed. - -Lemma context_subst_fun {ctx args s s'} : context_subst ctx args s -> context_subst ctx args s' -> s = s'. -Proof. - induction 1 in s' |- *; intros H'; depelim H'; auto. - eapply app_inj_tail in H. intuition subst. - now specialize (IHX _ H'). - now specialize (IHX _ H'). -Qed. - -Lemma context_subst_fun' {ctx args args' s s'} : context_subst ctx args s -> context_subst ctx args' s' -> #|args| = #|args'|. -Proof. - induction 1 as [ | ? ? ? ? ? ? ? IHX | ? ? ? ? ? ? ? IHX ] in args', s' |- *; intros H'; depelim H'; auto. - now rewrite !app_length; specialize (IHX _ _ H'). - now specialize (IHX _ _ H'). -Qed. - -Hint Constructors context_subst : core. - -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. - revert ctx' args s. - induction ctx; intros ctx' args s; simpl. - - intros Hc. rewrite !skipn_0. - rewrite - !(context_subst_length2 Hc). - now rewrite firstn_all skipn_all. - - intros Hc. - depelim Hc. simpl. - rewrite skipn_S. - specialize (IHctx _ _ _ Hc) as [IHctx IHctx']. - 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 firstn_app. rewrite (firstn_0 [a0]). - rewrite firstn_length_le in H0. lia. lia. - rewrite app_nil_r. split; auto. - rewrite skipn_app_le. lia. - rewrite subst_context_snoc. - now constructor. - - specialize (IHctx _ _ _ Hc). - split; try now rewrite skipn_S. - pose proof (context_subst_length2 Hc). - rewrite context_assumptions_app in H. - destruct IHctx as [IHctx _]. - pose proof (context_subst_length IHctx). - rewrite subst_context_snoc. rewrite !skipn_S. - rewrite /subst_decl /map_decl /= Nat.add_0_r. - rewrite -{4}(firstn_skipn #|ctx| s0). - rewrite subst_app_simpl. simpl. - rewrite subst_context_length in H0. rewrite -H0. - now constructor. -Qed. - -Lemma make_context_subst_rec_spec ctx args s tele args' s' : - context_subst ctx args s -> - (make_context_subst tele args' s = Some s') <~> - context_subst (List.rev tele ++ ctx) (args ++ args') s'. -Proof. - induction tele in ctx, args, s, args', s' |- *. - - move=> /= Hc. case: args'. - split. move => [= <-]. - now rewrite app_nil_r. - rewrite app_nil_r. - move/context_subst_fun => Hs. now specialize (Hs _ Hc). - intros. split; try discriminate. - intros H2. pose proof (context_subst_fun' Hc H2). - rewrite app_length /= in H. now lia. - - move=> Hc /=. case: a => [na [body|] ty] /=. - * specialize (IHtele (vdef na body ty :: ctx) args (subst0 s body :: s) args' s'). - move=> /=. rewrite <- app_assoc. - now forward IHtele by (constructor; auto). - * destruct args' as [|a args']. - split; [congruence | ]. intros Hc'. - 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 /=. - rewrite -app_assoc in IHtele. apply IHtele. -Qed. - -Lemma make_context_subst_spec_inv : forall (tele : list context_decl) (args s' : list term), - context_subst (List.rev tele) args s' -> - make_context_subst tele args [] = Some s'. -Proof. - intros. assert (H:=make_context_subst_rec_spec [] [] [] tele args s'). - forward H by constructor. - rewrite app_nil_r in H. destruct H. - simpl in *. auto. -Qed. - -Lemma map_subst_instance_constr_to_extended_list_k u ctx k : - map (subst_instance_constr u) (to_extended_list_k ctx k) + +Lemma map_subst_instance_to_extended_list_k u ctx k : + map (subst_instance u) (to_extended_list_k ctx k) = to_extended_list_k ctx k. Proof. pose proof (to_extended_list_k_spec ctx k). @@ -199,11 +68,11 @@ Proof. Qed. Lemma subst_instance_to_extended_list_k u l k - : map (subst_instance_constr u) (to_extended_list_k l k) - = to_extended_list_k (subst_instance_context u l) k. + : map (subst_instance u) (to_extended_list_k l k) + = to_extended_list_k (subst_instance u l) k. Proof. unfold to_extended_list_k. - change [] with (map (subst_instance_constr u) []) at 2. + change [] with (map (subst_instance u) (@nil term)) at 2. generalize (@nil term). induction l as [|[aa [ab|] ac] bb] in k |- *. + reflexivity. + intros l; cbn. now rewrite IHbb. @@ -226,11 +95,7 @@ Qed. Derive Signature for subslet. Lemma closedn_ctx_snoc k Γ d : closedn_ctx k (Γ ,, d) = closedn_ctx k Γ && closed_decl (#|Γ| + k) d. -Proof. - rewrite /closedn_ctx !mapi_rev /= forallb_app /= /closed_decl /id /=. - f_equal; first now rewrite mapi_rec_Sk. - now rewrite Nat.sub_0_r Nat.add_comm andb_true_r. -Qed. +Proof. reflexivity. Qed. Lemma type_local_ctx_wf_local {cf:checker_flags} Σ Γ Δ s : wf_local Σ Γ -> @@ -259,7 +124,7 @@ Lemma instantiate_minductive {cf:checker_flags} Σ ind mdecl u Γ t T : declared_minductive Σ.1 ind mdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> (Σ.1, ind_universes mdecl) ;;; Γ |- t : T -> - Σ ;;; subst_instance_context u Γ |- subst_instance_constr u t : subst_instance_constr u T. + Σ ;;; subst_instance u Γ |- subst_instance u t : subst_instance u T. Proof. intros wfΣ isdecl Hu Ht. red in isdecl. eapply PCUICUnivSubstitution.typing_subst_instance_decl in isdecl; eauto. @@ -270,7 +135,7 @@ Lemma type_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : declared_minductive Σ.1 ind mdecl -> type_local_ctx (lift_typing typing) (Σ.1, ind_universes mdecl) Γ Δ s -> consistent_instance_ext Σ (ind_universes mdecl) u -> - type_local_ctx (lift_typing typing) Σ (subst_instance_context u Γ) (subst_instance_context u Δ) (subst_instance_univ u s). + type_local_ctx (lift_typing typing) Σ (subst_instance u Γ) (subst_instance u Δ) (subst_instance_univ u s). Proof. intros Hctx Hu. induction Δ; simpl in *; intuition auto. @@ -283,11 +148,11 @@ Proof. - destruct a0. exists (subst_instance_univ u x). eapply instantiate_minductive in t; eauto. - now rewrite PCUICUnivSubstitution.subst_instance_context_app in t. + now rewrite PCUICUnivSubstitution.subst_instance_app in t. - eapply instantiate_minductive in b1; eauto. - now rewrite PCUICUnivSubstitution.subst_instance_context_app in b1. + now rewrite PCUICUnivSubstitution.subst_instance_app in b1. - eapply instantiate_minductive in b; eauto. - now rewrite PCUICUnivSubstitution.subst_instance_context_app in b. + now rewrite PCUICUnivSubstitution.subst_instance_app in b. Qed. Lemma sorts_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : @@ -295,7 +160,7 @@ Lemma sorts_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : 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_context u Γ) (subst_instance_context u Δ) + sorts_local_ctx (lift_typing typing) Σ (subst_instance u Γ) (subst_instance u Δ) (List.map (subst_instance_univ u) s). Proof. intros Hctx Hu. @@ -305,12 +170,12 @@ Proof. - destruct a0. exists (subst_instance_univ u x). eapply instantiate_minductive in t; eauto. - now rewrite PCUICUnivSubstitution.subst_instance_context_app in t. + now rewrite PCUICUnivSubstitution.subst_instance_app in t. - eapply instantiate_minductive in b1; eauto. - now rewrite PCUICUnivSubstitution.subst_instance_context_app in b1. + now rewrite PCUICUnivSubstitution.subst_instance_app in b1. - destruct s; simpl; intuition eauto. eapply instantiate_minductive in b; eauto. - now rewrite PCUICUnivSubstitution.subst_instance_context_app in b. + now rewrite PCUICUnivSubstitution.subst_instance_app in b. Qed. Lemma on_udecl_on_udecl_prop {cf:checker_flags} Σ ctx : @@ -323,7 +188,7 @@ Lemma wf_local_instantiate_poly {cf:checker_flags} Σ ctx Γ u : wf_ext (Σ.1, Polymorphic_ctx ctx) -> consistent_instance_ext Σ (Polymorphic_ctx ctx) u -> wf_local (Σ.1, Polymorphic_ctx ctx) Γ -> - wf_local Σ (subst_instance_context u Γ). + wf_local Σ (subst_instance u Γ). Proof. intros wfΣ Huniv wf. epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty. @@ -338,7 +203,7 @@ Lemma wf_local_instantiate {cf:checker_flags} Σ (decl : global_decl) Γ u c : 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 Σ (subst_instance_context u Γ). + wf_local Σ (subst_instance u Γ). Proof. intros wfΣ Hdecl Huniv wf. epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty. @@ -445,21 +310,21 @@ Proof. unfold to_extended_list_k. now rewrite reln_app reln_acc. Qed. -Lemma to_extended_list_k_fold_context f Γ k : - to_extended_list_k (fold_context f Γ) k = to_extended_list_k Γ 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. generalize (@nil term). induction Γ in k |- *. simpl; auto. intros. - rewrite fold_context_snoc0. simpl. + rewrite fold_context_k_snoc0. simpl. 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'. -Proof. now rewrite to_extended_list_k_fold_context. Qed. +Proof. now rewrite to_extended_list_k_fold_context_k. Qed. Lemma reln_lift n k Γ : reln [] (n + k) Γ = map (lift0 n) (reln [] k Γ). Proof. @@ -471,7 +336,7 @@ Proof. Qed. Lemma to_extended_list_length Γ : #|to_extended_list Γ| = context_assumptions Γ. -Proof. now rewrite /to_extended_list PCUICCtxShape.to_extended_list_k_length. Qed. +Proof. now rewrite /to_extended_list to_extended_list_k_length. Qed. Hint Rewrite to_extended_list_length : len. Lemma map_subst_app_to_extended_list_k s s' ctx k : @@ -496,8 +361,8 @@ Proof. rewrite subst_context_snoc; simpl. - rewrite IHΔ. f_equal. rewrite !subst_context_alt !mapi_mapi. apply mapi_ext. clear. - intros n x. rewrite /subst_decl !PCUICAstUtils.compose_map_decl. - eapply PCUICAstUtils.map_decl_ext. intros. + intros n x. rewrite /subst_decl !compose_map_decl. + eapply map_decl_ext. intros. autorewrite with len. generalize (Nat.pred #|Γ| - n). generalize (#|Δ| + k). clear. intros. rewrite distr_subst_rec. simpl. now rewrite -Nat.add_assoc. @@ -564,45 +429,7 @@ Proof. rewrite ?app_context_nil_l; eauto. Qed. -Lemma 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. - -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. - induction Γ as [|[? [] ?] ?] in |- *; simpl; auto; - intros; destruct n; simpl in *; rewrite ?subst_context_snoc in H0; simpl in H0. - - noconf H0; simpl. - specialize (H 0 _ eq_refl). simpl in H; discriminate. - - specialize (H 0 _ eq_refl). simpl in H; discriminate. - - noconf H0; simpl. auto. - - eapply IHΓ. intros. now specialize (H (S n0) d0 H1). - eauto. -Qed. - -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. - induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto. - - intros. eapply (IHΓ (subst_context [t] 0 Δ)). - apply nth_error_ass_subst_context. auto. eauto. - - intros. eapply IHΓ. 2:eauto. - intros. - pose proof (nth_error_Some_length H1). autorewrite with len in H2. simpl in H2. - destruct (eq_dec n0 #|Δ|). subst. - rewrite nth_error_app_ge in H1. lia. rewrite Nat.sub_diag /= in H1. noconf H1. - reflexivity. - rewrite nth_error_app_lt in H1; try lia. eauto. -Qed. +Local Open Scope sigma_scope. Lemma context_subst_extended_subst Γ args s : context_subst Γ args s -> @@ -620,21 +447,21 @@ Proof. rewrite subst_consn_subst_cons. now rewrite subst_cons_shift. - simpl. - f_equal; auto. + f_equal; auto. len. rewrite IHX. autorewrite with sigma. - apply inst_ext. - rewrite ren_lift_renaming. autorewrite with len. - rewrite subst_consn_compose. - autorewrite with sigma. - unfold Upn. + apply inst_ext. len. + rewrite (Upn_eq _ (List.rev args ⋅n ids)). rewrite subst_consn_compose. - apply subst_consn_proper; first last. + rewrite PCUICInst.map_inst_idsn; len; try lia. + rewrite subst_compose_assoc. + rewrite -(context_subst_length2 X). + rewrite subst_consn_shiftn; len => //. + sigma. rewrite Upn_eq. sigma. + rewrite PCUICInst.map_inst_idsn; len; try lia. + rewrite -subst_compose_assoc shiftk_compose. rewrite -subst_consn_app. - rewrite shiftk_compose. - rewrite subst_consn_shiftn //. - autorewrite with len. now rewrite (context_subst_length2 X). - rewrite map_inst_idsn //. now autorewrite with len. + rewrite subst_consn_shiftn //. now len. Qed. Lemma map_subst_app_decomp (l l' : list term) (k : nat) (ts : list term) : @@ -712,46 +539,187 @@ Proof. autorewrite with len in Hlen. lia. Qed. -Hint Rewrite arities_context_length : len. - Lemma assumption_context_fold f Γ : - assumption_context Γ -> assumption_context (fold_context f Γ). + assumption_context Γ -> assumption_context (fold_context_k f Γ). Proof. - induction 1; simpl. constructor. rewrite fold_context_snoc0. + induction 1; simpl. constructor. rewrite fold_context_k_snoc0. now constructor. Qed. -Lemma map_subst_closedn (s : list term) (k : nat) l : - forallb (closedn k) l -> map (subst s k) l = l. + + +Lemma smash_context_app_expand Γ Δ Δ' : + smash_context Γ (Δ ,,, Δ') = + smash_context [] Δ ,,, expand_lets_ctx Δ (smash_context Γ Δ'). Proof. - induction l; simpl; auto. - move/andP=> [cla cll]. rewrite IHl //. - now rewrite subst_closedn. + rewrite smash_context_app smash_context_acc. + rewrite /expand_lets_k_ctx /app_context. f_equal. Qed. -Lemma closedn_extended_subst_gen Γ k k' : - closedn_ctx k Γ -> - forallb (closedn (k' + k + context_assumptions Γ)) (extended_subst Γ k'). +Lemma expand_lets_smash_context Γ Δ Δ' : + expand_lets_ctx Γ (smash_context Δ Δ') = + smash_context (expand_lets_k_ctx Γ #|Δ'| Δ) (expand_lets_ctx Γ Δ'). Proof. - induction Γ as [|[? [] ?] ?] in k, k' |- *; simpl; auto; - rewrite ?closedn_ctx_cons; - move/andP => [clΓ /andP[clb clt]]. - - rewrite IHΓ //. - epose proof (closedn_subst (extended_subst Γ k') (k' + k + context_assumptions Γ) 0). - autorewrite with len in H. rewrite andb_true_r. - eapply H; auto. - replace (k' + k + context_assumptions Γ + #|Γ|) - with (k + #|Γ| + (context_assumptions Γ + k')) by lia. - eapply closedn_lift. eapply clb. - - apply andb_and. split. - * apply Nat.ltb_lt; lia. - * specialize (IHΓ k (S k') clΓ). - red. rewrite -IHΓ. f_equal. f_equal. lia. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + rewrite -smash_context_lift -smash_context_subst /=; len. + lia_f_equal. Qed. -Lemma closedn_extended_subst Γ : - closed_ctx Γ -> - forallb (closedn (context_assumptions Γ)) (extended_subst Γ 0). +Lemma expand_lets_k_ctx_nil Γ k : expand_lets_k_ctx Γ k [] = []. +Proof. reflexivity. Qed. + +Lemma expand_lets_ctx_nil Γ : expand_lets_ctx Γ [] = []. +Proof. reflexivity. Qed. +Hint Rewrite expand_lets_k_ctx_nil expand_lets_ctx_nil : pcuic. + +Definition subst_let_expand args Δ T := + (subst0 args (expand_lets Δ T)). + +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)) = + tProd na (subst_let_expand args Δ T) (tSort s). +Proof. + reflexivity. +Qed. + +Definition subst_let_expand_mkApps s Δ f args : + subst_let_expand s Δ (mkApps f args) = + mkApps (subst_let_expand s Δ f) (map (subst_let_expand s Δ) args). +Proof. + rewrite /subst_let_expand. + now rewrite expand_lets_mkApps subst_mkApps map_map_compose. +Qed. + +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 : + subst_let_expand s Γ (it_mkProd_or_LetIn Δ (tSort u)) = + it_mkProd_or_LetIn (subst_context_let_expand s Γ Δ) (tSort u). Proof. - intros clΓ. now apply (closedn_extended_subst_gen Γ 0 0). + rewrite /subst_let_expand /expand_lets. + rewrite expand_lets_it_mkProd_or_LetIn /= subst_it_mkProd_or_LetIn /=. + reflexivity. Qed. + +Lemma subst_lift_above s n k x : k = #|s| -> subst0 s (lift0 (n + k) x) = lift0 n x. +Proof. + intros. rewrite Nat.add_comm. subst k. now rewrite simpl_subst. +Qed. + +Lemma subst_let_expand_lift_id s Δ k x : + k = #|Δ| -> + #|s| = context_assumptions Δ -> + subst_let_expand s Δ (lift0 k x) = x. +Proof. + intros -> hl. + rewrite /subst_let_expand /expand_lets /expand_lets_k. + simpl. + rewrite simpl_lift; len; try lia. + rewrite subst_lift_above. now len. + change (context_assumptions Δ) with (0 + context_assumptions Δ). + rewrite subst_lift_above. len. lia. now rewrite lift0_id. +Qed. + +Lemma subslet_lift {cf:checker_flags} Σ (Γ Δ : context) s Δ' : + wf Σ.1 -> wf_local Σ (Γ ,,, Δ) -> + subslet Σ Γ s Δ' -> + subslet Σ (Γ ,,, Δ) (map (lift0 #|Δ|) s) (lift_context #|Δ| 0 Δ'). +Proof. + move=> wfΣ wfl. + induction 1; rewrite ?lift_context_snoc /=; try constructor; auto. + simpl. + rewrite -(subslet_length X). + rewrite -distr_lift_subst. apply weakening; eauto. + + rewrite -(subslet_length X). + rewrite distr_lift_subst. constructor; auto. + rewrite - !distr_lift_subst. apply weakening; eauto. +Qed. + +Lemma subslet_extended_subst {cf} {Σ} {wfΣ : wf Σ} Γ Δ : + wf_local Σ (Γ ,,, Δ) -> + subslet Σ (Γ ,,, smash_context [] Δ) + (extended_subst Δ 0) + (lift_context (context_assumptions Δ) 0 Δ). +Proof. + move=> wfΔ. + eapply wf_local_app_inv in wfΔ as [wfΓ wfΔ]. + induction Δ as [|[na [d|] ?] ?] in wfΔ |- *; simpl; try constructor. + * depelim wfΔ. repeat red in l, l0. red in l0. + specialize (IHΔ wfΔ). + rewrite lift_context_snoc /lift_decl /= /map_decl /=. + len. + constructor => //. + eapply (weakening_typing (Γ'' := smash_context [] Δ)) in l0. + len in l0. simpl in l0. simpl. + 2:{ eapply wf_local_smash_end; pcuic. } + eapply (PCUICSubstitution.substitution _ _ _ _ []) in l0; tea. + * rewrite smash_context_acc. simpl. + rewrite /map_decl /= /map_decl /=. simpl. + depelim wfΔ. + destruct l as [s Hs]. + specialize (IHΔ wfΔ). + rewrite lift_context_snoc /lift_decl /= /map_decl /=. + constructor. + - rewrite (lift_extended_subst _ 1). + rewrite -(lift_context_lift_context 1 _). + eapply (subslet_lift _ _ [_]); eauto. + constructor. + { eapply wf_local_smash_end; pcuic. } + red. exists s. + eapply (weakening_typing (Γ'' := smash_context [] Δ)) in Hs. + len in Hs. simpl in Hs. simpl. + 2:{ eapply wf_local_smash_end; pcuic. } + eapply (PCUICSubstitution.substitution _ _ _ _ []) in Hs; tea. + - eapply meta_conv. + econstructor. constructor. apply wf_local_smash_end; auto. + eapply wf_local_app; eauto. + exists s. + eapply (weakening_typing (Γ'' := smash_context [] Δ)) in Hs. + len in Hs. simpl in Hs. simpl. + 2:{ eapply wf_local_smash_end; pcuic. } + eapply (PCUICSubstitution.substitution _ _ _ _ []) in Hs; tea. + reflexivity. + simpl. rewrite (lift_extended_subst _ 1). + rewrite distr_lift_subst. f_equal. len. + 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. +Proof. + intros Ht. + rewrite /expand_lets /expand_lets_k. + pose proof (typing_wf_local Ht). + eapply (weakening_typing (Γ'' := smash_context [] Δ)) in Ht. + len in Ht. simpl in Ht. simpl. + 2:{ eapply wf_local_smash_end; pcuic. } + eapply (PCUICSubstitution.substitution _ _ _ _ []) in Ht; tea. + now eapply subslet_extended_subst. +Qed. + +Lemma subst_context_let_expand_length s Γ Δ : + #|subst_context_let_expand s Γ Δ| = #|Δ|. +Proof. + now rewrite /subst_context_let_expand; len. +Qed. +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 Γ Δ) = + to_extended_list Δ. +Proof. + rewrite /subst_context_let_expand /to_extended_list /expand_lets_ctx /expand_lets_k_ctx. + now rewrite !to_extended_list_k_subst to_extended_list_k_lift_context. +Qed. + +Lemma context_assumptions_expand_lets_ctx Γ Δ : + context_assumptions (expand_lets_ctx Γ Δ) = context_assumptions Δ. +Proof. now rewrite /expand_lets_ctx /expand_lets_k_ctx; len. Qed. +Hint Rewrite context_assumptions_expand_lets_ctx : len. diff --git a/pcuic/theories/PCUICConvCumInversion.v b/pcuic/theories/PCUICConvCumInversion.v index 1710f1d55..830667bd9 100644 --- a/pcuic/theories/PCUICConvCumInversion.v +++ b/pcuic/theories/PCUICConvCumInversion.v @@ -2,6 +2,7 @@ From Equations Require Import Equations. From MetaCoq.PCUIC Require Import PCUICAst. From MetaCoq.PCUIC Require Import PCUICAstUtils. From MetaCoq.PCUIC Require Import PCUICContextConversion. +From MetaCoq.PCUIC Require Import PCUICContextReduction. From MetaCoq.PCUIC Require Import PCUICConversion. From MetaCoq.PCUIC Require Import PCUICCumulativity. From MetaCoq.PCUIC Require Import PCUICCumulProp. @@ -20,6 +21,7 @@ Set Default Goal Selector "!". Section fixed. Context {cf : checker_flags}. Context (Σ : global_env_ext). + Context (wfΣ : wf Σ). Definition isIndConstructApp (t : term) : bool := match (decompose_app t).1 with @@ -118,14 +120,35 @@ Section fixed. + now apply IHa1. Qed. + Lemma red_ctx_rel_par_conv Γ Γ0 Γ0' Γ1 Γ1' : + red_ctx_rel Σ Γ Γ0 Γ0' -> + red_ctx_rel Σ Γ Γ1 Γ1' -> + eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ0' Γ1' -> + conv_context_rel Σ Γ Γ0 Γ1. + Proof. + intros r0 r1 eq. + apply red_ctx_rel_red_context_rel, red_context_app_same_left in r0; auto. + apply red_ctx_rel_red_context_rel, red_context_app_same_left in r1; auto. + apply PCUICConfluence.red_ctx_red_context, red_ctx_conv_context in r0. + apply PCUICConfluence.red_ctx_red_context, red_ctx_conv_context in r1. + apply conv_context_rel_app. + eapply conv_context_trans; eauto. + eapply conv_context_sym; eauto. + eapply conv_context_trans; eauto. + eapply conv_context_sym; eauto. + eapply eq_context_upto_univ_conv_context; eauto. + apply All2_fold_app; pcuic. + reflexivity. + Qed. + Lemma conv_cum_tCase_inv leq Γ p motive discr brs p' motive' discr' brs' : conv_cum leq Σ Γ (tCase p motive discr brs) (tCase p' motive' discr' brs') -> whnf RedFlags.default Σ Γ (tCase p motive discr brs) -> whnf RedFlags.default Σ Γ (tCase p' motive' discr' brs') -> ∥ p = p' × - Σ;;; Γ |- motive = motive' × + conv_predicate Σ Γ motive motive' × Σ;;; Γ |- discr = discr' × - All2 (fun br br' => br.1 = br'.1 × Σ;;; Γ |- br.2 = br'.2) brs brs'∥. + conv_brs Σ Γ brs brs'∥. Proof. intros conv whl whr. depelim whl; solve_discr. @@ -139,17 +162,29 @@ Section fixed. depelim r2. depelim eq. constructor. - split; [easy|]. - split; [apply conv_alt_red; now exists motive'0, motive'1|]. - split; [apply conv_alt_red; now exists discr'0, discr'1|]. - clear -a a0 a1. - induction a in brs, brs', brs'0, brs'1, a0, a1, a |- *; - depelim a0; depelim a1; [now constructor|]. - constructor; eauto. - destruct p, p0, r. - split; [congruence|]. - apply conv_alt_red. - eauto. + red in e; cbn in e. + specialize e as (?&?&?&?). + splits; eauto. + - eapply conv_terms_alt; eauto. + - eapply red_ctx_rel_par_conv; eauto. + - eapply conv_red_conv; eauto. + + eapply conv_context_rel_app, red_ctx_rel_par_conv; eauto. + + constructor; auto. + - apply conv_alt_red; exists discr'0, discr'1; auto. + - rename a0 into brsa1. + rename a2 into brsa2. + rename a3 into brseq. + clear -wfΣ brsa1 brsa2 brseq. + induction brseq in brs, brs', brsa1, brsa2 |- *; + depelim brsa1; depelim brsa2; [constructor|]. + destruct p, p0, r. + constructor. + 2: { apply IHbrseq; auto. } + split. + + eapply red_ctx_rel_par_conv; eauto. + + eapply conv_red_conv; eauto. + * eapply conv_context_rel_app, red_ctx_rel_par_conv; eauto. + * constructor; auto. Qed. Lemma conv_cum_tFix_inv leq Γ mfix idx mfix' idx' : @@ -192,8 +227,8 @@ Section fixed. exists (dbody x), (dbody y). split; [|easy]. split; [easy|]. - eapply context_change_decl_types_red; eauto. - eapply fix_context_change_decl_types; eauto. + eapply PCUICRedTypeIrrelevance.context_pres_let_bodies_red; eauto. + eapply PCUICRedTypeIrrelevance.fix_context_pres_let_bodies; eauto. Qed. Lemma conv_cum_tCoFix_inv leq Γ mfix idx mfix' idx' : @@ -233,8 +268,8 @@ Section fixed. exists (dbody x), (dbody y). split; [|easy]. split; [easy|]. - eapply context_change_decl_types_red; eauto. - eapply fix_context_change_decl_types; eauto. + eapply PCUICRedTypeIrrelevance.context_pres_let_bodies_red; eauto. + eapply PCUICRedTypeIrrelevance.fix_context_pres_let_bodies; eauto. Qed. Lemma conv_cum_tProj_inv leq Γ p c p' c' : diff --git a/pcuic/theories/PCUICConversion.v b/pcuic/theories/PCUICConversion.v index 527ce3503..04d3a71dc 100644 --- a/pcuic/theories/PCUICConversion.v +++ b/pcuic/theories/PCUICConversion.v @@ -1,8 +1,9 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICTyping +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICLiftSubst PCUICTyping PCUICSubstitution PCUICPosition PCUICCumulativity PCUICReduction PCUICConfluence PCUICClosed PCUICParallelReductionConfluence PCUICEquality + PCUICSigmaCalculus PCUICContextReduction PCUICContextConversion PCUICWeakening PCUICUnivSubst PCUICUnivSubstitution . @@ -13,8 +14,6 @@ Require Import Equations.Prop.DepElim. Set Default Goal Selector "!". - -Ltac tc := try typeclasses eauto 10. Ltac pcuic := intuition eauto 5 with pcuic || (try solve [repeat red; cbn in *; intuition auto; eauto 5 with pcuic || (try lia || congruence)]). @@ -31,86 +30,6 @@ Proof. intros HP. induction l; constructor; auto. Qed. -(** Remark that confluence is needed for transitivity of conv and cumul. *) - -Instance conv_trans {cf:checker_flags} (Σ : global_env_ext) {Γ} : - wf Σ -> Transitive (conv Σ Γ). -Proof. - intros wfΣ t u v X0 X1. - eapply conv_alt_red in X0 as [t' [u' [[tt' uu'] eq]]]. - eapply conv_alt_red in X1 as [u'' [v' [[uu'' vv'] eq']]]. - eapply conv_alt_red. - destruct (red_confluence wfΣ uu' uu'') as [u'nf [ul ur]]. - eapply red_eq_term_upto_univ_r in ul as [tnf [redtnf ?]]; tea; tc. - eapply red_eq_term_upto_univ_l in ur as [unf [redunf ?]]; tea; tc. - exists tnf, unf. - intuition auto. - - now transitivity t'. - - now transitivity v'. - - now transitivity u'nf. -Qed. - -Instance cumul_trans {cf:checker_flags} (Σ : global_env_ext) Γ : - wf Σ -> Transitive (cumul Σ Γ). -Proof. - intros wfΣ t u v X X0. - eapply cumul_alt in X as [v' [v'' [[redl redr] eq]]]. - eapply cumul_alt in X0 as [w [w' [[redl' redr'] eq']]]. - destruct (red_confluence wfΣ redr redl') as [nf [nfl nfr]]. - eapply cumul_alt. - eapply red_eq_term_upto_univ_r in eq. all:tc;eauto with pcuic. - destruct eq as [v'0 [red'0 eq2]]. - eapply red_eq_term_upto_univ_l in eq'; tc;eauto with pcuic. - destruct eq' as [v'1 [red'1 eq1]]. - exists v'0, v'1. - split. 1: split. - - transitivity v' ; auto. - - transitivity w' ; auto. - - eapply leq_term_trans with nf; eauto. -Qed. - -Instance conv_context_trans {cf:checker_flags} Σ : - wf Σ.1 -> Transitive (fun Γ Γ' => conv_context Σ Γ Γ'). -Proof. - intros wfΣ. - eapply context_relation_trans. - intros. - depelim X2; depelim X3; try constructor; auto. - * etransitivity; eauto. - * etransitivity. - + eapply conv_trans; eauto. - + eapply conv_conv_ctx => //. - - apply c0. - - apply conv_context_sym => //. - * etransitivity; eauto. - * eapply conv_trans; eauto. - eapply conv_conv_ctx => //. - + apply c1. - + apply conv_context_sym => //. - * etransitivity; eauto. - apply conv_context_sym in X; auto. - eapply conv_conv_ctx; eauto. -Qed. - -Instance cumul_context_trans {cf:checker_flags} Σ : - wf Σ.1 -> Transitive (fun Γ Γ' => cumul_context Σ Γ Γ'). -Proof. - intros wfΣ. - eapply context_relation_trans. - intros. - depelim X2; depelim X3; try constructor; auto. - * etransitivity; eauto. - * etransitivity; eauto. - eapply cumul_cumul_ctx; eauto. - * etransitivity; eauto. - * eapply conv_trans; eauto. - eapply conv_cumul_ctx => //. - + apply c1. - + assumption. - * etransitivity; eauto. - eapply cumul_cumul_ctx; eauto. -Qed. - Section EquivalenceConvCumulDefs. Context {cf:checker_flags} (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context). @@ -215,6 +134,44 @@ Proof. + constructor; auto. reflexivity. Qed. +Lemma congr_conv_prod_l : forall `{checker_flags} Σ Γ na na' M1 M2 N1, + wf Σ.1 -> + eq_binder_annot na na' -> + Σ ;;; Γ |- M1 = N1 -> + Σ ;;; Γ |- (tProd na M1 M2) = (tProd na' N1 M2). +Proof. + intros. + eapply conv_alt_red in X0 as (dom & dom' & (rdom & rdom') & eqdom). + eapply conv_alt_red. + exists (tProd na dom M2), (tProd na' dom' M2). + split; [split| auto]. + - eapply red_prod; eauto. + - eapply red_prod; eauto. + - constructor; [assumption|apply eqdom|reflexivity]. +Qed. + +Lemma congr_conv_prod : forall `{checker_flags} Σ Γ na na' M1 M2 N1 N2, + wf Σ.1 -> + eq_binder_annot na na' -> + Σ ;;; Γ |- M1 = N1 -> + Σ ;;; (Γ ,, vass na M1) |- M2 = N2 -> + Σ ;;; Γ |- (tProd na M1 M2) = (tProd na' N1 N2). +Proof. + intros * wfΣ ? ?. + transitivity (tProd na' N1 M2). + - eapply congr_conv_prod_l; eauto. + - eapply (conv_conv_ctx _ _ (Γ ,, vass na' N1)) in X0. + 2:{ constructor; [apply conv_ctx_refl|constructor; auto]. } + clear X. + eapply conv_alt_red in X0 as (codom & codom' & (rcodom & rcodom') & eqcodom). + eapply conv_alt_red. + exists (tProd na' N1 codom), (tProd na' N1 codom'). + split; [split|]. + + eapply red_prod; eauto. + + eapply red_prod; auto. + + constructor; auto. reflexivity. +Qed. + Lemma cumul_Sort_inv {cf:checker_flags} Σ Γ s s' : Σ ;;; Γ |- tSort s <= tSort s' -> leq_universe (global_ext_constraints Σ) s s'. @@ -347,7 +304,7 @@ Lemma conv_Prod_l_inv {cf:checker_flags} (Σ : global_env_ext) Γ na dom codom T wf Σ -> Σ ;;; Γ |- tProd na dom codom = T -> ∑ na' dom' codom', red Σ Γ T (tProd na' dom' codom') * - (Σ ;;; Γ |- dom = dom') * (Σ ;;; Γ ,, vass na dom |- codom = codom'). + (eq_binder_annot na na') * (Σ ;;; Γ |- dom = dom') * (Σ ;;; Γ ,, vass na dom |- codom = codom'). Proof. intros wfΣ H; depind H; auto. - inv e. exists na', a', b'; intuition eauto; constructor; auto. @@ -483,9 +440,8 @@ Proof. now eapply red_conv, red1_red. * eapply cumul_red_ctx_inv. 1: auto. 1: eauto. constructor. - -- eapply All2_local_env_red_refl. - -- reflexivity. - -- red. now eapply red1_red. + -- eapply All2_fold_red_refl. + -- constructor. constructor; auto. + destruct (IHcumul na na' _ _ _ _ wfΣ eq_refl) as [? [? ?]]. splits; auto. eapply cumul_trans with N2; auto. @@ -495,7 +451,7 @@ Qed. Section Inversions. Context {cf : checker_flags}. Context (Σ : global_env_ext). - Context (wfΣ : wf Σ). + Context {wfΣ : wf Σ}. Definition Is_conv_to_Arity Σ Γ T := exists T', ∥ red Σ Γ T T' ∥ /\ isArity T'. @@ -605,11 +561,10 @@ Section Inversions. do 2 eexists. repeat split; eauto with pcuic. + now transitivity x. + transitivity x0; auto. - eapply PCUICConfluence.red_red_ctx. 1: auto. 1: eauto. + eapply red_red_ctx_inv. 1: auto. 1: eauto. constructor. - * eapply All2_local_env_red_refl. - * reflexivity. - * red. auto. + * eapply All2_fold_red_refl. + * constructor; auto. Qed. Lemma invert_cumul_prod_r Γ C na A B : @@ -795,6 +750,8 @@ Section Inversions. + now constructor; apply leqvv'2. Qed. + Hint Constructors All_decls conv_decls cumul_decls : core. + Lemma invert_red_letin Γ C na d ty b : red Σ.1 Γ (tLetIn na d ty b) C -> (∑ d' ty' b', @@ -815,17 +772,15 @@ Section Inversions. - solve_discr. - left. do 3 eexists. repeat split; eauto with pcuic. * now transitivity r. - * eapply PCUICConfluence.red_red_ctx; eauto. - simpl. constructor; auto using All2_local_env_red_refl. - simpl. split; auto. + * eapply red_red_ctx_inv; eauto. + simpl. constructor; auto using All2_fold_red_refl. - right; auto. transitivity (b {0 := r}); auto. eapply (red_red _ _ [vass na ty] []); eauto. constructor. constructor. - left. do 3 eexists. repeat split; eauto with pcuic. * now transitivity r. - * eapply PCUICConfluence.red_red_ctx; eauto. - simpl. constructor; auto using All2_local_env_red_refl. - simpl. split; auto. + * eapply red_red_ctx_inv; eauto. + simpl. constructor; auto using All2_fold_red_refl. - right; auto. - left. do 3 eexists. repeat split; eauto with pcuic. now transitivity r. @@ -959,7 +914,7 @@ Section Inversions. subst. dependent destruction e. eexists _,_. split ; eauto. split ; auto. - - now rewrite (All2_length _ _ ha). + - now rewrite (All2_length ha). - eapply All2_trans. * intros x y z h1 h2. eapply conv_trans ; eauto. * eapply All2_impl ; eauto. @@ -983,7 +938,7 @@ Section Inversions. subst. dependent destruction e. eexists _,_. split ; eauto. split ; auto. - - rewrite (All2_length _ _ a); auto. + - rewrite (All2_length a); auto. - eapply All2_trans. * intros x y z h1 h2. eapply conv_trans ; eauto. * eapply All2_impl ; eauto. @@ -994,22 +949,13 @@ Section Inversions. End Inversions. -Lemma assumption_context_app Γ Γ' : - assumption_context (Γ' ,,, Γ) -> - assumption_context Γ * assumption_context Γ'. -Proof. - induction Γ; simpl; split; try constructor; auto. - - depelim H. constructor; auto. now eapply IHΓ. - - depelim H. now eapply IHΓ. -Qed. - (* Unused... *) Lemma it_mkProd_or_LetIn_ass_inv {cf : checker_flags} (Σ : global_env_ext) Γ ctx ctx' s s' : wf Σ -> assumption_context ctx -> assumption_context ctx' -> Σ ;;; Γ |- it_mkProd_or_LetIn ctx (tSort s) <= it_mkProd_or_LetIn ctx' (tSort s') -> - context_relation (fun ctx ctx' => conv_decls Σ (Γ ,,, ctx) (Γ ,,, ctx')) ctx ctx' * + All2_fold (fun ctx ctx' => conv_decls Σ (Γ ,,, ctx) (Γ ,,, ctx')) ctx ctx' * leq_term Σ.1 Σ (tSort s) (tSort s'). Proof. intros wfΣ. @@ -1047,10 +993,10 @@ Proof. specialize (IHctx (Γ ,, vass na' ty') l0 s s' H H0 Hcodom). clear IHctx'. intuition auto. - eapply context_relation_app_inv. - ** eapply (context_relation_length a). + eapply All2_fold_app. + ** eapply (All2_fold_length a). ** constructor; [constructor|constructor; auto]. - ** unshelve eapply (context_relation_impl a). + ** unshelve eapply (All2_fold_impl a). simpl; intros Γ0 Γ' d d'. rewrite !app_context_assoc. intros X; destruct X. @@ -1073,37 +1019,26 @@ Lemma cumul_Prod_inv {cf:checker_flags} Σ Γ na na' A B A' B' : Σ ;;; Γ |- tProd na A B <= tProd na' A' B' -> (eq_binder_annot na na' * (Σ ;;; Γ |- A = A') * (Σ ;;; Γ ,, vass na' A' |- B <= B'))%type. Proof. - intros wfΣ wfΓ H; depind H. - - depelim l. - splits; auto. - all: now constructor. - - - depelim r. - + solve_discr. - + specialize (IHcumul _ _ _ _ _ _ wfΣ wfΓ eq_refl). - intuition auto. - econstructor 2; eauto. - + specialize (IHcumul _ _ _ _ _ _ wfΣ wfΓ eq_refl). - intuition auto. apply cumul_trans with N2. - * auto. - * eapply cumul_conv_ctx; eauto. - -- econstructor 2. 1: eauto. - constructor. reflexivity. - -- constructor. 1: now apply conv_ctx_refl. - constructor; auto. - * auto. + intros wfΣ wfΓ H. + now eapply cumul_Prod_Prod_inv in H. +Qed. - - depelim r. - + solve_discr. - + specialize (IHcumul _ _ _ _ _ _ wfΣ wfΓ eq_refl). - intuition auto. - * econstructor 3. 2:eauto. auto. - * eapply cumul_conv_ctx in b. 1: eauto. 1: auto. - constructor. 1: eapply conv_ctx_refl. - constructor; auto. eapply conv_sym; auto. - + specialize (IHcumul _ _ _ _ _ _ wfΣ wfΓ eq_refl). - intuition auto. apply cumul_trans with N2. 1-2: auto. - eapply cumul_red_r; eauto. reflexivity. +(** Injectivity of products for conversion holds as well *) +Lemma conv_Prod_inv {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ na na' A B A' B'} : + wf_local Σ Γ -> + Σ ;;; Γ |- tProd na A B = tProd na' A' B' -> + (eq_binder_annot na na' * (Σ ;;; Γ |- A = A') * (Σ ;;; Γ ,, vass na' A' |- B = B'))%type. +Proof. + intros wfΓ H. + eapply conv_Prod_l_inv in H as [na'' [dom' [codom' [[[red eqann] eqd] eqcod]]]]; tea. + eapply invert_red_prod in red as [A'' [B'' [[eqp reddom] redcod]]]; tea. + noconf eqp. intuition auto. + - transitivity dom' => //. symmetry; now apply red_conv. + - transitivity codom' => //. + 2:symmetry; now apply red_conv. + eapply conv_conv_ctx; tea. constructor; try reflexivity. + constructor; auto. transitivity dom' => //. + now symmetry; apply red_conv. Qed. Lemma tProd_it_mkProd_or_LetIn na A B ctx s : @@ -1240,7 +1175,8 @@ Section Inversions. econstructor. assumption. Qed. - Global Instance conv_cum_refl {leq Γ} : + #[global] + Instance conv_cum_refl {leq Γ} : RelationClasses.Reflexive (conv_cum leq Σ Γ). Proof. destruct leq; constructor; reflexivity. @@ -1255,7 +1191,8 @@ Section Inversions. constructor. now eapply conv_cumul. Qed. - Global Instance conv_cum_trans {leq Γ} : + #[global] + Instance conv_cum_trans {leq Γ} : RelationClasses.Transitive (conv_cum leq Σ Γ). Proof. intros u v w h1 h2. destruct leq; cbn in *; sq; etransitivity; eassumption. @@ -1279,6 +1216,40 @@ Section Inversions. - reflexivity. - etransitivity; tea. Qed. + + Lemma conv_red_conv Γ Γ' t tr t' t'r : + conv_context Σ Γ Γ' -> + red Σ Γ t tr -> + red Σ Γ' t' t'r -> + Σ ;;; Γ |- tr = t'r -> + Σ ;;; Γ |- t = t'. + Proof. + intros cc r r' ct. + eapply red_conv_conv; eauto. + eapply conv_conv_ctx; eauto. + 2: apply conv_context_sym; eauto. + apply conv_sym. + eapply red_conv_conv; eauto. + apply conv_sym. + eapply conv_conv_ctx; eauto. + Qed. + + Lemma conv_red_conv_inv Γ Γ' t tr t' t'r : + conv_context Σ Γ Γ' -> + red Σ Γ t tr -> + red Σ Γ' t' t'r -> + Σ ;;; Γ |- tr = t'r -> + Σ ;;; Γ |- t = t'. + Proof. + intros conv_ctx r1 r2 cc. + eapply red_conv_conv; eauto. + apply conv_sym. + eapply conv_conv_ctx; eauto. + 2: apply conv_context_sym; eauto. + eapply red_conv_conv; eauto. + eapply conv_conv_ctx; eauto. + apply conv_sym; auto. + Qed. Lemma conv_cum_Prod leq Γ na1 na2 A1 A2 B1 B2 : eq_binder_annot na1 na2 -> @@ -1315,13 +1286,12 @@ Section Inversions. split; constructor. 1: assumption. etransitivity. 1: apply red_conv, redB. eapply conv_conv_ctx. 1,2 : eassumption. - apply ctx_rel_vass. 1: reflexivity. - now constructor. + constructor. 1: reflexivity. constructor; now symmetry. - intros [[eqann [eqA cumB]]%cumul_Prod_Prod_inv]. 2: assumption. split; auto; split; constructor. 1: assumption. eapply cumul_conv_ctx. 1,2: eassumption. - apply ctx_rel_vass. 1: reflexivity. - now constructor. + constructor; [reflexivity|]. + constructor; now symmetry. Qed. Lemma conv_cum_conv_ctx leq Γ Γ' T U : @@ -1437,12 +1407,10 @@ Section Inversions. Proof. intros Γ [ind n] p brs u v h. induction h. - - constructor. constructor. - + eapply eq_term_refl. - + assumption. + - constructor. constructor; auto. + + reflexivity. + eapply All2_same. - intros. split ; eauto. - reflexivity. + intros. split ; reflexivity. - eapply cumul_red_l ; eauto. constructor. assumption. - eapply cumul_red_r ; eauto. @@ -1500,23 +1468,168 @@ Section Inversions. - simpl. apply IHcuv. now apply App_conv. Qed. + + Definition conv_context_rel Γ Δ Δ' := + All2_fold (fun Γ' _ => All_decls_alpha (fun x y => Σ ;;; Γ ,,, Γ' |- x = y)) Δ Δ'. + + Definition conv_predicate Γ p p' := + All2 (conv Σ Γ) p.(pparams) p'.(pparams) × + R_universe_instance (eq_universe Σ) (puinst p) (puinst p') + × conv_context_rel Γ (pcontext p) (pcontext p') + × conv Σ (Γ ,,, pcontext p) (preturn p) (preturn p'). + + #[global] + Instance all_eq_term_refl : Reflexive (All2 (eq_term_upto_univ Σ.1 (eq_universe Σ) (eq_universe Σ))). + Proof. + intros x. apply All2_same. intros. reflexivity. + Qed. + Definition set_puinst (p : predicate term) (puinst : Instance.t) : predicate term := + {| pparams := p.(pparams); + 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 := + eq_refl. + + #[global] + Instance red_decls_refl Γ Δ : Reflexive (red_decls Σ Γ Δ). + Proof. + intros x. apply red_decls_refl. + Qed. - Lemma conv_Case_p : - forall Γ indn c brs u v, - Σ ;;; Γ |- u = v -> - Σ ;;; Γ |- tCase indn u c brs = tCase indn v c brs. + #[global] + Instance red_ctx_refl : Reflexive (All2_fold (red_decls Σ)). Proof. - intros Γ [ind n] c brs u v h. - induction h. - - constructor. constructor. - + assumption. - + eapply eq_term_refl. - + eapply All2_same. - intros. split ; eauto. reflexivity. - - eapply conv_red_l ; eauto. - constructor. assumption. - - eapply conv_red_r ; eauto. - constructor. assumption. + intros x. eapply All2_fold_refl. intros. apply red_decls_refl. + Qed. + Lemma red_context_rel_app Γ Δ Δ' : + red_context_rel Σ Γ Δ Δ' <~> red_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). + Proof. + split; intros h. + - eapply All2_fold_app. + + apply (length_of h). + + reflexivity. + + apply h. + - apply All2_fold_app_inv in h as [] => //. + pose proof (length_of h). len in H. lia. + Qed. + + Lemma conv_context_rel_app {Γ Δ Δ'} : + conv_context_rel Γ Δ Δ' <~> conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). + Proof. + split; intros h. + + eapply All2_fold_app => //. + * now apply (length_of h). + * reflexivity. + * eapply All2_fold_impl; tea. + intros ???? []; constructor; auto. + + eapply All2_fold_app_inv in h as []. + 2:{ move: (length_of h). len; lia. } + eapply All2_fold_impl; tea => /=. + intros ???? []; constructor; auto. + Qed. + + Lemma conv_context_red_context Γ Γ' Δ Δ' : + conv_context Σ (Γ ,,, Δ) (Γ' ,,, Δ') -> + #|Γ| = #|Γ'| -> + ∑ Δ1 Δ1', red_ctx_rel Σ Γ Δ Δ1 * red_ctx_rel Σ Γ' Δ' Δ1' * + eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Δ1 Δ1'. + Proof. + intros. + pose proof (length_of X). len in H0. + eapply conv_context_red_context in X as [Δ1 [Δ1' [[redl redr] eq]]]; auto. + exists (firstn #|Δ| Δ1), (firstn #|Δ'| Δ1'). + have l := (length_of redl). len in l. + have l' := (length_of redr). len in l'. + intuition auto. + - eapply red_ctx_rel_red_context_rel => //. + rewrite -(firstn_skipn #|Δ| Δ1) in redl. + eapply All2_fold_app_inv in redl as []. + * red. eapply All2_fold_impl; tea => /= //. + intros ???? []; constructor; auto. + * rewrite firstn_length_le //. + pose proof (length_of redl). + rewrite firstn_skipn in H1. + len in H0. lia. + - eapply red_ctx_rel_red_context_rel => //. + rewrite -(firstn_skipn #|Δ'| Δ1') in redr. + eapply All2_fold_app_inv in redr as []. + * red. eapply All2_fold_impl; tea => /= //. + intros ???? []; constructor; auto. + * rewrite firstn_length_le //. lia. + - rewrite -(firstn_skipn #|Δ'| Δ1') in eq. + rewrite -(firstn_skipn #|Δ| Δ1) in eq. + eapply All2_fold_app_inv in eq as [] => //. + rewrite !firstn_length_le => //; try lia. + Qed. + + Lemma conv_Case_p : + forall Γ ci c brs p p', + conv_predicate Γ p p' -> + Σ ;;; Γ |- tCase ci p c brs = tCase ci p' c brs. + Proof. + intros Γ ci c brs p p' [cpars [cu [cctx cret]]]. + set (pred := p). + destruct p, p'; simpl in *. + transitivity (tCase ci (set_pparams pred pparams0) c brs). + { clear -wfΣ cpars. + eapply All2_many_OnOne2 in cpars. + induction cpars. + * reflexivity. + * etransitivity; [tea|]. + + eapply OnOne2_split in r as [? [? [? [? [conv [-> ->]]]]]]. + clear -conv. + induction conv. + { do 2 constructor; try reflexivity. + 2:apply All2_same; split; reflexivity. + red; intuition try reflexivity. + simpl. eapply All2_app; try reflexivity. + constructor; auto; reflexivity. } + { eapply conv_red_l; eauto. + rewrite -[set_pparams _ (x1 ++ v :: _)](set_pparams_two (x1 ++ t :: x2)). + eapply case_red_param; simpl. + eapply OnOne2_app. now constructor. } + { eapply conv_red_r; eauto. + rewrite -[set_pparams _ (x1 ++ v :: _)](set_pparams_two (x1 ++ u :: x2)). + eapply case_red_param; simpl. + eapply OnOne2_app. now constructor. } } + transitivity (tCase ci (set_puinst (set_pparams pred pparams0) puinst0) c brs). + { do 2 constructor; try reflexivity. + 2:apply All2_same; split; reflexivity. + red; intuition try reflexivity. } + transitivity (tCase ci (set_preturn (set_puinst (set_pparams pred pparams0) puinst0) preturn0) c brs). + { clear -wfΣ cret. + rewrite /pred /set_puinst /set_pparams /set_pcontext /set_preturn; cbn. + induction cret. + - do 2 constructor; try reflexivity. + * red; intuition auto; try reflexivity. + * eapply All2_same; split; reflexivity. + - eapply conv_red_l. + * eapply case_red_return. simpl; tea. + * eapply IHcret. + - eapply conv_red_r; revgoals. + * eapply case_red_return; tea. + * eapply IHcret. + } + transitivity (tCase ci (set_pcontext (set_preturn (set_puinst (set_pparams pred pparams0) puinst0) preturn0) pcontext0) c brs). + { clear -wfΣ cctx. rewrite /pred /set_puinst /set_pparams /set_pcontext; cbn. + apply conv_context_rel_app in cctx. + eapply conv_context_red_context in cctx as [Δ [Δ' [[redl redr] eqc]]] => //. + transitivity (tCase ci {| + pparams := pparams0; + puinst := puinst0; + pcontext := Δ; + preturn := preturn0 |} c brs). + + eapply red_conv. now eapply red_case_pcontext_red_ctx_rel. + + etransitivity. + 2:{ symmetry. eapply red_conv. + eapply red_case_pcontext_red_ctx_rel; simpl; tea. } + rewrite /set_pcontext /=. + do 2 constructor; try reflexivity. + 2:eapply All2_same; split; reflexivity. + red; intuition auto; simpl; try reflexivity. } + reflexivity. Qed. Lemma conv_Case_c : @@ -1526,11 +1639,10 @@ Section Inversions. Proof. intros Γ [ind n] p brs u v h. induction h. - - constructor. constructor. - + eapply eq_term_refl. - + assumption. + - constructor. constructor; auto. + + reflexivity. + eapply All2_same. - intros. split ; eauto. reflexivity. + intros. split ; eauto; reflexivity. - eapply conv_red_l ; eauto. constructor. assumption. - eapply conv_red_r ; eauto. @@ -1539,48 +1651,69 @@ Section Inversions. Lemma conv_Case_one_brs : forall Γ indn p c brs brs', - OnOne2 (fun u v => u.1 = v.1 × Σ ;;; Γ |- u.2 = v.2) brs brs' -> + OnOne2 (fun u v => conv_context Σ (Γ ,,, u.(bcontext)) (Γ ,,, v.(bcontext)) × + Σ ;;; (Γ ,,, u.(bcontext)) |- u.(bbody) = v.(bbody)) brs brs' -> Σ ;;; Γ |- tCase indn p c brs = tCase indn p c brs'. Proof. - intros Γ [ind n] p c brs brs' h. + intros Γ ci p c brs brs' h. apply OnOne2_split in h as [[m br] [[m' br'] [l1 [l2 [[? h] [? ?]]]]]]. simpl in *. subst. - induction h. - - constructor. constructor. - + reflexivity. - + reflexivity. - + apply All2_app. - * apply All2_same. intros. intuition reflexivity. - * constructor. - -- simpl. intuition reflexivity. - -- apply All2_same. intros. intuition reflexivity. - - eapply conv_red_l ; eauto. - constructor. apply OnOne2_app. constructor. simpl. - intuition eauto. - - eapply conv_red_r ; eauto. - constructor. apply OnOne2_app. constructor. simpl. - intuition eauto. - Qed. + eapply conv_context_red_context in a as [Δ [Δ' [[redl redr] eqc]]] => //. + transitivity (tCase ci p c (l1 ++ {| bcontext := m; bbody := br' |} :: l2)). + { induction h. + * do 2 constructor; eauto; try reflexivity. + eapply All2_app. + + eapply All2_same; split; reflexivity. + + constructor; cbn; try split; auto; try reflexivity. + eapply All2_same; split; reflexivity. + * eapply conv_red_l; eauto. + econstructor. eapply OnOne2_app. constructor; cbn; auto. + * eapply conv_red_r; eauto. + econstructor. eapply OnOne2_app. constructor; cbn; eauto. } + transitivity (tCase ci p c (l1 ++ {| bcontext := Δ; bbody := br' |} :: l2)). + - eapply red_conv. eapply red_case_one_brs. + eapply OnOne2_app. constructor; cbn. + right. split => //. + - etransitivity. + 2:{ symmetry. eapply red_conv. + eapply red_case_one_brs; simpl; tea. + instantiate (1 := l1 ++ {| bcontext := Δ'; bbody := br' |} :: l2). + eapply OnOne2_app; constructor; cbn. + right; split => //. } + do 2 constructor; try reflexivity. + eapply All2_app. + * eapply All2_same; split; reflexivity. + * constructor; cbn. + + split => //; reflexivity. + + eapply All2_same; split; reflexivity. + Qed. + + Definition conv_brs Γ := + All2 (fun u v => + conv_context_rel Γ (bcontext u) (bcontext v) × + Σ ;;; Γ ,,, bcontext u |- bbody u = bbody v). Lemma conv_Case_brs : forall Γ indn p c brs brs', - All2 (fun u v => u.1 = v.1 × Σ ;;; Γ |- u.2 = v.2) brs brs' -> + conv_brs Γ brs brs' -> Σ ;;; Γ |- tCase indn p c brs = tCase indn p c brs'. Proof. - intros Γ [ind n] p c brs brs' h. + intros Γ ci p c brs brs' h. apply All2_many_OnOne2 in h. induction h. - reflexivity. - etransitivity. + eassumption. - + apply conv_Case_one_brs. assumption. + + apply conv_Case_one_brs. + eapply OnOne2_impl; tea => /=. + now move=> ? ? []; move/conv_context_rel_app. Qed. Lemma conv_Case : forall Γ indn p p' c c' brs brs', - Σ ;;; Γ |- p = p' -> + conv_predicate Γ p p' -> Σ ;;; Γ |- c = c' -> - All2 (fun u v => u.1 = v.1 × Σ ;;; Γ |- u.2 = v.2) brs brs' -> + conv_brs Γ brs brs' -> Σ ;;; Γ |- tCase indn p c brs = tCase indn p' c' brs'. Proof. intros Γ [ind n] p p' c c' brs brs' hp hc hbrs. @@ -1698,8 +1831,8 @@ Section Inversions. - unfold fix_context_alt. eapply eq_context_upto_rev'. rewrite 2!mapi_app. cbn. eapply eq_context_upto_cat. - + constructor; auto. - * eapply eq_term_upto_univ_refl. all: auto. + + constructor; auto; revgoals. + * constructor; auto. eapply eq_term_upto_univ_refl. all: auto. * eapply eq_context_upto_refl; auto. + eapply eq_context_upto_refl; auto. } @@ -1759,7 +1892,7 @@ Section Inversions. eapply conv_eq_context_upto. 2: eassumption. eapply eq_context_impl. 4: eassumption. all:tc. - + eapply eq_ctx_trans. 1-2:tc. + + etransitivity. * eassumption. * apply OnOne2_split in r as [[na ty bo ra] [[na' ty' bo' ra'] [l1 [l2 [[? [? [? ?]]] [? ?]]]]]]. @@ -1772,8 +1905,8 @@ Section Inversions. -- eapply eq_context_upto_rev'. rewrite 2!mapi_app. cbn. eapply eq_context_upto_cat. - ++ constructor; tas. - ** eapply eq_term_upto_univ_refl. all: auto. + ++ constructor; tas; revgoals. + ** constructor; tas. eapply eq_term_upto_univ_refl. all: auto. ** eapply eq_context_upto_refl; auto. ++ eapply eq_context_upto_refl; auto. } @@ -1936,9 +2069,8 @@ Section Inversions. - unfold fix_context_alt. eapply eq_context_upto_rev'. rewrite 2!mapi_app. cbn. eapply eq_context_upto_cat. - + constructor. - * assumption. - * eapply eq_term_upto_univ_refl. all: auto. + + constructor; revgoals. + * constructor; auto. reflexivity. * eapply eq_context_upto_refl; auto. + eapply eq_context_upto_refl; auto. } @@ -1998,7 +2130,7 @@ Section Inversions. eapply conv_eq_context_upto. 2: eassumption. eapply eq_context_impl. 4: eassumption. all:tc. - + eapply eq_ctx_trans. 1-2:tc. + + etransitivity. * eassumption. * apply OnOne2_split in r as [[na ty bo ra] [[na' ty' bo' ra'] [l1 [l2 [[? [? []]] [? ?]]]]]]. @@ -2011,9 +2143,8 @@ Section Inversions. -- eapply eq_context_upto_rev'. rewrite 2!mapi_app. cbn. eapply eq_context_upto_cat. - ++ constructor. - ** assumption. - ** eapply eq_term_upto_univ_refl. all: auto. + ++ constructor; revgoals. + ** constructor; eauto. reflexivity. ** eapply eq_context_upto_refl; auto. ++ eapply eq_context_upto_refl; auto. } @@ -2267,16 +2398,16 @@ Section Inversions. conv_cum leq Σ Γ (it_mkLambda_or_LetIn Δ1 t1) (it_mkLambda_or_LetIn Δ2 t2). Proof. induction Δ1 in Δ2, t1, t2 |- *; intros X Y. - - apply context_relation_length in X. + - apply All2_fold_length in X. destruct Δ2; cbn in *; [trivial|]. rewrite app_length in X; lia. - - apply context_relation_length in X as X'. + - apply All2_fold_length in X as X'. destruct Δ2 as [|c Δ2]; simpl in *; [rewrite app_length in X'; lia|]. dependent destruction X. + eapply IHΔ1; tas; cbn. - inv c0. eapply conv_cum_Lambda; tea. - + eapply IHΔ1; tas; cbn. - inversion c0; subst; eapply conv_cum_LetIn; auto. + depelim c0. + * eapply conv_cum_Lambda; simpl; tea. + * eapply conv_cum_LetIn; simpl; tea. Qed. Lemma it_mkLambda_or_LetIn_conv Γ Δ1 Δ2 t1 t2 : @@ -2285,20 +2416,18 @@ Section Inversions. Σ ;;; Γ |- it_mkLambda_or_LetIn Δ1 t1 = it_mkLambda_or_LetIn Δ2 t2. Proof. induction Δ1 in Δ2, t1, t2 |- *; intros X Y. - - apply context_relation_length in X. + - apply All2_fold_length in X. destruct Δ2; cbn in *; [trivial|]. exfalso. rewrite app_length in X; lia. - - apply context_relation_length in X as X'. + - apply All2_fold_length in X as X'. destruct Δ2 as [|c Δ2]; simpl in *; [exfalso; rewrite app_length in X'; lia|]. dependent destruction X. - + eapply IHΔ1; tas; cbn. - inv c0. etransitivity. - * eapply conv_Lambda_r; tea. - * now eapply conv_Lambda_l. - + eapply IHΔ1; tas; cbn. - etransitivity. - * eapply conv_LetIn_bo; tea. - * inv c0. + + eapply IHΔ1; tas; cbn. depelim c0. + * etransitivity. + { eapply conv_Lambda_r; tea. } + now eapply conv_Lambda_l. + * etransitivity. + { eapply conv_LetIn_bo; tea. } etransitivity. ++ eapply conv_LetIn_tm; tea. ++ eapply conv_LetIn_ty with (na := na'); tea. reflexivity. @@ -2315,10 +2444,10 @@ Section Inversions. destruct IHX as [A2 [B2 [[-> ?] ?]]]. + eexists _, _; intuition eauto. 1: now eapply red_step with M'. - eapply PCUICConfluence.red_red_ctx; eauto. + eapply red_red_ctx_inv; eauto. constructor; auto. - * eapply All2_local_env_red_refl. - * red. auto. + * eapply All2_fold_red_refl. + * constructor; auto. + eexists _, _; intuition eauto. now eapply red_step with M'. Qed. @@ -2373,6 +2502,24 @@ Section Inversions. End Inversions. +Lemma conv_LetIn `{cf:checker_flags} Σ Γ na1 na2 t1 t2 A1 A2 u1 u2 : + wf Σ.1 -> + eq_binder_annot na1 na2 -> + Σ;;; Γ |- t1 = t2 -> + Σ;;; Γ |- A1 = A2 -> + conv Σ (Γ ,, vdef na1 t1 A1) u1 u2 -> + conv Σ Γ (tLetIn na1 t1 A1 u1) (tLetIn na2 t2 A2 u2). +Proof. + intros wfΣ Hna X H H'. + eapply conv_trans => //. + + eapply conv_LetIn_bo. eassumption. + + etransitivity. + * eapply conv_LetIn_tm; tea. + * eapply conv_LetIn_ty with (na := na2). + ++ reflexivity. + ++ assumption. +Qed. + Lemma cum_LetIn `{cf:checker_flags} Σ Γ na1 na2 t1 t2 A1 A2 u1 u2 : wf Σ.1 -> eq_binder_annot na1 na2 -> @@ -2457,11 +2604,6 @@ Proof. now symmetry. Qed. -Lemma subslet_untyped_subslet {cf:checker_flags} Σ Γ s Γ' : subslet Σ Γ s Γ' -> untyped_subslet Γ s Γ'. -Proof. - induction 1; constructor; auto. -Qed. - Lemma untyped_subst_conv {cf:checker_flags} {Σ} Γ Γ0 Γ1 Δ s s' T U : wf Σ.1 -> untyped_subslet Γ s Γ0 -> @@ -2502,18 +2644,18 @@ Proof. eapply conv_subst_conv => //; eauto using subslet_untyped_subslet. Qed. -Lemma context_relation_subst {cf:checker_flags} {Σ} Γ Γ0 Γ1 Δ Δ' s s' : +Lemma All2_fold_subst {cf:checker_flags} {Σ} Γ Γ0 Γ1 Δ Δ' s s' : wf Σ.1 -> wf_local Σ (Γ ,,, Γ0 ,,, Δ) -> subslet Σ Γ s Γ0 -> subslet Σ Γ s' Γ1 -> All2 (conv Σ Γ) s s' -> - context_relation - (fun Γ0 Γ' : PCUICAst.context => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) + All2_fold + (fun Γ0 Γ' : context => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) (Γ0 ,,, Δ) (Γ1 ,,, Δ') -> - context_relation - (fun Γ0 Γ' : PCUICAst.context => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) + All2_fold + (fun Γ0 Γ' : context => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) (subst_context s 0 Δ) (subst_context s' 0 Δ'). Proof. @@ -2521,7 +2663,7 @@ Proof. assert (hlen: #|Γ0| = #|Γ1|). { rewrite -(subslet_length subss) -(subslet_length subss'). now apply All2_length in eqsub. } - assert(clen := context_relation_length ctxr). + assert(clen := All2_fold_length ctxr). autorewrite with len in clen. rewrite hlen in clen. assert(#|Δ| = #|Δ'|) by lia. clear clen. @@ -2570,8 +2712,8 @@ Lemma conv_subst_instance {cf:checker_flags} (Σ : global_env_ext) Γ u A B univ valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) -> Σ ;;; Γ |- A = B -> - (Σ.1,univs) ;;; subst_instance_context u Γ - |- subst_instance_constr u A = subst_instance_constr u B. + (Σ.1,univs) ;;; subst_instance u Γ + |- subst_instance u A = subst_instance u B. Proof. intros HH X0. induction X0. - econstructor. @@ -2580,14 +2722,14 @@ Proof. - econstructor 3. 1: eauto. eapply red1_subst_instance; cbn; eauto. Qed. -Lemma context_relation_subst_instance {cf:checker_flags} {Σ} Γ Δ u u' : +Lemma All2_fold_subst_instance {cf:checker_flags} {Σ} Γ Δ u u' : wf Σ.1 -> - wf_local Σ Γ -> wf_local Σ (subst_instance_context u Δ) -> + wf_local Σ Γ -> wf_local Σ (subst_instance u Δ) -> R_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> - context_relation - (fun Γ0 Γ' : PCUICAst.context => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) - (subst_instance_context u Δ) - (subst_instance_context u' Δ). + All2_fold + (fun Γ0 Γ' => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) + (subst_instance u Δ) + (subst_instance u' Δ). Proof. move=> wfΣ wf wf0 equ. assert (cl := closed_wf_local wfΣ wf0). @@ -2600,32 +2742,29 @@ Proof. destruct d as [na [b|] ty] => /=. * depelim wf0; simpl in *. simpl in cld. unfold closed_decl in cld. simpl in cld. simpl. - apply andb_and in cld as [clb clty]. + apply andb_and in cld as [clb clty]. cbn. constructor; auto. constructor; [reflexivity|..]. ** apply weaken_conv; auto; autorewrite with len. 1:now rewrite closedn_subst_instance_context. - 1-2:now rewrite closedn_subst_instance_constr. + 1-2:now rewrite closedn_subst_instance. constructor. red. - apply eq_term_upto_univ_subst_instance_constr; try typeclasses eauto. auto. + apply eq_term_upto_univ_subst_instance; try typeclasses eauto. auto. ** constructor. red. - apply eq_term_upto_univ_subst_instance_constr; try typeclasses eauto. auto. + apply eq_term_upto_univ_subst_instance; try typeclasses eauto. auto. * depelim wf0; simpl in *. - simpl in cld. unfold closed_decl in cld. simpl in cld. simpl. + simpl in cld. unfold closed_decl in cld. simpl in cld. simpl. cbn. constructor; auto. constructor; [reflexivity|..]. apply weaken_conv; auto. 1:now rewrite closedn_subst_instance_context. - 1-2:autorewrite with len; now rewrite closedn_subst_instance_constr. + 1-2:autorewrite with len; now rewrite closedn_subst_instance. constructor. red. - apply eq_term_upto_univ_subst_instance_constr; try typeclasses eauto. auto. + apply eq_term_upto_univ_subst_instance; try typeclasses eauto. auto. Qed. -Definition conv_ctx_rel {cf:checker_flags} Σ Γ Δ Δ' := - All2_local_env (on_decl (fun Γ' _ x y => Σ ;;; Γ ,,, Γ' |- x = y)) Δ Δ'. - Lemma cumul_ctx_subst_instance {cf:checker_flags} {Σ} Γ Δ u u' : wf Σ.1 -> wf_local Σ Γ -> R_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> - cumul_ctx_rel Σ Γ (subst_instance_context u Δ) (subst_instance_context u' Δ). + cumul_ctx_rel Σ Γ (subst_instance u Δ) (subst_instance u' Δ). Proof. move=> wfΣ wf equ. induction Δ as [|d Δ]. @@ -2635,28 +2774,28 @@ Proof. * constructor; eauto. simpl. constructor. + reflexivity. + constructor. - eapply eq_term_upto_univ_subst_instance_constr; try typeclasses eauto; auto. + eapply eq_term_upto_univ_subst_instance; try typeclasses eauto; auto. + constructor. eapply eq_term_leq_term. - eapply eq_term_upto_univ_subst_instance_constr; try typeclasses eauto; auto. + eapply eq_term_upto_univ_subst_instance; try typeclasses eauto; auto. * constructor; auto. constructor; auto. simpl. constructor. - apply eq_term_upto_univ_subst_instance_constr; try typeclasses eauto. auto. + apply eq_term_upto_univ_subst_instance; try typeclasses eauto. auto. Qed. -Lemma context_relation_over_same {cf:checker_flags} Σ Γ Δ Δ' : - context_relation (fun Γ0 Γ' => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) Δ Δ' -> - context_relation (conv_decls Σ) (Γ ,,, Δ) (Γ ,,, Δ'). +Lemma All2_fold_over_same {cf:checker_flags} Σ Γ Δ Δ' : + All2_fold (fun Γ0 Γ' => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) Δ Δ' -> + All2_fold (conv_decls Σ) (Γ ,,, Δ) (Γ ,,, Δ'). Proof. induction 1; simpl; try constructor; pcuic. Qed. -Lemma context_relation_over_same_app {cf:checker_flags} Σ Γ Δ Δ' : - context_relation (conv_decls Σ) (Γ ,,, Δ) (Γ ,,, Δ') -> - context_relation (fun Γ0 Γ' => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) Δ Δ'. +Lemma All2_fold_over_same_app {cf:checker_flags} Σ Γ Δ Δ' : + All2_fold (conv_decls Σ) (Γ ,,, Δ) (Γ ,,, Δ') -> + All2_fold (fun Γ0 Γ' => conv_decls Σ (Γ ,,, Γ0) (Γ ,,, Γ')) Δ Δ'. Proof. - move=> H. pose (context_relation_length H). + move=> H. pose (All2_fold_length H). autorewrite with len in e. assert(#|Δ| = #|Δ'|) by lia. - move/context_relation_app: H => H. + move/All2_fold_app_inv: H => H. now specialize (H H0) as [_ H]. Qed. @@ -2695,7 +2834,10 @@ Lemma R_global_instance_length Σ Req Rle ref napp i i' : Proof. unfold R_global_instance. destruct global_variance. - { induction i in l, i' |- *; destruct l, i'; simpl; auto; try easy. } + { induction i in l, i' |- *; destruct l, i'; simpl; auto; try lia; try easy. + * specialize (IHi i' []). simpl in IHi. intuition. + * intros []. intuition. + } { unfold R_universe_instance. intros H % Forall2_length. now rewrite !map_length in H. } Qed. @@ -2709,7 +2851,7 @@ Qed. Lemma weakening_conv_gen : forall {cf : checker_flags} (Σ : global_env × universes_decl) - (Γ Γ' Γ'' : PCUICAst.context) (M N : term) k, + (Γ Γ' Γ'' : context) (M N : term) k, wf Σ.1 -> k = #|Γ''| -> Σ;;; Γ ,,, Γ' |- M = N -> Σ;;; Γ ,,, Γ'' ,,, lift_context k 0 Γ' |- lift k #|Γ'| M = lift k #|Γ'| N. @@ -2717,12 +2859,46 @@ Proof. intros; subst k; now eapply weakening_conv. Qed. -Lemma cumul_it_mkProd_or_LetIn {cf : checker_flags} (Σ : PCUICAst.global_env_ext) - (Δ Γ Γ' : PCUICAst.context) (B B' : term) : +Lemma conv_it_mkProd_or_LetIn {cf : checker_flags} (Σ : global_env_ext) + (Δ Γ Γ' : context) (B B' : term) : wf Σ.1 -> - context_relation (fun Γ Γ' => conv_decls Σ (Δ ,,, Γ) (Δ ,,, Γ')) Γ Γ' -> + All2_fold (fun Γ Γ' => conv_decls Σ (Δ ,,, Γ) (Δ ,,, Γ')) Γ Γ' -> + Σ ;;; Δ ,,, Γ |- B = B' -> + Σ ;;; Δ |- it_mkProd_or_LetIn Γ B = it_mkProd_or_LetIn Γ' B'. +Proof. + move=> wfΣ; move: B B' Γ' Δ. + induction Γ as [|d Γ] using rev_ind; move=> B B' Γ' Δ; + destruct Γ' as [|d' Γ'] using rev_ind; try clear IHΓ'; + move=> H; try solve [simpl; auto]. + + depelim H. apply app_eq_nil in H; intuition discriminate. + + depelim H. apply app_eq_nil in H; intuition discriminate. + + assert (clen : #|Γ| = #|Γ'|). + { apply All2_fold_length in H. + autorewrite with len in H; simpl in H. lia. } + apply All2_fold_app_inv in H as [cd cctx] => //. + depelim cd; depelim c. + - rewrite !it_mkProd_or_LetIn_app => //=. + simpl. move=> HB. apply congr_conv_prod => //. + eapply IHΓ. + * unshelve eapply (All2_fold_impl cctx). + simpl. intros * X. rewrite !app_context_assoc in X. + destruct X; constructor; auto. + * now rewrite app_context_assoc in HB. + - rewrite !it_mkProd_or_LetIn_app => //=. + simpl. intros HB. apply conv_LetIn => //; auto. + eapply IHΓ. + * unshelve eapply (All2_fold_impl cctx). + simpl. intros * X. rewrite !app_context_assoc in X. + destruct X; constructor; auto. + * now rewrite app_context_assoc in HB. +Qed. + +Lemma cumul_it_mkProd_or_LetIn {cf : checker_flags} (Σ : global_env_ext) + (Δ Γ Γ' : context) (B B' : term) : + wf Σ.1 -> + All2_fold (fun Γ Γ' => conv_decls Σ (Δ ,,, Γ) (Δ ,,, Γ')) Γ Γ' -> Σ ;;; Δ ,,, Γ |- B <= B' -> - Σ ;;; Δ |- PCUICAst.it_mkProd_or_LetIn Γ B <= PCUICAst.it_mkProd_or_LetIn Γ' B'. + Σ ;;; Δ |- it_mkProd_or_LetIn Γ B <= it_mkProd_or_LetIn Γ' B'. Proof. move=> wfΣ; move: B B' Γ' Δ. induction Γ as [|d Γ] using rev_ind; move=> B B' Γ' Δ; @@ -2731,21 +2907,21 @@ Proof. + depelim H. apply app_eq_nil in H; intuition discriminate. + depelim H. apply app_eq_nil in H; intuition discriminate. + assert (clen : #|Γ| = #|Γ'|). - { apply context_relation_length in H. + { apply All2_fold_length in H. autorewrite with len in H; simpl in H. lia. } - apply context_relation_app in H as [cd cctx] => //. + apply All2_fold_app_inv in H as [cd cctx] => //. depelim cd; depelim c. - rewrite !it_mkProd_or_LetIn_app => //=. simpl. move=> HB. apply congr_cumul_prod => //. eapply IHΓ. - * unshelve eapply (context_relation_impl cctx). + * unshelve eapply (All2_fold_impl cctx). simpl. intros * X. rewrite !app_context_assoc in X. destruct X; constructor; auto. * now rewrite app_context_assoc in HB. - rewrite !it_mkProd_or_LetIn_app => //=. simpl. intros HB. apply cum_LetIn => //; auto. eapply IHΓ. - * unshelve eapply (context_relation_impl cctx). + * unshelve eapply (All2_fold_impl cctx). simpl. intros * X. rewrite !app_context_assoc in X. destruct X; constructor; auto. * now rewrite app_context_assoc in HB. @@ -2892,44 +3068,40 @@ Proof. eapply cumul_subst_conv => //; eauto using subslet_untyped_subslet. Qed. -Lemma conv_ctx_subst {cf:checker_flags} Σ Γ Γ' Δ Δ' s s' : - wf Σ.1 -> - wf_local Σ (Γ ,,, Γ' ,,, Δ) -> - conv_ctx_rel Σ (Γ ,,, Γ') Δ Δ' -> - All2 (conv Σ []) s s' -> - subslet Σ [] s Γ -> - subslet Σ [] s' Γ -> - conv_ctx_rel Σ (subst_context s 0 Γ') (subst_context s #|Γ'| Δ) (subst_context s' #|Γ'| Δ'). +Lemma conv_ctx_subst {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ'0 Γ'' Δ Δ' s s'} : + wf_local Σ (Γ ,,, Γ' ,,, Γ'' ,,, Δ) -> + conv_context_rel Σ (Γ ,,, Γ' ,,, Γ'') Δ Δ' -> + All2 (conv Σ Γ) s s' -> + untyped_subslet Γ s Γ' -> + untyped_subslet Γ s' Γ'0 -> + conv_context_rel Σ (Γ ,,, subst_context s 0 Γ'') (subst_context s #|Γ''| Δ) (subst_context s' #|Γ''| Δ'). Proof. - intros wfΣ wf. induction 1. + intros wf. induction 1. - simpl. constructor. - rewrite !subst_context_snoc /=. intros Hs subs subs'. depelim wf. - specialize (IHX wf Hs subs subs'). - constructor; auto. - red. red in p. simpl. - epose proof (subst_conv [] Γ Γ (Γ' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs). - rewrite app_context_nil_l app_context_assoc in X0. - specialize (X0 wf p). - rewrite subst_context_app in X0; autorewrite with len in X0. - rewrite app_context_nil_l in X0. - now rewrite -(All2_local_env_length X). - - rewrite !subst_context_snoc /=. - intros Hs subs subs'. - depelim wf. - specialize (IHX wf Hs subs subs'). - constructor; auto. - red. red in p. simpl. - destruct p as [pb pt]. - epose proof (subst_conv [] Γ Γ (Γ' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs) as X0. - rewrite app_context_nil_l app_context_assoc in X0. - specialize (X0 wf pb). - epose proof (subst_conv [] Γ Γ (Γ' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs) as X1. - rewrite app_context_nil_l app_context_assoc in X1. - specialize (X1 wf pt). - rewrite !subst_context_app !app_context_nil_l in X0, X1; autorewrite with len in X0, X1. - now rewrite -(All2_local_env_length X). + * specialize (IHX wf Hs subs subs'). + depelim p. + constructor; auto. constructor; auto. simpl. + epose proof (untyped_subst_conv Γ Γ' Γ'0 (Γ'' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs). + rewrite app_context_assoc in X0. + specialize (X0 wf c). + rewrite !subst_context_app app_context_assoc in X0; autorewrite with len in X0. + now rewrite -(All2_fold_length X). + * specialize (IHX wf Hs subs subs'). + depelim p. + constructor; auto. constructor; auto. + + epose proof (untyped_subst_conv Γ Γ' Γ'0 (Γ'' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs) as X1. + rewrite !app_context_assoc in X1. + specialize (X1 wf c). + rewrite !subst_context_app !app_context_assoc in X1; autorewrite with len in X1. + now rewrite -(All2_fold_length X). + + epose proof (untyped_subst_conv Γ Γ' Γ'0 (Γ'' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs) as X0. + rewrite app_context_assoc in X0. + specialize (X0 wf c0). + rewrite !subst_context_app !app_context_assoc in X0; autorewrite with len in X0. + now rewrite -(All2_fold_length X). Qed. Lemma conv_terms_weaken {cf:checker_flags} Σ Γ Γ' args args' : @@ -2976,29 +3148,27 @@ Proof. - rewrite !subst_context_snoc /=. intros Hs subs subs'. depelim wf. - specialize (IHX wf Hs subs subs'). - depelim p. - constructor; auto. constructor; auto. simpl. - epose proof (untyped_subst_cumul Γ Γ' Γ'0 (Γ'' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs). - rewrite app_context_assoc in X0. - specialize (X0 wf c). - rewrite !subst_context_app app_context_assoc in X0; autorewrite with len in X0. - now rewrite -(context_relation_length X). - - rewrite !subst_context_snoc /=. - intros Hs subs subs'. depelim wf. - specialize (IHX wf Hs subs subs'). - depelim p. - constructor; auto. constructor; auto. + * specialize (IHX wf Hs subs subs'). + depelim p. + constructor; auto. constructor; auto. simpl. + epose proof (untyped_subst_cumul Γ Γ' Γ'0 (Γ'' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs). + rewrite app_context_assoc in X0. + specialize (X0 wf c). + rewrite !subst_context_app app_context_assoc in X0; autorewrite with len in X0. + now rewrite -(All2_fold_length X). + * specialize (IHX wf Hs subs subs'). + depelim p. + constructor; auto. constructor; auto. + epose proof (untyped_subst_conv Γ Γ' Γ'0 (Γ'' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs) as X1. rewrite !app_context_assoc in X1. specialize (X1 wf c). rewrite !subst_context_app !app_context_assoc in X1; autorewrite with len in X1. - now rewrite -(context_relation_length X). + now rewrite -(All2_fold_length X). + epose proof (untyped_subst_cumul Γ Γ' Γ'0 (Γ'' ,,, Γ0) _ _ _ _ wfΣ subs subs' Hs) as X0. rewrite app_context_assoc in X0. specialize (X0 wf c0). rewrite !subst_context_app !app_context_assoc in X0; autorewrite with len in X0. - now rewrite -(context_relation_length X). + now rewrite -(All2_fold_length X). Qed. Lemma cumul_ctx_rel_nth_error {cf:checker_flags} Σ Γ Δ Δ' : @@ -3018,7 +3188,6 @@ Proof. forward IHX by now depelim H. destruct (IHX _ _ Hnth) as [decl' [Hnth' cum]]. eexists; intuition eauto. - - move=> H; elimtype False; depelim H; simpl in H0; noconf H0. Qed. Require Import ssrbool. @@ -3026,13 +3195,7 @@ Require Import ssrbool. Lemma closed_ctx_decl k d Γ : closedn_ctx k (d :: Γ) = closed_decl (k + #|Γ|) d && closedn_ctx k Γ. Proof. - unfold closedn_ctx at 1. - rewrite mapi_rev /= forallb_app {2}/id /= andb_true_r. - replace (#|Γ| - 0) with #|Γ| by lia. - rewrite andb_comm. f_equal. - unfold closedn_ctx. - rewrite mapi_rev (mapi_rec_add _ _ 1 0) /=. - f_equal. + now simpl; rewrite andb_comm Nat.add_comm. Qed. Lemma weaken_cumul_ctx {cf:checker_flags} Σ Γ Γ' Δ Δ' : @@ -3045,30 +3208,155 @@ Lemma weaken_cumul_ctx {cf:checker_flags} Σ Γ Γ' Δ Δ' : Proof. intros wfΣ wf wf' wf''. induction 1. - simpl. constructor. - - rewrite /= closed_ctx_decl in wf. - rewrite /= closed_ctx_decl in wf'. - move/andb_and: wf => [wfd wf]. - move/andb_and: wf' => [wfd' wf']. - constructor; auto. - + now eapply IHX. - + depelim p. constructor; auto. - rewrite -app_context_assoc. - eapply weaken_cumul; eauto. - autorewrite with len; simpl; rewrite (context_relation_length X). - now autorewrite with len in wfd'. - - rewrite /= closed_ctx_decl in wf. - rewrite /= closed_ctx_decl in wf'. - move/andb_and: wf => [wfd wf]. - move/andb_and: wf' => [wfd' wf']. + - simpl in wf, wf'. + move/andb_and: wf => [wf wfd]. + move/andb_and: wf' => [wf' wfd']. constructor; auto. + now eapply IHX. - + move/andb_and: wfd => /= [wfb wft]. - move/andb_and: wfd' => /= [wfb' wft']. - autorewrite with len in *. - rewrite <- (context_relation_length X) in *. - depelim p; constructor; auto. - * rewrite -app_context_assoc. - apply weaken_conv; autorewrite with len; auto with pcuic. - * rewrite -app_context_assoc. - apply weaken_cumul; autorewrite with len; auto with pcuic. + + len in wfd; len in wfd'. + rewrite -(length_of X) in wfd'. + depelim p; constructor; auto; + rewrite -app_context_assoc; + (eapply weaken_cumul || eapply weaken_conv); eauto; + rewrite app_context_length; now move/andP: wfd => /=; move/andP: wfd' => /=. +Qed. + +Local Open Scope sigma_scope. +From MetaCoq.PCUIC Require Import PCUICParallelReduction. + +(* Lemma clos_rt_image {A B} (R : A -> A -> Type) (f g : B -> A) x y: + (forall x, R (f x) (g x)) -> + (forall x, R (f x) (g x)) -> + clos_refl_trans (fun x y => R (f x) (g y)) x y -> + clos_refl_trans R (f x) (g y). +Proof. + intros Hf. induction 1; try solve [econstructor; eauto]. + * econstructor 3. 2:tea. + econstructor 3; tea. + now rewrite -Hf. +Qed. *) + +Lemma strong_substitutivity_clos_rt {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ s t} σ τ : + ctxmap Γ Δ σ -> + ctxmap Γ Δ τ -> + pred1_subst Σ Γ Δ Δ σ τ -> + clos_refl_trans (pred1 Σ Γ Γ) s t -> + clos_refl_trans (pred1 Σ Δ Δ) s.[σ] t.[τ]. +Proof. + intros ctxm ctxm' ps h. + induction h in σ, τ, ctxm, ctxm', ps |- *. + * constructor 1. + now eapply strong_substitutivity. + * eapply strong_substitutivity in ps; tea. + 2:eapply pred1_refl. + constructor. apply ps. + * econstructor 3. + + eapply IHh1; tea. + + eapply IHh2; tea. + intros h. + split. + - eapply pred1_refl. + - destruct option_map as [[]|] => //. +Qed. +(* +Lemma red_strong_substitutivity {cf:checker_flags} {Σ} {wfΣ : wf Σ} Γ Δ s t σ τ : + red Σ Γ s t -> + ctxmap Γ Δ σ -> + ctxmap Γ Δ τ -> + (forall x, red Σ Γ (σ x) (τ x)) -> + red Σ Δ s.[σ] t.[τ]. +Proof. + intros r ctxm ctxm' IH. + eapply red_pred in r; eauto. + eapply (strong_substitutivity_clos_rt σ τ) in r; tea. + - eapply pred_red => //. + - intros x. +*) + +Lemma map_branches_k_map_branches_k + (f : nat -> term -> term) k + (f' : nat -> term -> term) k' + (l : list (branch term)) : + map_branches_k f k (map_branches_k f' k' l) = + map (map_branch_k (fun (i : nat) (x : term) => f (i + k) (f' (i + k') x)) 0) l. +Proof. + rewrite map_map. + eapply map_ext => b. + rewrite map_branch_k_map_branch_k. + auto. +Qed. + +Lemma red_rel_all {cf:checker_flags} Σ Γ i body t : + wf Σ -> + option_map decl_body (nth_error Γ i) = Some (Some body) -> + red Σ Γ t (lift 1 i (t {i := body})). +Proof. + intros wfΣ. + induction t using PCUICInduction.term_forall_list_ind in Γ, i |- *; intro H; cbn; + eauto using red_prod, red_abs, red_app, red_letin, red_proj_c. + - case_eq (i <=? n); intro H0. + + apply Nat.leb_le in H0. + case_eq (n - i); intros; cbn. + * apply red1_red. + rewrite simpl_lift; cbn; try lia. + assert (n = i) by lia; subst. now constructor. + * enough (nth_error (@nil term) n0 = None) as ->; + [cbn|now destruct n0]. + enough (i <=? n - 1 = true) as ->; try (apply Nat.leb_le; lia). + enough (S (n - 1) = n) as ->; try lia. auto. + + cbn. rewrite H0. auto. + - eapply red_evar. repeat eapply All2_map_right. + eapply All_All2; tea. intro; cbn; eauto. + - destruct X as (IHparams&IHctx&IHret). + rewrite map_predicate_k_map_predicate_k. + assert (ctxapp: forall Γ', + option_map decl_body (nth_error (Γ,,, Γ') (#|Γ'| + i)) = Some (Some body)). + { unfold app_context. + intros. + rewrite nth_error_app2; [lia|]. + rewrite minus_plus; auto. } + eapply red_case. + + rewrite Nat.add_0_r; eauto. + + apply red_ctx_rel_red_context_rel; auto. + clear -IHctx ctxapp. + induction IHctx; pcuic. + constructor; auto. + destruct p0 as (IHty&IHbody). + destruct x as [? [] ?]; unfold map_decl; cbn in *; constructor. + all: try rewrite Nat.add_0_r; eauto. + eapply IHbody. + rewrite Nat.add_0_r; eauto. + + induction IHparams; pcuic. + + apply IHt; auto. + + clear -wfΣ X0 ctxapp. + induction X0; pcuic. + constructor; auto. + destruct p as (IHctx&IHbody). + unfold on_Trel. + rewrite map_branch_k_map_branch_k. + split. + * eapply IHbody. + rewrite Nat.add_0_r. + eauto. + * unfold map_branch_k; cbn. + clear -wfΣ IHctx ctxapp. + eapply red_ctx_rel_red_context_rel; auto. + clear -IHctx ctxapp. + induction IHctx; pcuic. + constructor; auto. + destruct p as (IHty&IHbody). + destruct x0 as [? [] ?]; unfold map_decl; cbn in *; constructor. + all: try rewrite Nat.add_0_r; eauto. + eapply IHbody. + rewrite Nat.add_0_r; eauto. + - eapply red_fix_congr. repeat eapply All2_map_right. + eapply All_All2; tea. intros; cbn in *; rdest; eauto. + rewrite map_length. eapply r0. + rewrite nth_error_app_context_ge; rewrite fix_context_length; try lia. + enough (#|m| + i - #|m| = i) as ->; tas; lia. + - eapply red_cofix_congr. repeat eapply All2_map_right. + eapply All_All2; tea. intros; cbn in *; rdest; eauto. + rewrite map_length. eapply r0. + rewrite nth_error_app_context_ge; rewrite fix_context_length; try lia. + enough (#|m| + i - #|m| = i) as ->; tas; lia. Qed. diff --git a/pcuic/theories/PCUICCtxShape.v b/pcuic/theories/PCUICCtxShape.v deleted file mode 100644 index d00541a9f..000000000 --- a/pcuic/theories/PCUICCtxShape.v +++ /dev/null @@ -1,124 +0,0 @@ -From Coq Require Import CRelationClasses ProofIrrelevance. -From MetaCoq.Template Require Import config Universes utils BasicAst - AstUtils UnivSubst. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction - PCUICReflect PCUICLiftSubst PCUICUnivSubst PCUICTyping - PCUICCumulativity PCUICPosition PCUICEquality PCUICNameless - PCUICInversion PCUICCumulativity PCUICReduction - PCUICConfluence PCUICConversion PCUICContextConversion - PCUICParallelReductionConfluence PCUICWeakeningEnv - PCUICClosed PCUICSubstitution PCUICWeakening PCUICGeneration PCUICUtils. - -From Equations Require Import Equations. -Require Import Equations.Prop.DepElim. -Require Import Equations.Type.Relation_Properties. -Require Import ssreflect ssrbool. - - -Definition same_shape (d d' : context_decl) := - match decl_body d, decl_body d' with - | None, None => True - | Some _, Some _ => True - | _, _ => False - end. - -Definition same_ctx_shape (Γ Γ' : context) := - context_relation (fun _ _ => same_shape) Γ Γ'. - -Hint Unfold same_ctx_shape : core. - -Lemma same_ctx_shape_app Γ Γ' Δ Δ' : same_ctx_shape Γ Γ' -> - same_ctx_shape Δ Δ' -> - same_ctx_shape (Γ ++ Δ) (Γ' ++ Δ'). -Proof. - unfold same_ctx_shape. - induction 1; simpl; try constructor; eauto. -Qed. - -Lemma same_ctx_shape_rev Γ Γ' : same_ctx_shape Γ Γ' -> - same_ctx_shape (List.rev Γ) (List.rev Γ'). -Proof. - induction 1; simpl; try constructor. - apply same_ctx_shape_app; auto. repeat constructor. - apply same_ctx_shape_app; auto. repeat constructor. -Qed. - -Lemma to_extended_list_k_eq Γ Γ' n : same_ctx_shape Γ Γ' -> - to_extended_list_k Γ n = to_extended_list_k Γ' n. -Proof. - unfold to_extended_list_k. - intros s. - generalize (@nil term). induction s in n |- *; simpl; auto. -Qed. - -Lemma to_extended_list_eq Γ Γ' : same_ctx_shape Γ Γ' -> - to_extended_list Γ = to_extended_list Γ'. -Proof. - unfold to_extended_list. apply to_extended_list_k_eq. -Qed. - -Hint Constructors context_relation : core. - -Lemma same_ctx_shape_refl Γ : same_ctx_shape Γ Γ. -Proof. induction Γ. constructor; auto. - destruct a as [? [?|] ?]; constructor; simpl; auto; constructor. -Qed. - -Lemma same_ctx_shape_map Γ Γ' f f' : same_ctx_shape Γ Γ' -> - same_ctx_shape (map_context f Γ) (map_context f' Γ'). -Proof. induction 1; constructor; auto. Qed. - -Lemma same_ctx_shape_subst Γ Γ' s k s' k' : same_ctx_shape Γ Γ' -> - same_ctx_shape (subst_context s k Γ) (subst_context s' k' Γ'). -Proof. move=> same. induction same in s, k |- *. constructor; auto. - rewrite !subst_context_snoc. constructor; auto. apply IHsame. - rewrite !subst_context_snoc. constructor; auto. apply IHsame. -Qed. - -Lemma context_assumptions_app Γ Γ' : context_assumptions (Γ ++ Γ') = - context_assumptions Γ + context_assumptions Γ'. -Proof. - induction Γ; simpl; auto. - destruct a as [? [?|] ?]; simpl; auto. -Qed. - -Lemma instantiate_params_ok ctx ctx' pars t : - same_ctx_shape ctx ctx' -> #|pars| = context_assumptions ctx -> - ∑ h, instantiate_params ctx pars (it_mkProd_or_LetIn ctx' t) = Some h. -Proof. - intros Hctx Hpars. rewrite instantiate_params_. - apply same_ctx_shape_rev in Hctx. - rewrite -(List.rev_involutive ctx'). - rewrite -(List.rev_involutive ctx) in Hpars. - generalize (@nil term). - induction Hctx in t, pars, Hpars |- *. - - simpl. destruct pars; try discriminate. simpl in Hpars. intros l. - now eexists (subst0 l _). - - destruct pars; try discriminate. - simpl in Hpars. rewrite context_assumptions_app in Hpars. - simpl in Hpars. elimtype False. lia. - simpl in Hpars. rewrite context_assumptions_app in Hpars. - rewrite Nat.add_1_r in Hpars. noconf Hpars. - simpl in H. - intros l. - destruct (IHHctx _ t H (t0 :: l)). - simpl. exists x. - now rewrite it_mkProd_or_LetIn_app. - - intros l. - simpl in Hpars. rewrite context_assumptions_app in Hpars. - simpl in Hpars. rewrite Nat.add_0_r in Hpars. simpl. - rewrite it_mkProd_or_LetIn_app. - simpl. apply IHHctx. auto. -Qed. - -Lemma reln_length Γ Γ' n : #|reln Γ n Γ'| = #|Γ| + context_assumptions Γ'. -Proof. - induction Γ' in n, Γ |- *; simpl; auto. - destruct a as [? [b|] ?]; simpl; auto. - rewrite Nat.add_1_r. simpl. rewrite IHΓ' => /= //. -Qed. - -Lemma to_extended_list_k_length Γ n : #|to_extended_list_k Γ n| = context_assumptions Γ. -Proof. - now rewrite /to_extended_list_k reln_length. -Qed. diff --git a/pcuic/theories/PCUICCumulProp.v b/pcuic/theories/PCUICCumulProp.v index 5de299dce..72a8912c2 100644 --- a/pcuic/theories/PCUICCumulProp.v +++ b/pcuic/theories/PCUICCumulProp.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import config utils Universes. From MetaCoq.PCUIC Require Import PCUICTyping PCUICAst PCUICAstUtils PCUICLiftSubst PCUICInductives PCUICGeneration PCUICSpine PCUICWeakeningEnv PCUICSubstitution PCUICUnivSubst PCUICUnivSubstitution - PCUICCtxShape PCUICConversion PCUICCumulativity PCUICConfluence PCUICContexts + PCUICConversion PCUICCumulativity PCUICConfluence PCUICContexts PCUICSR PCUICInversion PCUICValidity PCUICSafeLemmata PCUICContextConversion PCUICEquality PCUICReduction. @@ -511,7 +511,7 @@ Definition conv_decls_prop (Σ : global_env_ext) (Γ Γ' : context) (c d : conte | _, _ => False end. -Notation conv_ctx_prop Σ := (context_relation (conv_decls_prop Σ)). +Notation conv_ctx_prop Σ := (All2_fold (conv_decls_prop Σ)). Lemma conv_ctx_prop_refl Σ Γ : conv_ctx_prop Σ Γ Γ. @@ -535,17 +535,28 @@ Lemma red1_upto_conv_ctx_prop Σ Γ Γ' t t' : red1 Σ.1 Γ' t t'. Proof. intros Hred; induction Hred using red1_ind_all in Γ' |- *; - try solve [econstructor; eauto; - try solve [solve_all]]. + 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. - eapply context_relation_nth in X; eauto. + eapply All2_fold_nth in X; eauto. destruct X as [d' [Hnth [ctxrel cp]]]. red in cp. rewrite H in cp. rewrite Hnth /=. destruct (decl_body d'); subst => //. - econstructor. eapply IHHred. constructor; simpl; auto => //. - econstructor. eapply IHHred. constructor; simpl => //. - - econstructor. eapply IHHred; constructor => //. + - econstructor. + eapply OnOne2_local_env_impl; tea => /=; intros ? d d'. + eapply on_one_decl_impl => Δ' x y IH. apply IH. + now apply conv_ctx_prop_app. + - intros h. constructor. + eapply IHHred. now apply conv_ctx_prop_app. + - intros h; constructor. + eapply OnOne2_impl; tea => /= br br'. + intros [[red IH]|[red IH]]; [left|right]. + * split=> //. now eapply red, conv_ctx_prop_app. + * split=> //. eapply OnOne2_local_env_impl; tea => /=; intros ? d d'. + apply on_one_decl_impl => Δ' x y IH'; now apply IH', conv_ctx_prop_app. + - intros. constructor; eapply IHHred; constructor; simpl; auto => //. - intros. eapply fix_red_body. solve_all. eapply b0. now eapply conv_ctx_prop_app. - intros. eapply cofix_red_body. solve_all. @@ -673,26 +684,26 @@ Proof. Qed. -Lemma cumul_prop_subst_instance_instance Σ univs u u' i : +Lemma cumul_prop_subst_instance_instance Σ univs u u' (i : Instance.t) : wf Σ.1 -> consistent_instance_ext Σ univs u -> consistent_instance_ext Σ univs u' -> - R_universe_instance eq_univ_prop (subst_instance_instance u i) - (subst_instance_instance u' i). + R_universe_instance eq_univ_prop (subst_instance u i) + (subst_instance u' i). Proof. intros wfΣ cu cu'. red. eapply All2_Forall2, All2_map. - unfold subst_instance_instance. + unfold subst_instance. eapply All2_map. eapply All2_refl. intros x. red. rewrite !is_prop_subst_instance_level /=. split; reflexivity. Qed. -Lemma cumul_prop_subst_instance_constr Σ Γ univs u u' T : +Lemma cumul_prop_subst_instance Σ Γ univs u u' T : wf Σ.1 -> consistent_instance_ext Σ univs u -> consistent_instance_ext Σ univs u' -> - Σ ;;; Γ |- subst_instance_constr u T ~~ subst_instance_constr u' T. + Σ ;;; Γ |- subst_instance u T ~~ subst_instance u' T. Proof. intros wfΣ cu cu'. eapply cumul_prop_alt. @@ -708,7 +719,21 @@ Proof. - constructor. red. apply R_opt_variance_impl. intros x y; auto. 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. + - cbn. constructor. splits; simpl; solve_all. + eapply cumul_prop_subst_instance_instance; tea. + eapply All2_fold_map. eapply All2_fold_All2. + eapply All_All2; tea. + move=> [na [b|] ty]; rewrite /ondecl /map_decl /=. + * move=> [eqty eqb] /=; constructor; auto. + * move=> [eqty _] /=; constructor; auto. + * eapply eq_term_upto_univ_impl; tea. all:tc. reflexivity. + * eapply All2_map, All_All2; tea. solve_all. + simpl. eapply All2_fold_map, All2_fold_All2, All_All2; tea. + clear. + move=> [na [b|] ty]; rewrite /ondecl /map_decl /=. + + move=> [eqty eqb] /=; constructor; auto. + + move=> [eqty _] /=; constructor; auto. Qed. Lemma All_All_All2 {A} (P Q : A -> Prop) l l' : @@ -741,7 +766,7 @@ Qed. Lemma untyped_subslet_inds Γ ind u u' mdecl : untyped_subslet Γ (inds (inductive_mind ind) u (ind_bodies mdecl)) - (subst_instance_context u' (arities_context (ind_bodies mdecl))). + (subst_instance u' (arities_context (ind_bodies mdecl))). Proof. generalize (le_n #|ind_bodies mdecl|). generalize (ind_bodies mdecl) at 1 3 4. @@ -751,9 +776,9 @@ Proof. unfold arities_context. simpl. rewrite /arities_context rev_map_spec /=. rewrite map_app /= rev_app_distr /=. - rewrite {1}/map_decl /= Nat.add_1_r /=. + rewrite /= Nat.add_1_r /=. constructor. - rewrite -rev_map_spec. apply IHl. lia. + rewrite -rev_map_spec. apply IHl. lia. Qed. Hint Resolve conv_ctx_prop_refl : core. @@ -878,6 +903,7 @@ Proof. eapply eq_term_upto_univ_impl; auto; typeclasses eauto. Qed. +(** Well-typed terms in the leq_term relation live in the same sort hierarchy. *) Lemma typing_leq_term_prop (Σ : global_env_ext) Γ t t' T T' : wf Σ.1 -> Σ ;;; Γ |- t : T -> @@ -895,7 +921,7 @@ Proof. Σ;;; Γ |- t' : T' -> forall n, leq_term_napp Σ n t' t -> Σ ;;; Γ |- T ~~ T')%type - (fun Σ Γ wfΓ => wf_local Σ Γ)); auto;intros Σ wfΣ Γ wfΓ; intros. + (fun Σ Γ => wf_local Σ Γ)); auto;intros Σ wfΣ Γ wfΓ; intros. 1-13:match goal with [ H : leq_term_napp _ _ _ _ |- _ ] => depelim H @@ -974,13 +1000,13 @@ Proof. eapply cumul_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. pose proof (PCUICWeakeningEnv.declared_constant_inj _ _ H declc); subst decl'. - eapply cumul_prop_subst_instance_constr; eauto. + eapply cumul_prop_subst_instance; eauto. - eapply inversion_Ind in X1 as [decl' [idecl' [wf [declc [cu cum]]]]]; auto. pose proof (PCUICWeakeningEnv.declared_inductive_inj isdecl declc) as [-> ->]. eapply cumul_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. do 2 red in H. - now eapply cumul_prop_subst_instance_constr. + now eapply cumul_prop_subst_instance. - eapply inversion_Construct in X1 as [decl' [idecl' [cdecl' [wf [declc [cu cum]]]]]]; auto. pose proof (PCUICWeakeningEnv.declared_constructor_inj isdecl declc) as [-> [-> ->]]. @@ -988,27 +1014,34 @@ Proof. eapply cumul_prop_trans; eauto. unfold type_of_constructor. etransitivity. - eapply (substitution_untyped_cumul_prop_equiv _ Γ (subst_instance_context u (arities_context mdecl.(ind_bodies))) []); auto. + eapply (substitution_untyped_cumul_prop_equiv _ Γ (subst_instance u (arities_context mdecl.(ind_bodies))) []); auto. eapply untyped_subslet_inds. eapply (untyped_subslet_inds _ ind u0 u). simpl. generalize (ind_bodies mdecl). induction l; simpl; constructor; auto. constructor. simpl. eapply R_opt_variance_impl. now intros x. eapply R_eq_univ_prop_consistent_instances; eauto. simpl. - eapply (substitution_untyped_cumul_prop _ Γ (subst_instance_context u0 (arities_context mdecl.(ind_bodies))) []) => //. + eapply (substitution_untyped_cumul_prop _ Γ (subst_instance u0 (arities_context mdecl.(ind_bodies))) []) => //. eapply untyped_subslet_inds. simpl. - eapply cumul_prop_subst_instance_constr => //; eauto. + eapply cumul_prop_subst_instance => //; eauto. - - eapply inversion_Case in X6 as (u' & args' & mdecl' & idecl' & ps' & pty' & btys' & inv); auto. - intuition auto. - intuition auto. - eapply cumul_cumul_prop in b; eauto. + - eapply inversion_Case in X10 as (mdecl' & idecl' & isdecl' & indices' & data & cum); auto. + eapply cumul_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. simpl. - specialize (X4 _ _ H4 a6 _ (eq_term_upto_univ_napp_leq X7_2)). + clear X9. + destruct data. + specialize (X8 _ _ H5 scrut_ty _ (eq_term_upto_univ_napp_leq X11)). eapply cumul_prop_sym => //. + destruct e as [eqpars [eqinst [eqpctx eqpret]]]. eapply cumul_prop_mkApps => //. + rewrite /ptm. + eapply PCUICEquality.eq_term_upto_univ_it_mkLambda_or_LetIn => //. tc. eapply All2_app. 2:(repeat constructor; auto using eq_term_eq_term_prop_impl). - eapply All2_skipn. eapply cumul_prop_mkApps_Ind_inv in X4 => //. + eapply cumul_prop_mkApps_Ind_inv in X8 => //. + eapply All2_app_inv_l in X8 as (?&?&?&?&?). eapply All2_symP => //. typeclasses eauto. + eapply app_inj in e as [eql ->] => //. + move: (All2_length eqpars). + move: (All2_length a0). lia. - eapply inversion_Proj in X3 as (u' & mdecl' & idecl' & pdecl' & args' & inv); auto. intuition auto. @@ -1019,7 +1052,7 @@ Proof. eapply cumul_prop_mkApps_Ind_inv in X2 => //. destruct (PCUICWeakeningEnv.declared_projection_inj a isdecl) as [<- [<- <-]]. subst ty. - transitivity (subst0 (c0 :: List.rev args') (subst_instance_constr u pdecl'.2)). + transitivity (subst0 (c0 :: List.rev args') (subst_instance u pdecl'.2)). eapply (substitution_untyped_cumul_prop_cumul Σ Γ (projection_context mdecl idecl p.1.1 u) []) => //. epose proof (projection_subslet Σ _ _ _ _ _ _ _ _ isdecl wfΣ X1). eapply subslet_untyped_subslet. eapply X3, validity; eauto. @@ -1032,9 +1065,9 @@ Proof. epose proof (projection_subslet Σ _ _ _ _ _ _ _ _ a wfΣ a0). eapply subslet_untyped_subslet. eapply X3, validity; eauto. destruct a. - eapply validity, (isType_mkApps_Ind wfΣ H1) in X1 as [ps [argss [_ cu]]]; eauto. - eapply validity, (isType_mkApps_Ind wfΣ H1) in a0 as [? [? [_ cu']]]; eauto. - eapply cumul_prop_subst_instance_constr; eauto. + eapply validity, (isType_mkApps_Ind_inv wfΣ H1) in X1 as [ps [argss [_ cu]]]; eauto. + eapply validity, (isType_mkApps_Ind_inv wfΣ H1) in a0 as [? [? [_ cu']]]; eauto. + eapply cumul_prop_subst_instance; eauto. - eapply inversion_Fix in X2 as (decl' & fixguard' & Hnth & types' & bodies & wffix & cum); auto. eapply cumul_cumul_prop in cum; eauto. diff --git a/pcuic/theories/PCUICCumulativity.v b/pcuic/theories/PCUICCumulativity.v index 346361e62..557c3b888 100644 --- a/pcuic/theories/PCUICCumulativity.v +++ b/pcuic/theories/PCUICCumulativity.v @@ -3,7 +3,8 @@ From Coq Require Import CRelationClasses. From Equations.Type Require Import Relation Relation_Properties. From MetaCoq.Template Require Import config utils BasicAst. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils - PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICReduction. + PCUICLiftSubst PCUICEquality PCUICUnivSubst + PCUICContextRelation PCUICReduction. Set Default Goal Selector "!". @@ -17,10 +18,9 @@ it is oriented. Those definitions are NOT used in the definition of typing. Instead we use [cumul] and [conv] which are defined as "reducing to a common term". It tunrs out to be equivalent -to [conv1] and [cumul1] by confluence. It will be shown afterward, in PCUICConversion.v . +to [conv1] and [cumul1] by confluence. It will be shown afterward, in PCUICConversion.v. *) - Section ConvCumulDefs. Context {cf:checker_flags} (Σ : global_env_ext) (Γ : context). @@ -30,7 +30,6 @@ Section ConvCumulDefs. Definition conv1 : relation term := clos_refl_trans (relation_disjunction (clos_sym (red1 Σ Γ)) (eq_term Σ Σ)). - Lemma conv0_conv1 M N : conv0 M N <~> conv1 M N. Proof. @@ -49,7 +48,6 @@ Section ConvCumulDefs. + etransitivity; eassumption. Defined. - Definition cumul1 : relation term := clos_refl_trans (relation_disjunction (clos_sym (red1 Σ Γ)) (leq_term Σ Σ)). @@ -81,6 +79,28 @@ where " Σ ;;; Γ |- t = u " := (@conv _ Σ Γ t u) : type_scope. Hint Resolve cumul_refl conv_refl : pcuic. +Module PCUICConversionPar <: EnvironmentTyping.ConversionParSig PCUICTerm PCUICEnvironment PCUICEnvTyping. + Definition conv := @conv. + Definition cumul := @cumul. +End PCUICConversionPar. + +Module PCUICConversion := EnvironmentTyping.Conversion PCUICTerm PCUICEnvironment PCUICEnvTyping PCUICConversionPar. +Include PCUICConversion. + +Notation conv_context Σ Γ Γ' := (All2_fold (conv_decls Σ) Γ Γ'). +Notation cumul_context Σ Γ Γ' := (All2_fold (cumul_decls Σ) Γ Γ'). + +Instance conv_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (conv_decls Σ Γ Γ'). +Proof. + intros x. destruct x as [na [b|] ty]; constructor; auto. + all:constructor; apply eq_term_refl. +Qed. + +Instance cumul_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (cumul_decls Σ Γ Γ'). +Proof. + intros x. destruct x as [na [b|] ty]; constructor; auto. + all:constructor; apply eq_term_refl || apply leq_term_refl. +Qed. Lemma cumul_alt `{cf : checker_flags} Σ Γ t u : Σ ;;; Γ |- t <= u <~> { v & { v' & (red Σ Γ t v * red Σ Γ u v' * @@ -361,3 +381,30 @@ Proof. - eapply cumul_red_r ; try eassumption. econstructor. assumption. Qed. + +Section ContextConversion. + Context {cf : checker_flags}. + Context (Σ : global_env_ext). + + Notation conv_context Γ Γ' := (All2_fold (conv_decls Σ) Γ Γ'). + Notation cumul_context Γ Γ' := (All2_fold (cumul_decls Σ) Γ Γ'). + + Global Instance conv_ctx_refl : Reflexive (All2_fold (conv_decls Σ)). + Proof. + intro Γ; induction Γ; try econstructor; auto. + destruct a as [na [b|] ty]; constructor; auto; pcuic. + Qed. + + Global Instance cumul_ctx_refl : Reflexive (All2_fold (cumul_decls Σ)). + Proof. + intro Γ; induction Γ; try econstructor; auto. + destruct a as [na [b|] ty]; econstructor; eauto; pcuic; eapply cumul_refl'. + Qed. + + Definition conv_ctx_refl' Γ : conv_context Γ Γ + := conv_ctx_refl Γ. + + Definition cumul_ctx_refl' Γ : cumul_context Γ Γ + := cumul_ctx_refl Γ. + +End ContextConversion. \ No newline at end of file diff --git a/pcuic/theories/PCUICElimination.v b/pcuic/theories/PCUICElimination.v index 73b33e6df..effa9ca52 100644 --- a/pcuic/theories/PCUICElimination.v +++ b/pcuic/theories/PCUICElimination.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import config utils Universes. From MetaCoq.PCUIC Require Import PCUICTyping PCUICAst PCUICAstUtils PCUICLiftSubst PCUICInductives PCUICGeneration PCUICSpine PCUICWeakeningEnv PCUICSubstitution PCUICUnivSubst PCUICUnivSubstitution - PCUICCtxShape PCUICConversion PCUICCumulativity PCUICConfluence PCUICContexts + PCUICConversion PCUICCumulativity PCUICConfluence PCUICContexts PCUICSR PCUICInversion PCUICValidity PCUICSafeLemmata PCUICContextConversion PCUICCumulProp. @@ -16,7 +16,7 @@ Definition Is_proof `{cf : checker_flags} Σ Γ t := ∑ T u, Σ ;;; Γ |- t : T Definition SingletonProp `{cf : checker_flags} (Σ : global_env_ext) (ind : inductive) := forall mdecl idecl, - declared_inductive (fst Σ) mdecl ind idecl -> + declared_inductive (fst Σ) ind mdecl idecl -> forall Γ args u n (Σ' : global_env_ext), wf Σ' -> extends Σ Σ' -> @@ -27,7 +27,7 @@ Definition SingletonProp `{cf : checker_flags} (Σ : global_env_ext) (ind : indu Definition Computational `{cf : checker_flags} (Σ : global_env_ext) (ind : inductive) := forall mdecl idecl, - declared_inductive (fst Σ) mdecl ind idecl -> + declared_inductive (fst Σ) ind mdecl idecl -> forall Γ args u n (Σ' : global_env_ext), wf Σ' -> extends Σ Σ' -> @@ -36,7 +36,7 @@ Definition Computational `{cf : checker_flags} (Σ : global_env_ext) (ind : indu Definition Informative `{cf : checker_flags} (Σ : global_env_ext) (ind : inductive) := forall mdecl idecl, - declared_inductive (fst Σ) mdecl ind idecl -> + declared_inductive (fst Σ) ind mdecl idecl -> forall Γ args u n (Σ' : global_env_ext), wf_ext Σ' -> extends Σ Σ' -> @@ -44,82 +44,90 @@ Definition Informative `{cf : checker_flags} (Σ : global_env_ext) (ind : induct #|ind_ctors idecl| <= 1 /\ squash (All (Is_proof Σ' Γ) (skipn (ind_npars mdecl) args)). -Lemma elim_restriction_works_kelim1 - `{cf : checker_flags} (Σ : global_env_ext) Γ T ind npar p c brs mind idecl : +From MetaCoq.PCUIC Require Import PCUICInductiveInversion. + +Lemma elim_restriction_works_kelim1 {cf : checker_flags} {Σ : global_env_ext} + {Γ T ci p c brs mdecl idecl} : check_univs -> wf_ext Σ -> - declared_inductive (fst Σ) mind ind idecl -> - Σ ;;; Γ |- tCase (ind, npar) p c brs : T -> - (Is_proof Σ Γ (tCase (ind, npar) p c brs) -> False) -> + declared_inductive Σ ci.(ci_ind) mdecl idecl -> + Σ ;;; Γ |- tCase ci p c brs : T -> + (Is_proof Σ Γ (tCase ci p c brs) -> False) -> ind_kelim idecl = IntoAny \/ ind_kelim idecl = IntoSetPropSProp. Proof. intros cu wfΣ. intros. assert (HT := X). - eapply inversion_Case in X as [uni [args [mdecl [idecl' [ps [pty [btys - [? [? [? [? [? [? [ht0 [? [? ?]]]]]]]]]]]]]]]]; auto. - eapply declared_inductive_inj in d as []. 2:exact H. subst. + eapply inversion_Case in X as [mdecl' [idecl' [isdecl' [indices [data cum]]]]]; eauto. + destruct data. + eapply declared_inductive_inj in isdecl' as []. 2:exact H. subst. enough (~ (Universe.is_prop ps \/ Universe.is_sprop ps)). - { clear -cu wfΣ i H1. + { clear -cu wfΣ allowed_elim H1. apply wf_ext_consistent in wfΣ as (val&sat). unfold is_allowed_elimination, is_allowed_elimination0 in *. - rewrite cu in i. - specialize (i _ sat). + rewrite cu in allowed_elim. + specialize (allowed_elim _ sat). destruct (ind_kelim idecl); auto; destruct ⟦ps⟧_val%u eqn:v; try easy; try apply val_is_sprop in v; try apply val_is_prop in v; intuition congruence. } intros Huf. apply H0. - red. exists (mkApps p (skipn (ind, npar).2 args ++ [c])); intuition auto. + red. exists (mkApps ptm (indices ++ [c])); intuition auto. exists ps. - intuition auto. - econstructor; eauto. - assert (watiapp := env_prop_typing _ _ validity _ _ _ _ _ ht0). - simpl in watiapp. - eapply (isType_mkApps_Ind wfΣ H) in watiapp as [psub [asub [[spp spa] cuni]]]; eauto. - 2:eapply typing_wf_local; eauto. - destruct on_declared_inductive as [oi oib] in *. simpl in *. - eapply (build_case_predicate_type_spec _ _ _ _ _ _ _ _ oib) in e0 as [parsubst [cs eq]]. - rewrite eq in t. - eapply PCUICGeneration.type_mkApps. eauto. - eapply wf_arity_spine_typing_spine; auto. - split; auto. - now eapply validity in t. - eapply arity_spine_it_mkProd_or_LetIn; eauto. - subst npar. - pose proof (PCUICContexts.context_subst_fun cs spp). subst psub. clear cs. - eapply spa. - simpl. constructor. - rewrite PCUICLiftSubst.subst_mkApps. simpl. - rewrite map_app map_map_compose. - rewrite PCUICLiftSubst.map_subst_lift_id_eq. - { rewrite - (PCUICSubstitution.context_subst_length spa). - now autorewrite with len. } - { unfold to_extended_list. - rewrite (spine_subst_subst_to_extended_list_k_gen spa). - unfold subst_context; rewrite to_extended_list_k_fold_context. - apply PCUICSubstitution.map_subst_instance_constr_to_extended_list_k. - subst npar. - now rewrite firstn_skipn. } - - constructor. - - rewrite H1; auto. - - rewrite H1 Bool.orb_true_r; auto. + assert (Σ;;; Γ |- tCase ci p c brs : mkApps ptm (indices ++ [c])). + econstructor; eauto. split; auto. + split; auto. clear brs_ty. + eapply type_mkApps. rewrite /ptm. + eapply type_it_mkLambda_or_LetIn; tea. + assert (wf Σ) by apply wfΣ. + pose proof (PCUICInductiveInversion.isType_mkApps_Ind_smash H (validity scrut_ty)). + 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) + (Γ,,, predctx)). + { + eapply All2_app. 2:eapply All2_refl; reflexivity. + eapply case_predicate_context_alpha. + destruct wf_pred. eapply Forall2_All2 in H2. + depelim H2. rewrite H3. constructor; auto. } + assert (conv_context Σ (Γ ,,, case_predicate_context' ci mdecl idecl p) (Γ ,,, pcontext p)). + { etransitivity. + 2:{ symmetry. eassumption. } + eapply eq_context_alpha_conv => //. } + unshelve epose proof (arity_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. + specialize (X2 spargs scrut_ty). + eapply typing_spine_strengthen; tea. + 2:{ eapply cumul_it_mkProd_or_LetIn; tea. + eapply PCUICContextRelation.All2_fold_app_inv. 2:symmetry; tea. + pose proof (All2_fold_length X1). len in H1. + rewrite /case_predicate_context'; simpl; len. + reflexivity. } + eapply wf_arity_spine_typing_spine; tea. + split. eapply validity. eapply type_it_mkLambda_or_LetIn; tea. + eapply context_conversion; tea. + eapply wf_local_alpha; tea. now symmetry. + now symmetry. + exact X2. + destruct Huf as [Huf|Huf]; rewrite Huf // orb_true_r //. Qed. -Lemma elim_sort_intype {cf:checker_flags} Σ mdecl ind idecl ind_indices ind_sort cshapes : +Lemma elim_sort_intype {cf:checker_flags} Σ mdecl ind idecl ind_indices ind_sort cdecls : Universe.is_prop ind_sort -> - elim_sort_prop_ind cshapes = IntoAny -> + elim_sort_prop_ind cdecls = IntoAny -> on_constructors (lift_typing typing) (Σ, ind_universes mdecl) mdecl (inductive_ind ind) idecl ind_indices - (ind_ctors idecl) cshapes -> + (ind_ctors idecl) cdecls -> (#|ind_ctors idecl| = 0) + - (∑ cdecl cshape, + (∑ cdecl cdecl_sorts, (ind_ctors idecl = [cdecl]) * - (cshapes = [cshape]) * - (Forall is_propositional cshape.(cshape_sorts)) * + (cdecls = [cdecl_sorts]) * + (Forall is_propositional cdecl_sorts) * (on_constructor (lift_typing typing) (Σ, ind_universes mdecl) mdecl - (inductive_ind ind) idecl ind_indices cdecl cshape))%type. + (inductive_ind ind) idecl ind_indices cdecl cdecl_sorts))%type. Proof. intros uf lein onc. induction onc; simpl in *. @@ -139,7 +147,7 @@ Lemma typing_spine_it_mkProd_or_LetIn_full_inv {cf:checker_flags} Σ Γ Δ s arg leq_universe (global_ext_constraints Σ) s s'. Proof. intros wfΣ. - induction Δ using ctx_length_rev_ind in args |- *. + induction Δ using PCUICInduction.ctx_length_rev_ind in args |- *. - simpl. intros sp; depelim sp. now eapply cumul_Sort_inv in c. now eapply cumul_Sort_Prod_inv in c. @@ -232,19 +240,19 @@ Lemma typing_spine_proofs {cf:checker_flags} Σ Γ Δ ind u args' args T' s : (∑ s, (Σ ;;; Γ ,,, Γ' |- t : tSort s) * is_propositional s)%type) Δ -> ∥ All (Is_proof Σ Γ) args ∥) * (forall mdecl idecl - (Hdecl : declared_inductive Σ.1 mdecl ind idecl) - (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) - (inductive_mind ind) mdecl (inductive_ind ind) idecl), + (Hdecl : declared_inductive Σ.1 ind mdecl idecl), consistent_instance_ext Σ (ind_universes mdecl) u -> - ((is_propositional s -> s = subst_instance_univ u oib.(ind_sort)) /\ + ((is_propositional s -> s = subst_instance_univ u idecl.(ind_sort)) /\ (prop_sub_type = false -> - is_propositional (subst_instance_univ u oib.(ind_sort)) -> s = subst_instance_univ u oib.(ind_sort)))))%type. + is_propositional (subst_instance_univ u idecl.(ind_sort)) -> + s = subst_instance_univ u idecl.(ind_sort)))))%type. Proof. intros checku wfΣ Ht. - induction Δ using ctx_length_rev_ind in Γ, args', args, T', Ht |- *; simpl; intros sp. + induction Δ using PCUICInduction.ctx_length_rev_ind in Γ, args', args, T', Ht |- *; simpl; intros sp. - depelim sp. split; [repeat constructor|]. * eapply invert_cumul_ind_l in c as [ui' [l' [red [Req argeq]]]] => //; auto. - intros mdecl idecl decli oib cu. + intros mdecl idecl decli cu. + destruct (on_declared_inductive decli) as [onmind oib]. eapply subject_reduction in Ht; eauto. eapply inversion_mkApps in Ht as [A [tInd sp]]; auto. eapply inversion_Ind in tInd as [mdecl' [idecl' [wfΓ [decli' [cu' cum]]]]]; auto. @@ -252,7 +260,7 @@ Proof. clear decli'. eapply typing_spine_strengthen in sp; eauto. rewrite (oib.(ind_arity_eq)) in sp. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in sp. + rewrite !subst_instance_it_mkProd_or_LetIn in sp. rewrite -it_mkProd_or_LetIn_app in sp. eapply typing_spine_it_mkProd_or_LetIn_full_inv in sp; auto. split. @@ -260,17 +268,17 @@ Proof. destruct s => //. eapply leq_universe_prop_r in sp; auto. rewrite (is_prop_subst_instance_univ ui') in sp => //. - now destruct (ind_sort oib). + now destruct (ind_sort idecl). apply wfΣ. eapply leq_universe_sprop_r in sp; auto. rewrite (is_sprop_subst_instance_univ ui') in sp => //. - now destruct (ind_sort oib). + now destruct (ind_sort idecl). apply wfΣ. intros propsub props. rewrite is_propositional_subst_instance in props. apply leq_universe_propositional_l in sp; eauto. subst s. - now destruct (ind_sort oib). - now destruct (ind_sort oib). + now destruct (ind_sort idecl). + now destruct (ind_sort idecl). * eapply cumul_Prod_r_inv in c; auto. destruct c as [na' [dom' [codom' [[[red _] _] ?]]]]. @@ -300,7 +308,7 @@ Proof. rewrite app_context_assoc in Ht2. eapply All_local_env_app_inv in Ht2 as [Ht2 _]. depelim Ht2. apply l0. now rewrite app_context_assoc in Ht2. - * intros mdecl idec decli oib. + * intros mdecl idec decli. now apply H. + rewrite it_mkProd_or_LetIn_app in sp. destruct args. split; [repeat constructor|]. @@ -321,7 +329,7 @@ Proof. { constructor. now exists s. eapply cumul_conv_ctx; eauto. constructor; auto. apply conv_ctx_refl. constructor; auto. } - destruct H; auto. + destruct H. eapply a; tea. * simpl in sp. depelim sp. eapply cumul_Prod_inv in c as [conv cum]; auto. 2:eauto using typing_wf_local. eapply typing_spine_strengthen in sp; auto. @@ -349,23 +357,23 @@ Proof. sq. constructor; auto. simpl in conv. red. destruct s0 as [s' [Ht' sprop]]. exists ty, s'. intuition auto. - intros. now apply H. + intros. now eapply H; tea. Qed. Lemma check_ind_sorts_is_propositional {cf:checker_flags} (Σ : global_env_ext) mdecl idecl ind (onib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl (inductive_ind ind) idecl) : (ind_kelim idecl <> IntoPropSProp /\ ind_kelim idecl <> IntoSProp) -> - is_propositional (ind_sort onib) -> + 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 onib) (ind_cshapes onib) (ind_sort onib) -> - (#|ind_cshapes onib| <= 1) * All (fun cs => All is_propositional cs.(cshape_sorts)) (ind_cshapes onib). + (ind_indices idecl) (ind_cunivs onib) (ind_sort idecl) -> + (#|ind_cunivs onib| <= 1) * All (fun cs => All is_propositional cs) (ind_cunivs onib). Proof. intros kelim isp. unfold check_ind_sorts. simpl. destruct Universe.is_prop eqn:isp'. - + induction (ind_cshapes onib); simpl; auto; try discriminate. + + induction (ind_cunivs onib); simpl; auto; try discriminate. destruct l; simpl. intros; split; eauto. constructor; [|constructor]. destruct forallb eqn:fo. eapply forallb_All in fo. eapply All_impl; eauto; simpl. @@ -373,7 +381,7 @@ Proof. intros leb. destruct (ind_kelim idecl); simpl in *; intuition congruence. + destruct Universe.is_sprop eqn:issp. - induction (ind_cshapes onib); simpl; auto; try discriminate. + induction (ind_cunivs onib); simpl; auto; try discriminate. destruct (ind_kelim idecl); simpl in *; intuition congruence. unfold is_propositional in isp. now rewrite isp' issp in isp. @@ -413,7 +421,7 @@ Qed. Lemma Is_proof_mkApps_tConstruct `{cf : checker_flags} (Σ : global_env_ext) Γ ind n u mdecl idecl args : check_univs = true -> wf_ext Σ -> - declared_inductive (fst Σ) mdecl ind idecl -> + declared_inductive (fst Σ) ind mdecl idecl -> (ind_kelim idecl <> IntoPropSProp /\ ind_kelim idecl <> IntoSProp) -> Is_proof Σ Γ (mkApps (tConstruct ind n u) args) -> #|ind_ctors idecl| <= 1 /\ ∥ All (Is_proof Σ Γ) (skipn (ind_npars mdecl) args) ∥. @@ -422,7 +430,7 @@ Proof. assert (wfΣ : wf Σ) by apply HΣ. eapply inversion_mkApps in hc as [? [hc hsp]]; auto. eapply inversion_Construct in hc as [mdecl' [idecl' [cdecl' [wfΓ [declc [cu cum']]]]]]; auto. - destruct (on_declared_constructor _ declc) as [[oi oib] [cs [Hnth onc]]]. + destruct (on_declared_constructor declc) as [[oi oib] [cs [Hnth onc]]]. set (onib := declared_inductive_inv _ _ _ _) in *. clearbody onib. clear oib. eapply typing_spine_strengthen in hsp; eauto. @@ -431,10 +439,10 @@ Proof. { eapply PCUICInductiveInversion.declared_constructor_valid_ty in declc; eauto. } move: X hsp. unfold type_of_constructor. - rewrite [cdecl'.1.2](onc.(cstr_eq)). - rewrite !subst_instance_constr_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn. + rewrite (onc.(cstr_eq)). + rewrite !subst_instance_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn. rewrite - {1}(firstn_skipn (ind_npars mdecl) args). - rewrite !subst_instance_constr_mkApps. + rewrite !subst_instance_mkApps. simpl. autorewrite with len. rewrite !subst_mkApps. @@ -443,7 +451,7 @@ Proof. destruct (le_dec (ind_npars mdecl) #|args|). * intros X hsp. eapply PCUICSpine.typing_spine_inv in hsp as [parsub [[sub wat] sp]]; auto. - 2:{ rewrite context_assumptions_subst subst_instance_context_assumptions. + 2:{ rewrite context_assumptions_subst subst_instance_assumptions. autorewrite with len. rewrite firstn_length_le //. symmetry; eapply onNpars. eauto. } rewrite !subst_it_mkProd_or_LetIn in X, sp. @@ -451,15 +459,15 @@ Proof. simpl in sp. eapply typing_spine_proofs in sp; eauto. destruct sp. - specialize (a _ _ (proj1 declc) onib cu) as [a a']. + specialize (a _ _ declc cu) as [a a']. specialize (a hp). pose proof (onc.(on_cargs)). pose proof (onib.(ind_sorts)). - assert (Universe.is_prop (ind_sort onib) || Universe.is_sprop (ind_sort onib)). + assert (Universe.is_prop (ind_sort idecl) || Universe.is_sprop (ind_sort idecl)). { rewrite -(is_prop_subst_instance_univ u) -(is_sprop_subst_instance_univ u) => //. now subst tycs. } apply check_ind_sorts_is_propositional in X1 as [nctors X1]; eauto. - assert(#|ind_cshapes onib| = #|ind_ctors idecl|). + assert(#|ind_cunivs onib| = #|ind_ctors idecl|). clear wat X. clear -onib. pose proof (onib.(onConstructors)). eapply All2_length in X. now rewrite X. rewrite H0 in nctors; split; auto. @@ -467,21 +475,21 @@ Proof. eapply nth_error_all in X1; eauto. simpl in X1. eapply sorts_local_ctx_instantiate in X0. 4:eapply cu. all: eauto. - rewrite subst_instance_context_app in X0. + 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 _ _ _ _ []), PCUICArities.subslet_inds; eauto. } eapply sub. } 2:{ eapply PCUICWeakening.weaken_wf_local; auto. - unshelve eapply PCUICInductiveInversion.on_constructor_inst in oi; eauto. - destruct oi as [oi _]. - rewrite !subst_instance_context_app in oi. - now eapply wf_local_app_l in oi. } + edestruct (PCUICInductiveInversion.on_constructor_inst declc); eauto. + destruct s0 as [inst [sp _]]. + rewrite !subst_instance_app in sp. + now eapply wf_local_app_l in sp. } apply s. rewrite subst_app_context in X0. - rewrite -(context_subst_length sub) 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 => @@ -499,12 +507,13 @@ Proof. pose proof (onc.(on_cargs)). pose proof (onib.(ind_sorts)). eapply check_ind_sorts_is_propositional in X0 as [nctors X1]; eauto. - assert(#|ind_cshapes onib| = #|ind_ctors idecl|). + assert(#|ind_cunivs onib| = #|ind_ctors idecl|). clear -onib. pose proof (onib.(onConstructors)). eapply All2_length in X. now rewrite X. now rewrite -H. rewrite -it_mkProd_or_LetIn_app in sp. eapply typing_spine_proofs in sp; eauto. - destruct sp as [_ sp]. specialize (sp _ _ decli onib cu) as [a a']. + destruct sp as [_ sp]. + specialize (sp _ _ decli cu) as [a a']. specialize (a hp). subst tycs. rewrite -(is_propositional_subst_instance u) //. Qed. @@ -512,24 +521,24 @@ Qed. Lemma elim_restriction_works_kelim `{cf : checker_flags} (Σ : global_env_ext) ind mind idecl : check_univs = true -> wf_ext Σ -> - declared_inductive (fst Σ) mind ind idecl -> + declared_inductive (fst Σ) ind mind idecl -> (ind_kelim idecl <> IntoPropSProp /\ ind_kelim idecl <> IntoSProp) -> Informative Σ ind. Proof. intros cu HΣ H indk. assert (wfΣ : wf Σ) by apply HΣ. - destruct (PCUICWeakeningEnv.on_declared_inductive wfΣ H) as [[]]; eauto. + destruct (PCUICWeakeningEnv.on_declared_inductive H) as [[]]; eauto. intros ?. intros. eapply declared_inductive_inj in H as []; eauto; subst idecl0 mind. eapply Is_proof_mkApps_tConstruct in X1; tea. now eapply weakening_env_declared_inductive. Qed. -Lemma elim_restriction_works `{cf : checker_flags} (Σ : global_env_ext) Γ T ind npar 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 = true -> wf_ext Σ -> - declared_inductive (fst Σ) mind ind idecl -> - Σ ;;; Γ |- tCase (ind, npar) p c brs : T -> - (Is_proof Σ Γ (tCase (ind, npar) p c brs) -> False) -> Informative Σ ind. + declared_inductive (fst Σ) ci mind idecl -> + Σ ;;; Γ |- tCase ci p c brs : T -> + (Is_proof Σ Γ (tCase ci p c brs) -> False) -> Informative Σ ci.(ci_ind). Proof. intros cu wfΣ decli HT H. eapply elim_restriction_works_kelim1 in HT; eauto. @@ -539,7 +548,7 @@ Qed. Lemma declared_projection_projs_nonempty `{cf : checker_flags} {Σ : global_env_ext} { mind ind p a} : wf Σ -> - declared_projection Σ mind ind p a -> + declared_projection Σ p mind ind a -> ind_projs ind <> []. Proof. intros. destruct H. destruct H0. @@ -549,7 +558,7 @@ Qed. Lemma elim_restriction_works_proj_kelim1 `{cf : checker_flags} (Σ : global_env_ext) Γ T p c mind idecl : wf Σ -> - declared_inductive (fst Σ) mind (fst (fst p)) idecl -> + declared_inductive (fst Σ) (fst (fst p)) mind idecl -> Σ ;;; Γ |- tProj p c : T -> (Is_proof Σ Γ (tProj p c) -> False) -> ind_kelim idecl = IntoAny. Proof. @@ -558,17 +567,19 @@ Proof. eapply inversion_Proj in X0 as (? & ? & ? & ? & ? & ? & ? & ? & ?) ; auto. destruct x2. cbn in *. pose (d' := d). destruct d' as [? _]. - eapply declared_inductive_inj in H as []; eauto. subst. + eapply declared_inductive_inj in H as []; eauto. subst. simpl in *. pose proof (declared_projection_projs_nonempty X d). - pose proof (PCUICWeakeningEnv.on_declared_projection X d) as [oni onp]. - simpl in onp. destruct ind_cshapes as [|? []]; try contradiction. - destruct onp as (((? & ?) & ?) & ?). - inv o. auto. + pose proof (PCUICWeakeningEnv.on_declared_projection d) as [_ onp]. + simpl in onp. + destruct ind_ctors as [|? []]; try contradiction. + destruct ind_cunivs as [|? []]; try contradiction. + now destruct onp as (((? & ?) & ?) & ?). + all:destruct onp as (((? & ?) & ?) & ?); now inv o. Qed. Lemma elim_restriction_works_proj `{cf : checker_flags} (Σ : global_env_ext) Γ p c mind idecl T : check_univs = true -> wf_ext Σ -> - declared_inductive (fst Σ) mind (fst (fst p)) idecl -> + declared_inductive (fst Σ) (fst (fst p)) mind idecl -> Σ ;;; Γ |- tProj p c : T -> (Is_proof Σ Γ (tProj p c) -> False) -> Informative Σ (fst (fst p)). Proof. @@ -577,12 +588,6 @@ Proof. intuition congruence. Qed. -Lemma length_of_btys {ind mdecl' idecl' args' u' p} : - #|build_branches_type ind mdecl' idecl' args' u' p| = #|ind_ctors idecl'|. -Proof. - unfold build_branches_type. now rewrite mapi_length. -Qed. - Lemma length_map_option_out {A} l l' : @map_option_out A l = Some l' -> #|l| = #|l'|. Proof. @@ -590,6 +595,7 @@ Proof. - destruct l'; [reflexivity|discriminate]. - cbn. destruct (map_option_out l); [|discriminate]. destruct l'; [discriminate|]. inversion 1; subst; cbn; eauto. + noconf H. now specialize (IHl l' eq_refl). - discriminate. Qed. @@ -600,37 +606,6 @@ Proof. - destruct a. destruct ?. all:inv H. eauto. Qed. -Lemma tCase_length_branch_inv `{cf : checker_flags} (Σ : global_env_ext) Γ ind npar p n u args brs T m t : - wf Σ -> - Σ ;;; Γ |- tCase (ind, npar) p (mkApps (tConstruct ind n u) args) brs : T -> - nth_error brs n = Some (m, t) -> - (#|args| = npar + m)%nat. -Proof. - intros. eapply inversion_Case in X0 as (u' & args' & mdecl' & idecl' & ps' & pty' & btys' & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?); eauto. - subst. unfold build_case_predicate_type in *. - pose proof t1 as t1'. - eapply inversion_mkApps in t1' as [A [tc _]]; auto. - eapply inversion_Construct in tc as [mdecl [idecl [cdecl [_ [declc _]]]]]; auto. clear A. - unshelve eapply PCUICInductiveInversion.Construct_Ind_ind_eq in t1; eauto. - destruct on_declared_constructor as [[onind oib] [cs [Hnth onc]]]. - destruct t1 as [[t1 ->] _]. simpl in e. rewrite <- e. - destruct (declared_inductive_inj d (proj1 declc)); subst mdecl' idecl'. - f_equal. clear Hnth. - eapply build_branches_type_lookup in e2. eauto. - 2:eauto. - 3:destruct declc; eauto. - 2:{ eapply (All2_impl a); pcuicfo eauto. } - destruct e2 as [nargs [br [brty [[[Hnth Hnth'] brtyped]]]]]. - epose proof (All2_nth_error _ _ _ a H). - specialize (X0 Hnth'). - simpl in X0. destruct X0 as [[X0 _] _]. subst m. - clear e0. - set (decli := declared_inductive_inv _ _ _ _) in *. - clear oib. clearbody decli. - unshelve eapply branch_type_spec in e2; eauto. - now destruct e2 as [e2 _]. -Qed. - Section no_prop_leq_type. Context `{cf : checker_flags}. @@ -703,8 +678,9 @@ Proof. intros [[HA HB]|[HB HA]] cum; split; auto; apply cumul_alt in cum as [v [v' [[redv redv'] leq]]]. - eapply type_Cumul' with (tSort u'); eauto. - eapply isType_Sort; pcuic. + eapply PCUICArities.isType_Sort. now eapply PCUICWfUniverses.typing_wf_universe in HA. + pcuic. constructor. constructor. eapply subject_reduction in redv; eauto. eapply subject_reduction in redv'; eauto. @@ -713,8 +689,9 @@ Proof. eapply subject_reduction in redv'; eauto. eapply leq_term_prop_sorted_r in leq; eauto. eapply type_Cumul' with (tSort u'); eauto. - eapply isType_Sort; pcuic. + eapply PCUICArities.isType_Sort. now eapply PCUICWfUniverses.typing_wf_universe in HB. + pcuic. constructor. constructor. auto. Qed. @@ -730,8 +707,7 @@ Proof. intros [[HA HB]|[HB HA]] cum; split; auto; apply cumul_alt in cum as [v [v' [[redv redv'] leq]]]. - eapply type_Cumul' with (tSort u'); eauto. - eapply isType_Sort; pcuic. - now eapply PCUICWfUniverses.typing_wf_universe in HA. + eapply PCUICArities.isType_Sort; pcuic. constructor. constructor. eapply subject_reduction in redv; eauto. eapply subject_reduction in redv'; eauto. @@ -740,141 +716,10 @@ Proof. eapply subject_reduction in redv'; eauto. eapply leq_term_sprop_sorted_r in leq; eauto. eapply type_Cumul' with (tSort u'); eauto. - eapply isType_Sort; pcuic. - now eapply PCUICWfUniverses.typing_wf_universe in HB. + eapply PCUICArities.isType_Sort; pcuic. constructor. constructor. auto. Qed. - -(* -Lemma cumul_prop_r_is_type (Σ : global_env_ext) Γ A B u : - wf_ext Σ -> - Universe.is_prop u -> - isType Σ Γ A -> - Σ ;;; Γ |- B : tSort u -> - Σ ;;; Γ |- A <= B -> - isType Σ Γ A. -Proof. - intros. - destruct X0; eauto. - destruct i as [ctx [s [Hd eq]]]. - exists u. - apply PCUICArities.destArity_spec_Some in Hd. - simpl in Hd. subst A. - revert u H Γ eq B X1 X2. revert ctx. intros ctx. - change (list context_decl) with context in ctx. - induction ctx using ctx_length_rev_ind; simpl in *; intros. - - elimtype False. - eapply invert_cumul_sort_l in X2 as [u' [red leq]]; auto. - eapply subject_reduction in red; eauto. - eapply inversion_Sort in red as [l [wf [inl [eq' lt]]]]; auto. - subst u'. - eapply cumul_Sort_inv in lt. - now apply is_prop_gt in lt. - - rewrite app_context_assoc in eq. - pose proof eq as eq'. - eapply All_local_env_app_inv in eq' as [wfΓ wf']. depelim wfΓ; - rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /= in X2 |- *. - + eapply invert_cumul_prod_l in X2 as (na' & A & B' & (red & conv) & cum). - eapply subject_reduction in X1. 3:eassumption. all:auto. - eapply inversion_Prod in X1 as (s1 & s2 & tA & tB' & cum'); auto. - eapply cumul_Sort_inv in cum'. - specialize (X0 Γ ltac:(reflexivity) u H _ eq B'). - forward X0. - eapply type_Cumul. - eapply context_conversion; eauto. - constructor; pcuic. constructor. now symmetry. - constructor; auto. - left. eexists _, _; simpl; intuition eauto. constructor; pcuic. - do 2 constructor. etransitivity; eauto. - eapply leq_universe_product. - specialize (X0 cum). - eapply type_Cumul. - econstructor; eauto. eapply l.π2. - left; eexists _, _; simpl; intuition auto. - do 2 constructor. now eapply impredicative_product. - + eapply invert_cumul_letin_l in X2; auto. - eapply type_Cumul. - econstructor; eauto. eapply l.π2. - instantiate (1 := (tSort u)). - eapply X0; auto. - eapply (PCUICWeakening.weakening _ _ [vdef na b t]) in X1. simpl in X1. - eapply X1. all:eauto. - constructor; auto. - eapply (PCUICWeakening.weakening_cumul _ _ [] [vdef na b t]) in X2; auto. - simpl in X2. assert (wf Σ) by apply X. - etransitivity; eauto. - eapply red_cumul. apply PCUICSpine.red_expand_let. - constructor; pcuic. - left; eexists _, _; simpl; intuition eauto. - eapply red_cumul, PCUICReduction.red1_red. - constructor. -Qed. - -Lemma cumul_prop_l_is_type (Σ : global_env_ext) Γ A B u : - wf_ext Σ -> - Universe.is_prop u -> - isWfArity_or_Type Σ Γ B -> - Σ ;;; Γ |- A : tSort u -> - Σ ;;; Γ |- A <= B -> - isType Σ Γ B. -Proof. - intros. - destruct X0; eauto. - destruct i as [ctx [s [Hd eq]]]. - exists u. - apply PCUICArities.destArity_spec_Some in Hd. - simpl in Hd. subst B. - revert u H Γ eq A X1 X2. revert ctx. intros ctx. - change (list context_decl) with context in ctx. - induction ctx using ctx_length_rev_ind; simpl in *; intros. - - elimtype False. - eapply invert_cumul_sort_r in X2 as [u' [red leq]]; auto. - eapply subject_reduction in red; eauto. - eapply inversion_Sort in red as [l [wf [inl [eq' lt]]]]; auto. - subst u'. - eapply cumul_Sort_inv in lt. - apply is_prop_gt in lt; auto. - - rewrite app_context_assoc in eq. - pose proof eq as eq'. - eapply All_local_env_app_inv in eq' as [wfΓ wf']. depelim wfΓ; - rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /= in X2 |- *. - + eapply invert_cumul_prod_r in X2 as (na' & A' & B' & (red & conv) & cum). - eapply subject_reduction in X1. 3:eassumption. all:auto. - eapply inversion_Prod in X1 as (s1 & s2 & tA & tB' & cum'); auto. - eapply cumul_Sort_inv in cum'. - specialize (X0 Γ ltac:(reflexivity) u H _ eq B'). - forward X0. - eapply type_Cumul. - eapply context_conversion; eauto. - constructor; pcuic. constructor. now symmetry. - constructor; auto. - left. eexists _, _; simpl; intuition eauto. constructor; pcuic. - do 2 constructor. etransitivity; eauto. - eapply leq_universe_product. - specialize (X0 cum). - eapply type_Cumul. - econstructor; eauto. eapply l.π2. - left; eexists _, _; simpl; intuition auto. - do 2 constructor. now eapply impredicative_product. - + eapply invert_cumul_letin_r in X2; auto. - eapply type_Cumul. - econstructor; eauto. eapply l.π2. - instantiate (1 := (tSort u)). - eapply X0; auto. - eapply (PCUICWeakening.weakening _ _ [vdef na b t]) in X1. simpl in X1. - eapply X1. all:eauto. - constructor; auto. - eapply (PCUICWeakening.weakening_cumul _ _ [] [vdef na b t]) in X2; auto. - simpl in X2. assert (wf Σ) by apply X. - etransitivity; eauto. - eapply conv_cumul, conv_sym, red_conv. apply PCUICSpine.red_expand_let. - constructor; pcuic. - left; eexists _, _; simpl; intuition eauto. - eapply red_cumul, PCUICReduction.red1_red. - constructor. -Qed. *) - Lemma cumul_prop1 (Σ : global_env_ext) Γ A B u : wf_ext Σ -> Universe.is_prop u -> diff --git a/pcuic/theories/PCUICEquality.v b/pcuic/theories/PCUICEquality.v index 9f6ce36e5..0c31e5241 100644 --- a/pcuic/theories/PCUICEquality.v +++ b/pcuic/theories/PCUICEquality.v @@ -1,13 +1,19 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import CMorphisms. -From MetaCoq.Template Require Import config utils Reflect. +From MetaCoq.Template Require Import LibHypsNaming config utils Reflect. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction - PCUICLiftSubst PCUICReflect. + PCUICLiftSubst PCUICReflect PCUICContextRelation. Require Import ssreflect. From Equations.Prop Require Import DepElim. +From Equations Require Import Equations. Set Equations With UIP. +Instance All2_fold_len P Γ Δ : HasLen (All2_fold P Γ Δ) #|Γ| #|Δ| := + All2_fold_length. + +Implicit Types (cf : checker_flags). + Definition R_universe_instance R := fun u u' => Forall2 R (List.map Universe.make u) (List.map Universe.make u'). @@ -39,32 +45,6 @@ Fixpoint R_universe_instance_variance Re Rle v u u' := | _, _ => False 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 => - 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) => - match nth_error idecl.(ind_ctors) k with - | Some cdecl => Some (mdecl, idecl, cdecl) - | None => None - end - | _ => None - end. - Definition global_variance Σ gr napp := match gr with | IndRef ind => @@ -80,7 +60,7 @@ Definition global_variance Σ gr napp := | ConstructRef ind k => match lookup_constructor Σ ind k with | Some (mdecl, idecl, cdecl) => - if (cdecl.2 + mdecl.(ind_npars))%nat <=? napp then + if (cdecl.(cstr_arity) + mdecl.(ind_npars))%nat <=? napp then (** Fully applied constructors are always compared at the same supertype, which implies that no universe equality needs to be checked here. *) Some [] @@ -113,6 +93,140 @@ Proof. intros H x y xy. eapply Forall2_impl ; tea. Qed. +Section compare_decls. + (* leq_term compares types, eq_term bodies: + - For conversion they are both equality + - For cumulativity only the type are compared using leq. + *) + Context {eq_term leq_term : term -> term -> Type}. + Inductive compare_decls : context_decl -> context_decl -> Type := + | compare_vass {na T na' T'} : + eq_binder_annot na na' -> + leq_term T T' -> + compare_decls (vass na T) (vass na' T') + | compare_vdef {na b T na' b' T'} : + eq_binder_annot na na' -> + eq_term b b' -> + leq_term T T' -> + compare_decls (vdef na b T) (vdef na' b' T'). + + Derive Signature NoConfusion for compare_decls. +End compare_decls. +Arguments compare_decls : clear implicits. + +Notation eq_context_gen eq_term leq_term := + (All2_fold (fun _ _ => compare_decls eq_term leq_term)). + +Lemma compare_decls_impl eq_term leq_term eq_term' leq_term' : + subrelation eq_term eq_term' -> + subrelation leq_term leq_term' -> + subrelation (compare_decls eq_term leq_term) + (compare_decls eq_term' leq_term'). +Proof. + intros he hle x y []; constructor; auto. +Qed. + +Lemma eq_context_gen_impl eq_term leq_term eq_term' leq_term' : + subrelation eq_term eq_term' -> + subrelation leq_term leq_term' -> + subrelation (eq_context_gen eq_term leq_term) (eq_context_gen eq_term' leq_term'). +Proof. + intros he hle x y eq. + eapply All2_fold_impl; tea => /=. + intros; eapply compare_decls_impl; tea. +Qed. + +Lemma compare_decl_impl_ondecl P eq_term leq_term eq_term' leq_term' d d' : + ondecl P d -> + (forall x y, P x -> eq_term x y -> eq_term' x y) -> + (forall x y, P x -> leq_term x y -> leq_term' x y) -> + compare_decls eq_term leq_term d d' -> + compare_decls eq_term' leq_term' d d'. +Proof. + intros ond he hle cd; depelim cd; depelim ond; constructor => //; eauto. +Qed. + +Lemma compare_decl_map eq_term leq_term f g d d' : + compare_decls (fun x y => eq_term (f x) (g y)) + (fun x y => leq_term (f x) (g y)) d d' -> + compare_decls eq_term leq_term (map_decl f d) (map_decl g d'). +Proof. + intros h; depelim h; constructor; intuition auto. +Qed. + +Definition bcompare_decls (eq_term leq_term : term -> term -> bool) (d d' : context_decl) : bool := + match d, d' with + | {| decl_name := na; decl_body := None; decl_type := T |}, + {| decl_name := na'; decl_body := None; decl_type := T' |} => + eqb_binder_annot na na' && leq_term T T' + | {| decl_name := na; decl_body := Some b; decl_type := T |}, + {| decl_name := na'; decl_body := Some b'; decl_type := T' |} => + eqb_binder_annot na na' && eq_term b b' && leq_term T T' + | _, _ => false + end. + +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. +Qed. + +Instance compare_decl_sym 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. + +Instance compare_decl_trans 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. +Qed. + +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. +Qed. + +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. +Qed. + +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. +Qed. + +Definition eq_predicate (eq_term : term -> term -> Type) Re p p' := + All2 eq_term p.(pparams) p'.(pparams) * + (R_universe_instance Re p.(puinst) p'.(puinst) * + ((eq_context_gen eq_term eq_term p.(pcontext) p'.(pcontext)) * + eq_term p.(preturn) p'.(preturn))). + (** ** Syntactic equality up-to universes We don't look at printing annotations *) @@ -172,11 +286,13 @@ Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) eq_term_upto_univ_napp Σ Re Rle napp (tLetIn na t ty u) (tLetIn na' t' ty' u') | eq_Case indn p p' c c' brs brs' : - eq_term_upto_univ_napp Σ Re Re 0 p p' -> + eq_predicate (eq_term_upto_univ_napp Σ Re Re 0) Re p p' -> eq_term_upto_univ_napp Σ Re Re 0 c c' -> All2 (fun x y => - (fst x = fst y) * - eq_term_upto_univ_napp Σ Re Re 0 (snd x) (snd y) + eq_context_gen (eq_term_upto_univ_napp Σ Re Re 0) + (eq_term_upto_univ_napp Σ Re Re 0) + (bcontext x) (bcontext y) * + eq_term_upto_univ_napp Σ Re Re 0 (bbody x) (bbody y) ) brs brs' -> eq_term_upto_univ_napp Σ Re Rle napp (tCase indn p c brs) (tCase indn p' c' brs') @@ -215,7 +331,7 @@ Definition eq_term `{checker_flags} Σ φ := Definition leq_term `{checker_flags} Σ φ := eq_term_upto_univ Σ (eq_universe φ) (leq_universe φ). - + Lemma R_global_instance_refl Σ Re Rle gr napp u : RelationClasses.Reflexive Re -> RelationClasses.Reflexive Rle -> @@ -231,7 +347,7 @@ Proof. - apply Forall2_same; eauto. Qed. -Instance eq_binder_annot_equiv {A} : RelationClasses.Equivalence (@eq_binder_annot A). +Instance eq_binder_annot_equiv {A} : RelationClasses.Equivalence (@eq_binder_annot A A). Proof. split. - red. reflexivity. @@ -240,11 +356,65 @@ Proof. apply transitivity. Qed. -Definition eq_binder_annot_refl {A} x : @eq_binder_annot A x x. +Definition eq_binder_annot_refl {A} x : @eq_binder_annot A A x x. Proof. reflexivity. Qed. Hint Resolve @eq_binder_annot_refl : core. +(* TODO MOVE *) +Existing Instance All2_symP. + +(* TODO MOVE *) +Instance Forall2_symP : + forall A (P : A -> A -> Prop), + RelationClasses.Symmetric P -> + Symmetric (Forall2 P). +Proof. + intros A P h l l' hl. + induction hl. all: auto. +Qed. + +Lemma eq_binder_relevances_refl (x : list aname) : All2 (on_rel eq binder_relevance) x x. +Proof. now eapply All_All2_refl, All_refl. Qed. +Hint Resolve eq_binder_relevances_refl : core. + +Instance R_universe_instance_refl Re : RelationClasses.Reflexive Re -> + RelationClasses.Reflexive (R_universe_instance Re). +Proof. intros tRe x. eapply Forall2_map. + induction x; constructor; auto. +Qed. + +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. + +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. + +Lemma onctx_eq_ctx P ctx eq_term : + onctx P ctx -> + (forall x, P x -> eq_term x x) -> + All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx. +Proof. + intros onc HP. + induction onc. + - constructor; auto. + - constructor; auto; simpl. + destruct x as [na [b|] ty]; destruct p; simpl in *; + constructor; auto. +Qed. + +Instance eq_predicate_refl Re Ru : + CRelationClasses.Reflexive Re -> + RelationClasses.Reflexive Ru -> + CRelationClasses.Reflexive (eq_predicate Re Ru). +Proof. + intros hre hru. + intros p. unfold eq_predicate; intuition auto; try reflexivity. + eapply All2_same; reflexivity. +Qed. + Instance eq_term_upto_univ_refl Σ Re Rle napp : RelationClasses.Reflexive Re -> RelationClasses.Reflexive Rle -> @@ -256,11 +426,17 @@ Proof. all: try constructor. all: eauto. all: try solve [eapply All_All2 ; eauto]. all: try solve [eapply Forall2_same ; eauto]. - all: try reflexivity. + all: try solve [unfold eq_predicate; solve_all; eapply All_All2; eauto]. - apply R_global_instance_refl; auto. - apply R_global_instance_refl; auto. - - eapply All_All2; eauto. simpl. intuition eauto; reflexivity. - - eapply All_All2; eauto. simpl. intuition eauto; reflexivity. + - destruct X as [? [? ?]]. + unfold eq_predicate; solve_all. + eapply All_All2; eauto. reflexivity. + eapply onctx_eq_ctx in a0; eauto. + - eapply All_All2; eauto; simpl; intuition eauto. + eapply onctx_eq_ctx in a; eauto. + - eapply All_All2; eauto; simpl; intuition eauto. + - eapply All_All2; eauto; simpl; intuition eauto. Qed. Instance eq_term_refl `{checker_flags} Σ φ : Reflexive (eq_term Σ φ). @@ -273,19 +449,6 @@ Proof. apply eq_term_upto_univ_refl; exact _. Qed. -(* TODO MOVE *) -Existing Instance All2_symP. - -(* TODO MOVE *) -Instance Forall2_symP : - forall A (P : A -> A -> Prop), - RelationClasses.Symmetric P -> - Symmetric (Forall2 P). -Proof. - intros A P h l l' hl. - induction hl. all: auto. -Qed. - Derive Signature for eq_term_upto_univ_napp. Lemma R_global_instance_sym Σ Re Rle gr napp u u' : @@ -303,7 +466,18 @@ Proof. destruct v; simpl; auto. apply IHu; auto. - apply Forall2_symP; eauto. -Qed. +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) -> + All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx' -> + All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx' ctx. +Proof. + intros onc HP H1. + induction H1; depelim onc; constructor; intuition auto; simpl in *. + depelim p; depelim o; constructor; auto; try now symmetry. +Qed. Instance eq_term_upto_univ_sym Σ Re Rle napp : RelationClasses.Symmetric Re -> @@ -311,7 +485,7 @@ Instance eq_term_upto_univ_sym Σ Re Rle napp : Symmetric (eq_term_upto_univ_napp Σ Re Rle napp). Proof. intros he hle u v e. - pose proof (@RelationClasses.symmetry _ (@eq_binder_annot name) _). + pose proof (@RelationClasses.symmetry _ (@eq_binder_annot name name) _). induction u in Rle, hle, v, napp, e |- * using term_forall_list_ind. all: dependent destruction e. all: try solve [ @@ -324,12 +498,14 @@ Proof. induction h. + constructor. + destruct r as [h1 h2]. eapply h1 in h2 ; auto. - - econstructor; eauto. - eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h. - + constructor. - + destruct r as [h1 [h2 h3]]. eapply h1 in h3 ; auto. + - solve_all. destruct e as (r & ? & eq & ?). + econstructor; rewrite ?e; unfold eq_predicate in *; solve_all; eauto. + eapply All2_sym; solve_all. + unfold R_universe_instance in r |- *. + eapply Forall2_symP; eauto. + eapply onctx_eq_ctx_sym in a1; eauto. + eapply All2_sym; solve_all. + eapply onctx_eq_ctx_sym in a0; eauto. - econstructor. eapply All2_All_mix_left in X as h; eauto. clear a X. @@ -346,6 +522,15 @@ Proof. constructor; auto. Qed. +Instance eq_predicate_sym Re Ru : + CRelationClasses.Symmetric Re -> + RelationClasses.Symmetric Ru -> + CRelationClasses.Symmetric (eq_predicate Re Ru). +Proof. + intros hre hru. + intros p. unfold eq_predicate; intuition auto; try now symmetry. +Qed. + Instance eq_term_sym `{checker_flags} Σ φ : Symmetric (eq_term Σ φ). Proof. eapply eq_term_upto_univ_sym. all: exact _. @@ -354,7 +539,7 @@ Qed. Instance R_global_instance_trans Σ Re Rle gr napp : RelationClasses.Transitive Re -> RelationClasses.Transitive Rle -> - Transitive (R_global_instance Σ Re Rle gr napp). + RelationClasses.Transitive (R_global_instance Σ Re Rle gr napp). Proof. intros he hle x y z. unfold R_global_instance, R_opt_variance. @@ -369,13 +554,37 @@ Proof. eapply Forall2_trans; auto. Qed. +Lemma onctx_eq_ctx_trans P ctx ctx' ctx'' eq_term : + onctx P ctx -> + (forall x, P x -> forall y z, eq_term x y -> eq_term y z -> eq_term x z) -> + All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx' -> + All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx' ctx'' -> + All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx''. +Proof. + intros onc HP H1; revert ctx''. + induction H1; depelim onc; intros ctx'' H; depelim H; constructor; intuition auto; simpl in *. + depelim o. depelim p0. + - depelim c; constructor; [now etransitivity|eauto]. + - depelim c; constructor; [now etransitivity|eauto ..]. +Qed. + +Instance eq_predicate_trans Re Ru : + CRelationClasses.Transitive Re -> + RelationClasses.Transitive Ru -> + CRelationClasses.Transitive (eq_predicate Re Ru). +Proof. + intros hre hru. + intros p. unfold eq_predicate; intuition auto; try now etransitivity. + eapply All2_trans; tea. +Qed. + Instance eq_term_upto_univ_trans Σ Re Rle napp : RelationClasses.Transitive Re -> RelationClasses.Transitive Rle -> Transitive (eq_term_upto_univ_napp Σ Re Rle napp). Proof. intros he hle u v w e1 e2. - pose proof (@RelationClasses.transitivity _ (@eq_binder_annot name) _). + pose proof (@RelationClasses.transitivity _ (@eq_binder_annot name name) _). induction u in Rle, hle, v, w, napp, e1, e2 |- * using term_forall_list_ind. all: dependent destruction e1. all: try solve [ eauto ]. @@ -398,15 +607,24 @@ Proof. constructor. eapply R_global_instance_trans; eauto. - dependent destruction e2. - econstructor; eauto. - eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h in a0, brs'0 |- *. - + assumption. - + dependent destruction a0. constructor ; eauto. - destruct r as [h1 [h2 h3]]. - destruct p0 as [? ?]. split; eauto. - transitivity (fst y); auto. + unfold eq_predicate in *. + !!solve_all. + econstructor; unfold eq_predicate in *; solve_all; eauto. + * clear -he hh1 hh2. + revert hh1 hh2. generalize (pparams p), p'.(pparams), p'0.(pparams). + intros l l' l''. + induction 1 in l'' |- *; auto. intros H; depelim H. constructor; auto. + eapply r; eauto. apply r. + * etransitivity; eauto. + * eapply onctx_eq_ctx_trans in hh; eauto. + * clear -H he a a0. + induction a in a0, brs'0 |- *. + + assumption. + + depelim a0. destruct p. constructor; auto. + destruct r as [[h1 h1'] [h2 h3]]. + split. + eapply onctx_eq_ctx_trans in h1; eauto. + eapply h1'; eauto. - dependent destruction e2. econstructor. eapply All2_All_mix_left in X as h; eauto. @@ -437,13 +655,22 @@ Proof. eapply eq_term_upto_univ_trans ; exact _. Qed. - Instance eq_term_upto_univ_equiv Σ Re (hRe : RelationClasses.Equivalence Re) : Equivalence (eq_term_upto_univ Σ Re Re). Proof. constructor. all: exact _. Defined. +Instance eq_context_equiv {cf} Σ φ : Equivalence (eq_context_gen (eq_term Σ φ) (eq_term Σ φ)). +Proof. + constructor; try exact _. +Qed. + +Instance leq_context_preord {cf} Σ φ : PreOrder (eq_context_gen (eq_term Σ φ) (leq_term Σ φ)). +Proof. + constructor; try exact _. +Qed. + Instance eq_term_equiv {cf:checker_flags} Σ φ : Equivalence (eq_term Σ φ) := {| Equivalence_Reflexive := eq_term_refl _ _; Equivalence_Symmetric := eq_term_sym _ _; @@ -585,6 +812,17 @@ Proof. destruct t0; simpl; auto. Qed. +Lemma onctx_eq_ctx_impl P ctx ctx' eq_term eq_term' : + onctx P ctx -> + (forall x, P x -> forall y, eq_term x y -> eq_term' x y) -> + eq_context_gen eq_term eq_term ctx ctx' -> + eq_context_gen eq_term' eq_term' ctx ctx'. +Proof. + intros onc HP H1. + induction H1; depelim onc; constructor; eauto; intuition auto; simpl in *. + destruct o; depelim p; constructor; auto. +Qed. + Instance eq_term_upto_univ_impl Σ Re Re' Rle Rle' napp napp' : RelationClasses.subrelation Re Re' -> RelationClasses.subrelation Rle Rle' -> @@ -605,10 +843,10 @@ Proof. eapply R_global_instance_impl. 5:eauto. all:auto. - inversion 1; subst; constructor. eapply R_global_instance_impl. 5:eauto. all:eauto. - - inversion 1; subst; constructor; eauto. - eapply All2_impl'; tea. - eapply All_impl; eauto. - cbn. intros x ? y [? ?]. split; eauto. + - inversion 1; subst; constructor; unfold eq_predicate in *; eauto; solve_all. + * eapply R_universe_instance_impl'; eauto. + * eapply onctx_eq_ctx_impl in a0; tea. eauto. + * eapply onctx_eq_ctx_impl in a4; tea. eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. @@ -637,10 +875,10 @@ Proof. eapply R_global_instance_empty_impl. 4:eauto. all:eauto. - inversion 1; subst; constructor. eapply R_global_instance_empty_impl. 4:eauto. all:eauto. - - inversion 1; subst; constructor; eauto. - eapply All2_impl'; tea. - eapply All_impl; eauto. - cbn. intros x ? y [? ?]. split; eauto. + - inversion 1; subst; constructor; unfold eq_predicate in *; solve_all. + * eapply R_universe_instance_impl'; eauto. + * eapply onctx_eq_ctx_impl in a0; tea. eauto. + * eapply onctx_eq_ctx_impl in a4; tea. eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. @@ -673,6 +911,7 @@ Proof. now eapply leq_term_antisym. Qed. +Hint Constructors compare_decls : pcuic. Local Ltac lih := lazymatch goal with @@ -688,11 +927,24 @@ Proof. induction u in n', v, n, k, e, Rle |- * using term_forall_list_ind. all: dependent destruction e. all: try solve [cbn ; constructor ; try lih ; try assumption; solve_all]. + - cbn. destruct e as (? & ? & e & ?). + constructor; unfold eq_predicate in *; simpl; !!solve_all. + * apply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea; simpl; eauto. + unfold ondecl; + intros Γ Γ' d d' IH []; constructor; intuition eauto. + * rewrite -?(All2_fold_length e). + eapply hh0; eauto. + * eapply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea; simpl; eauto. + unfold ondecl; + intros Γ Γ' d d' IH []; constructor; intuition pcuic. + * rewrite (All2_fold_length a). now eapply hh4. - cbn. constructor. - pose proof (All2_length _ _ a). + pose proof (All2_length a). solve_all. rewrite H. eauto. - cbn. constructor. - pose proof (All2_length _ _ a). + pose proof (All2_length a). solve_all. rewrite H. eauto. Qed. @@ -739,12 +991,22 @@ Proof. constructor. + constructor. - cbn. constructor. solve_all. - - cbn. constructor ; try sih ; eauto. solve_all. + - cbn. + destruct e as (? & ? & e & ?). + constructor ; unfold eq_predicate; simpl; try sih ; solve_all. + * eapply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea; simpl; eauto. + unfold ondecl; intros Γ Γ' d d' IH []; constructor; simpl; intuition eauto. + * rewrite -(All2_fold_length e). eapply e1; eauto. + * eapply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea; simpl; eauto. + unfold ondecl; intros Γ Γ' d d' IH []; simpl; constructor; intuition eauto. + * rewrite (All2_fold_length a). now eapply b0. - cbn. constructor ; try sih ; eauto. - pose proof (All2_length _ _ a). + pose proof (All2_length a). solve_all. now rewrite H. - cbn. constructor ; try sih ; eauto. - pose proof (All2_length _ _ a). + pose proof (All2_length a). solve_all. now rewrite H. Qed. @@ -809,8 +1071,8 @@ Definition compare_global_instance Σ equ lequ gr napp := | None => compare_universe_instance equ end. -Definition eqb_annot {A} (b b' : binder_annot A) : bool := - eqb b.(binder_relevance) b'.(binder_relevance). +Definition eqb_binder_annots (x y : list aname) : bool := + forallb2 eqb_binder_annot x y. Fixpoint eqb_term_upto_univ_napp Σ (equ lequ : Universe.t -> Universe.t -> bool) napp (u v : term) : bool := match u, v with @@ -845,28 +1107,35 @@ Fixpoint eqb_term_upto_univ_napp Σ (equ lequ : Universe.t -> Universe.t -> bool compare_global_instance Σ equ lequ (ConstructRef i k) napp u u' | tLambda na A t, tLambda na' A' t' => - eqb_annot na na' && + eqb_binder_annot na na' && eqb_term_upto_univ_napp Σ equ equ 0 A A' && eqb_term_upto_univ_napp Σ equ lequ 0 t t' | tProd na A B, tProd na' A' B' => - eqb_annot na na' && + eqb_binder_annot na na' && eqb_term_upto_univ_napp Σ equ equ 0 A A' && eqb_term_upto_univ_napp Σ equ lequ 0 B B' | tLetIn na B b u, tLetIn na' B' b' u' => - eqb_annot na na' && + eqb_binder_annot na na' && eqb_term_upto_univ_napp Σ equ equ 0 B B' && eqb_term_upto_univ_napp Σ equ equ 0 b b' && eqb_term_upto_univ_napp Σ equ lequ 0 u u' | tCase indp p c brs, tCase indp' p' c' brs' => eqb indp indp' && - eqb_term_upto_univ_napp Σ equ equ 0 p p' && + eqb_predicate_gen + (fun u u' => forallb2 equ (map Universe.make u) (map Universe.make u')) + (bcompare_decls (eqb_term_upto_univ_napp Σ equ equ 0) + (eqb_term_upto_univ_napp Σ equ equ 0)) + (eqb_term_upto_univ_napp Σ equ equ 0) p p' && eqb_term_upto_univ_napp Σ equ equ 0 c c' && forallb2 (fun x y => - eqb (fst x) (fst y) && - eqb_term_upto_univ_napp Σ equ equ 0 (snd x) (snd y) + forallb2 + (bcompare_decls (eqb_term_upto_univ_napp Σ equ equ 0) + (eqb_term_upto_univ_napp Σ equ equ 0)) + x.(bcontext) y.(bcontext) && + eqb_term_upto_univ_napp Σ equ equ 0 (bbody x) (bbody y) ) brs brs' | tProj p c, tProj p' c' => @@ -879,7 +1148,7 @@ Fixpoint eqb_term_upto_univ_napp Σ (equ lequ : Universe.t -> Universe.t -> bool eqb_term_upto_univ_napp Σ equ equ 0 x.(dtype) y.(dtype) && eqb_term_upto_univ_napp Σ equ equ 0 x.(dbody) y.(dbody) && eqb x.(rarg) y.(rarg) && - eqb_annot x.(dname) y.(dname) + eqb_binder_annot x.(dname) y.(dname) ) mfix mfix' | tCoFix mfix idx, tCoFix mfix' idx' => @@ -888,7 +1157,7 @@ Fixpoint eqb_term_upto_univ_napp Σ (equ lequ : Universe.t -> Universe.t -> bool eqb_term_upto_univ_napp Σ equ equ 0 x.(dtype) y.(dtype) && eqb_term_upto_univ_napp Σ equ equ 0 x.(dbody) y.(dbody) && eqb x.(rarg) y.(rarg) && - eqb_annot x.(dname) y.(dname) + eqb_binder_annot x.(dname) y.(dname) ) mfix mfix' | tPrim p, tPrim p' => eqb p p' @@ -959,81 +1228,146 @@ Proof. eapply Forall2_impl; tea; eauto. Qed. -Lemma eqb_annot_spec {A} na na' : eqb_annot na na' <-> @eq_binder_annot A na na'. +Lemma eqb_annot_spec {A} na na' : eqb_binder_annot na na' <-> @eq_binder_annot A A na na'. Proof. - unfold eqb_annot, eq_binder_annot. - now destruct (eqb_spec (binder_relevance na) (binder_relevance na')). + unfold eqb_binder_annot, eq_binder_annot. + now destruct Classes.eq_dec. Qed. -Lemma eqb_annot_reflect {A} na na' : reflect (@eq_binder_annot A na na') (eqb_annot na na'). +Lemma eqb_annot_reflect {A} na na' : reflect (@eq_binder_annot A A na na') (eqb_binder_annot na na'). Proof. - unfold eqb_annot, eq_binder_annot. - destruct (eqb_spec (binder_relevance na) (binder_relevance na')); constructor; auto. + unfold eqb_binder_annot, eq_binder_annot. + destruct Classes.eq_dec; constructor; auto. Qed. -Lemma eqb_annot_refl {A} n : @eqb_annot A n n. +Lemma eqb_annot_refl {A} n : @eqb_binder_annot A n n. Proof. apply eqb_annot_spec. reflexivity. Qed. -Lemma eqb_term_upto_univ_impl (equ lequ : _ -> _ -> bool) Σ Re Rle napp : - RelationClasses.subrelation equ Re -> - RelationClasses.subrelation lequ Rle -> - subrelation (eqb_term_upto_univ_napp Σ equ lequ napp) (eq_term_upto_univ_napp Σ Re Rle napp). +Lemma eqb_annots_spec nas nas' : eqb_binder_annots nas nas' <-> Forall2 (on_rel eq binder_relevance) nas nas'. Proof. - intros he hle t t'. - induction t in t', lequ, Rle, hle, napp |- * using term_forall_list_ind. - all: destruct t'; try discriminate 1. all: cbn -[eqb]. - - eqspec; [intros _|discriminate]. constructor. - - eqspec; [intros _|discriminate]. constructor. - - eqspec; [|discriminate]. constructor. - cbn in H. apply forallb2_All2 in H. - eapply All2_impl'; tea. - eapply All_impl; tea. simpl. eauto. - - constructor; eauto. - - intro. rtoProp. constructor; eauto. - now apply eqb_annot_spec. - - intro. rtoProp. constructor; eauto. - now apply eqb_annot_spec. - - intro. rtoProp. constructor; eauto. - now apply eqb_annot_spec. - - intro. rtoProp. constructor; eauto. - - unfold kername in *. eqspec; [|discriminate]. - intro. rtoProp. constructor; eauto. - apply forallb2_Forall2 in H0. - eapply Forall2_impl; tea; eauto. - - unfold kername in *. eqspec; [|discriminate]. - intro. rtoProp. constructor; eauto. - eapply compare_global_instance_impl; eauto. - - unfold kername in *. eqspec; [|discriminate]. - eqspec; [|discriminate]. - intro. simpl in H. - constructor. eapply compare_global_instance_impl; eauto. - - eqspec; [|discriminate]. intro. rtoProp. - destruct indn. econstructor; eauto. - apply forallb2_All2 in H0. - eapply All2_impl'; tea. - red in X. eapply All_impl; tea. - cbn -[eqb]. intros x X0 y. eqspec; [|discriminate]. - intro. split; eauto. - - eqspec; [|discriminate]. intro. constructor; eauto. - - eqspec; [|discriminate]. - econstructor; eauto. - cbn -[eqb] in H; apply forallb2_All2 in H. - eapply All2_impl'; tea. - red in X. eapply All_impl; tea. - cbn -[eqb]. intros x X0 y. eqspec; [|rewrite andb_false_r; discriminate]. - intro. rtoProp. split; tas. split;tas. split; eapply X0; tea. - now apply eqb_annot_spec. - - eqspec; [|discriminate]. - econstructor; eauto. - cbn -[eqb] in H; apply forallb2_All2 in H. - eapply All2_impl'; tea. - red in X. eapply All_impl; tea. - cbn -[eqb]. intros x X0 y. eqspec; [|rewrite andb_false_r; discriminate]. - intro. rtoProp. split; tas. split;tas. split; eapply X0; tea. - now apply eqb_annot_spec. - - eqspec; [|discriminate]. constructor. + unfold eqb_binder_annots, eq_binder_annot. + split; intros. + eapply forallb2_Forall2 in H. + eapply (Forall2_impl H). unfold on_rel. apply eqb_annot_spec. + eapply Forall2_forallb2, (Forall2_impl H); apply eqb_annot_spec. +Qed. + +Lemma eqb_annots_reflect nas nas' : reflectT (All2 (on_rel eq binder_relevance) nas nas') (eqb_binder_annots nas nas'). +Proof. + unfold eqb_binder_annots, eq_binder_annot. + destruct forallb2 eqn:H; constructor. + eapply Forall2_All2. now apply eqb_annots_spec. + intros H'; apply All2_Forall2, eqb_annots_spec in H'. + red in H'. unfold eqb_binder_annots in H'. congruence. +Qed. + +(*Lemma eqb_context_reflect ctx ctx' : reflectT (eq_context_gen false (eq_term_up)) *) + +Lemma forallb2_bcompare_decl_All2_fold + (P : term -> term -> bool) Γ Δ : + forallb2 (bcompare_decls P P) Γ Δ -> + All2_fold (fun _ _ => bcompare_decls P P) Γ Δ. +Proof. + induction Γ as [|[na [b|] ty] Γ] in Δ |- *; destruct Δ as [|[na' [b'|] ty'] Δ]; simpl => //; constructor; auto; + now move/andb_and: H => []. +Qed. + +Lemma reflect_eq_context_IH {Σ equ lequ} {Re Rle : Universe.t -> Universe.t -> Prop} : + (forall u u', reflectT (Re u u') (equ u u')) -> + (forall u u', reflectT (Rle u u') (lequ u u')) -> + forall ctx ctx', + onctx + (fun t : term => + forall (lequ : Universe.t -> Universe.t -> bool) + (Rle : Universe.t -> Universe.t -> Prop) + (napp : nat), + (forall u u' : Universe.t, reflectT (Rle u u') (lequ u u')) -> + forall t' : term, + reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') + (eqb_term_upto_univ_napp Σ equ lequ napp t t')) + ctx -> + reflectT + (eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Re) ctx ctx') + (forallb2 (bcompare_decls (eqb_term_upto_univ Σ equ equ) + (eqb_term_upto_univ Σ equ equ)) ctx ctx'). +Proof. + intros hRe hRle ctx ctx' onc. + eapply equiv_reflectT. + - intros hcc'. + eapply All2_fold_forallb2, All2_fold_impl_onctx; tea. + unfold ondecl; intuition auto. + depelim X0; cbn in * => //; + intuition auto. + + destruct (eqb_annot_reflect na na') => //. + destruct (a equ Re 0 hRe T') => //. + + destruct (eqb_annot_reflect na na') => //. + destruct (b0 equ Re 0 hRe b') => //. + destruct (a equ Re 0 hRe T') => //. + - intros hcc'. + eapply forallb2_bcompare_decl_All2_fold in hcc'; tea. + eapply All2_fold_impl_onctx in onc; tea; simpl; intuition eauto. + destruct X0. + move: H. + destruct d as [na [bod|] ty], d' as [na' [bod'|] ty']; cbn in * => //. + + destruct (eqb_annot_reflect na na') => //. + destruct (r equ Re 0 hRe ty') => //. + destruct (o equ Re 0 hRe bod') => //. + now constructor. + now rewrite andb_false_r. + + destruct (eqb_annot_reflect na na') => //. + destruct (r equ Re 0 hRe ty') => //. + now constructor. +Qed. + +Definition reflect_eq_predicate {Σ equ lequ} {Re Rle : Universe.t -> Universe.t -> Prop} : + (forall u u', reflectT (Re u u') (equ u u')) -> + (forall u u', reflectT (Rle u u') (lequ u u')) -> + forall p p', + tCasePredProp + (fun t : term => + forall (lequ : Universe.t -> Universe.t -> bool) + (Rle : Universe.t -> Universe.t -> Prop) + (napp : nat), + (forall u u' : Universe.t, reflectT (Rle u u') (lequ u u')) -> + forall t' : term, + reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') + (eqb_term_upto_univ_napp Σ equ lequ napp t t')) + (fun t : term => + forall (lequ : Universe.t -> Universe.t -> bool) + (Rle : Universe.t -> Universe.t -> Prop) + (napp : nat), + (forall u u' : Universe.t, reflectT (Rle u u') (lequ u u')) -> + forall t' : term, + reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') + (eqb_term_upto_univ_napp Σ equ lequ napp t t')) p -> + reflectT (eq_predicate (eq_term_upto_univ_napp Σ Re Re 0) Re p p') + (eqb_predicate_gen (fun u u' => forallb2 equ (map Universe.make u) (map Universe.make u')) + (bcompare_decls (eqb_term_upto_univ_napp Σ equ equ 0) (eqb_term_upto_univ_napp Σ equ equ 0)) + (eqb_term_upto_univ_napp Σ equ equ 0) p p'). +Proof. + intros. + solve_all. unfold eq_predicate, eqb_predicate, eqb_predicate_gen. + simpl; apply equiv_reflectT. + - intros H; rtoProp. + destruct H as [onpars [onuinst [pctx pret]]]. + intuition auto; rtoProp; intuition auto. + * solve_all. destruct (a _ Re 0 X y); auto; try contradiction. + * red in onuinst. + eapply Forall2_forallb2, Forall2_impl; eauto. + now move=> x y /X. + * destruct (reflect_eq_context_IH X X0 (pcontext p) (pcontext p') a0) => //. + * ih. contradiction. + - move/andb_and => [/andb_and [/andb_and [ppars pinst] pctx] pret]. + intuition auto. + * solve_all. + now destruct (a _ _ 0 X y). + * solve_all. red. apply All2_Forall2. + eapply (All2_impl pinst); eauto. + now move=> x y /X. + * now destruct (reflect_eq_context_IH X X0 (pcontext p) (pcontext p') a0). + * now destruct (r _ _ 0 X (preturn p')). Qed. Lemma reflect_eq_term_upto_univ Σ equ lequ (Re Rle : Universe.t -> Universe.t -> Prop) napp : @@ -1134,9 +1468,9 @@ Proof. apply (reflectT_subrelation' he). apply (reflectT_subrelation' hle). - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. - cbn - [eqb]. - destruct indn as [i n]. + - cbn - [eqb]. eqspecs => /=. + destruct (reflect_eq_predicate he hle p p0 X). + ih. clear X. rename X0 into X. induction l in brs, X |- *. + destruct brs. * constructor. constructor ; try assumption. @@ -1145,22 +1479,23 @@ Proof. + destruct brs. * constructor. intro bot. inversion bot. subst. inversion X2. * cbn - [eqb]. inversion X. subst. - destruct a, p. cbn - [eqb]. eqspecs. - -- cbn - [eqb]. pose proof (X0 equ Re 0 he t0) as hh. cbn in hh. - destruct hh. - ++ cbn - [eqb]. - destruct (IHl X1 brs). - ** constructor. constructor ; try assumption. - constructor ; try easy. - inversion e2. subst. assumption. + destruct a, b. cbn - [eqb eqb_binder_annots]. + destruct X0 as [onc onbod]. + destruct (reflect_eq_context_IH he hle bcontext bcontext0 onc) => // /=. + -- cbn - [eqb]. + pose proof (onbod equ Re 0 he bbody0) as hh. cbn in hh. + destruct hh => /=. + ++ cbn -[eqb eqb_binder_annots] in *. destruct (IHl X1 brs). + ** constructor ; try easy. inversion e2. subst. + constructor; auto. ** constructor. intro bot. apply f. inversion bot. subst. - constructor ; try assumption. - inversion X4. subst. assumption. + inversion X3. subst. constructor; auto. ++ constructor. intro bot. apply f. inversion bot. subst. - inversion X4. subst. destruct X5. assumption. + inversion X3. subst. destruct X4. assumption. -- constructor. intro bot. inversion bot. subst. - inversion X4. subst. destruct X5. cbn in e1. subst. - apply n2. reflexivity. + inversion X3. subst. destruct X4. cbn in e1. subst. + contradiction. + + simpl. constructor. intros bot; inv bot; contradiction. - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. constructor. constructor ; assumption. - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. @@ -1229,6 +1564,18 @@ Proof. - cbn - [eqb]. eqspecs. do 2 constructor. Qed. +Lemma eqb_term_upto_univ_impl (equ lequ : _ -> _ -> bool) Σ Re Rle napp : + RelationClasses.subrelation equ Re -> + RelationClasses.subrelation lequ Rle -> + RelationClasses.subrelation equ Rle -> + subrelation (eqb_term_upto_univ_napp Σ equ lequ napp) (eq_term_upto_univ_napp Σ Re Rle napp). +Proof. + intros he hle heqle t t'. + case: (reflect_eq_term_upto_univ Σ equ lequ equ lequ) => //; eauto. + 1-2:eapply reflectT_pred2. + intros. eapply eq_term_upto_univ_impl. 5:tea. all:eauto. +Qed. + Lemma compare_global_instance_refl : forall Σ (eqb leqb : Universe.t -> Universe.t -> bool) gr napp u, (forall u, eqb u u) -> @@ -1241,7 +1588,8 @@ Proof. induction u in v |- *; destruct v; simpl; auto. rtoProp. split; auto. destruct t; simpl; auto. - eapply forallb2_map, forallb2_refl; intro; apply eqb_refl. + rewrite /compare_universe_instance. + rewrite forallb2_map; eapply forallb2_refl; intro; apply eqb_refl. Qed. Lemma eq_dec_to_bool_refl {A} {ea : Classes.EqDec A} (x : A) : @@ -1260,42 +1608,11 @@ Lemma eqb_term_upto_univ_refl : eqb_term_upto_univ_napp Σ eqb leqb napp t t. Proof. intros Σ eqb leqb napp t eqb_refl leqb_refl. - induction t using term_forall_list_ind in napp, leqb, leqb_refl |- *. - all: simpl. - all: rewrite -> ?Nat.eqb_refl, ?eq_string_refl, ?eq_kername_refl, ?eq_inductive_refl, ?eqb_annot_refl. - all: repeat rewrite -> eq_prod_refl - by (eauto using eq_prod_refl, Nat.eqb_refl, eq_string_refl, eq_inductive_refl, eqb_annot_refl). - all: repeat lazymatch goal with - | ih : forall leqb napp, _ -> @?P leqb napp |- _ => - rewrite -> ih by assumption ; clear ih - end. - all: simpl. - all: try solve [ eauto ]. - - induction X. - + reflexivity. - + simpl. rewrite -> p by assumption. auto. - - eapply forallb2_map. eapply forallb2_refl. - intro l. eapply eqb_refl. - - eapply compare_global_instance_refl; auto. - - eapply compare_global_instance_refl; auto. - - induction X. - + reflexivity. - + simpl. rewrite Nat.eqb_refl. rewrite -> p0 by assumption. - assumption. - - induction X. - + reflexivity. - + simpl. rewrite Nat.eqb_refl. - destruct p as [e1 e2]. - rewrite -> e1 by assumption. rewrite -> e2 by assumption. - rewrite eqb_annot_refl. - assumption. - - induction X. - + reflexivity. - + simpl. rewrite -> Nat.eqb_refl. - destruct p as [e1 e2]. - rewrite -> e1 by assumption. rewrite -> e2 by assumption. - rewrite eqb_annot_refl; assumption. - - apply eq_dec_to_bool_refl. + case: (reflect_eq_term_upto_univ Σ eqb leqb eqb leqb napp _ _ t t) => //. + * intros. eapply equiv_reflectT; auto. + * intros. eapply equiv_reflectT; auto. + * intros. + unshelve epose proof (eq_term_upto_univ_refl Σ eqb leqb napp _ _); eauto. Qed. (** ** Behavior on mkApps and it_mkLambda_or_LetIn ** *) @@ -1398,58 +1715,17 @@ Proof. rewrite Nat.add_0_r in H; auto. Qed. -Lemma eq_term_upto_univ_it_mkLambda_or_LetIn Σ Re Rle Γ : - RelationClasses.Reflexive Re -> - respectful (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) - (it_mkLambda_or_LetIn Γ) (it_mkLambda_or_LetIn Γ). +Lemma R_universe_instance_eq {u u'} : R_universe_instance eq u u' -> u = u'. Proof. - intros he u v h. - induction Γ as [| [na [b|] A] Γ ih ] in u, v, h |- *. - - assumption. - - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. - all: auto. - - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. - all: auto. + intros H. + apply Forall2_eq in H. apply map_inj in H ; revgoals. + { apply Universe.make_inj. } + subst. constructor ; auto. Qed. -Lemma eq_term_it_mkLambda_or_LetIn {cf:checker_flags} Σ φ Γ : - respectful (eq_term Σ φ) (eq_term Σ φ) - (it_mkLambda_or_LetIn Γ) (it_mkLambda_or_LetIn Γ). +Lemma valid_constraints_empty {cf} i : valid_constraints (empty_ext []) (subst_instance_cstrs i (empty_ext [])). Proof. - apply eq_term_upto_univ_it_mkLambda_or_LetIn; exact _. -Qed. - -Lemma eq_term_upto_univ_it_mkProd_or_LetIn Σ Re Rle Γ : - RelationClasses.Reflexive Re -> - respectful (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) - (it_mkProd_or_LetIn Γ) (it_mkProd_or_LetIn Γ). -Proof. - intros he u v h. - induction Γ as [| [na [b|] A] Γ ih ] in u, v, h |- *. - - assumption. - - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. - all: auto. - - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. - all: auto. -Qed. - -Lemma eq_term_it_mkProd_or_LetIn {cf:checker_flags} Σ φ Γ: - respectful (eq_term Σ φ) (eq_term Σ φ) - (it_mkProd_or_LetIn Γ) (it_mkProd_or_LetIn Γ). -Proof. - eapply eq_term_upto_univ_it_mkProd_or_LetIn ; exact _. -Qed. - -Lemma eq_term_it_mkLambda_or_LetIn_inv {cf:checker_flags} Σ φ Γ u v : - eq_term Σ φ (it_mkLambda_or_LetIn Γ u) (it_mkLambda_or_LetIn Γ v) -> - eq_term Σ φ u v. -Proof. - revert u v. induction Γ as [| [na [b|] A] Γ ih ] ; intros u v h. - - assumption. - - simpl in h. cbn in h. apply ih in h. inversion h. subst. - assumption. - - simpl in h. cbn in h. apply ih in h. inversion h. subst. - assumption. + red. destruct check_univs => //. Qed. Lemma upto_eq_impl Σ Re Rle : @@ -1525,35 +1801,25 @@ Proof. all: reflexivity. Qed. - (** ** Equality on contexts ** *) -Inductive eq_context_upto Σ (Re Rle : Universe.t -> Universe.t -> Prop) : context -> context -> Type := -| eq_context_nil : eq_context_upto Σ Re Rle [] [] -| eq_context_vass na A Γ nb B Δ : - eq_binder_annot na nb -> - eq_term_upto_univ Σ Re Rle A B -> - eq_context_upto Σ Re Rle Γ Δ -> - eq_context_upto Σ Re Rle (Γ ,, vass na A) (Δ ,, vass nb B) -| eq_context_vdef na u A Γ nb v B Δ : - eq_binder_annot na nb -> - eq_term_upto_univ Σ Re Re u v -> - eq_term_upto_univ Σ Re Rle A B -> - eq_context_upto Σ Re Rle Γ Δ -> - eq_context_upto Σ Re Rle (Γ ,, vdef na u A) (Δ ,, vdef nb v B). +Notation eq_context_upto Σ Re Rle := + (eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Rle)). Inductive rel_option {A B} (R : A -> B -> Type) : option A -> option B -> Type := | rel_some : forall a b, R a b -> rel_option R (Some a) (Some b) | rel_none : rel_option R None None. -Definition eq_decl_upto Σ Re Rle d d' : Type := +Derive Signature NoConfusion for rel_option. + +Definition eq_decl_upto_gen Σ Re Rle d d' : Type := eq_binder_annot d.(decl_name) d'.(decl_name) * rel_option (eq_term_upto_univ Σ Re Re) d.(decl_body) d'.(decl_body) * eq_term_upto_univ Σ Re Rle d.(decl_type) d'.(decl_type). (* TODO perhaps should be def *) Lemma All2_eq_context_upto Σ Re Rle : - subrelation (All2 (eq_decl_upto Σ Re Rle)) (eq_context_upto Σ Re Rle). + subrelation (All2 (eq_decl_upto_gen Σ Re Rle)) (eq_context_upto Σ Re Rle). Proof. intros Γ Δ h. induction h. @@ -1562,44 +1828,30 @@ Proof. destruct x as [na bo ty], y as [na' bo' ty']. simpl in h1, h2. destruct h2. - + constructor ; eauto. - + constructor ; eauto. + + constructor ; eauto. constructor; auto. + + constructor ; eauto. constructor; auto. Qed. Lemma eq_context_upto_refl Σ Re Rle : RelationClasses.Reflexive Re -> RelationClasses.Reflexive Rle -> Reflexive (eq_context_upto Σ Re Rle). -Proof. - intros hRe hRle Γ. - induction Γ as [| [na [bo |] ty] Γ ih]. - - constructor. - - constructor ; eauto. - all: eapply eq_term_upto_univ_refl ; eauto. - - constructor ; eauto. - all: eapply eq_term_upto_univ_refl ; eauto. -Qed. +Proof. exact _. Qed. Lemma eq_context_upto_sym Σ Re Rle : RelationClasses.Symmetric Re -> RelationClasses.Symmetric Rle -> Symmetric (eq_context_upto Σ Re Rle). -Proof. - intros hRe hRle Γ Δ. - induction 1; constructor; eauto using eq_term_upto_univ_sym. - all:try now symmetry. - all:eapply eq_term_upto_univ_sym; auto. -Qed. +Proof. exact _. Qed. Lemma eq_context_upto_cat Σ Re Rle Γ Δ Γ' Δ' : eq_context_upto Σ Re Rle Γ Γ' -> eq_context_upto Σ Re Rle Δ Δ' -> eq_context_upto Σ Re Rle (Γ ,,, Δ) (Γ' ,,, Δ'). Proof. - intros h1 h2. induction h2 in Γ, Γ', h1 |- *. - - assumption. - - simpl. constructor ; eauto. - - simpl. constructor ; eauto. + intros. + eapply All2_fold_app; eauto. + apply (length_of X0). Qed. Lemma eq_context_upto_rev Σ Re Rle Γ Δ : @@ -1610,8 +1862,6 @@ Proof. - constructor. - rewrite 2!rev_cons. eapply eq_context_upto_cat ; eauto. constructor ; eauto. constructor. - - rewrite 2!rev_cons. eapply eq_context_upto_cat ; eauto. - constructor ; eauto. constructor. Qed. Lemma eq_context_upto_rev' : @@ -1625,9 +1875,6 @@ Proof. - simpl. eapply eq_context_upto_cat. + repeat constructor; assumption. + assumption. - - simpl. eapply eq_context_upto_cat. - + repeat constructor. all: assumption. - + assumption. Qed. Lemma eq_context_upto_length : @@ -1649,39 +1896,35 @@ Proof. intros re u v n l l'. induction 1; intros Hl. - rewrite !subst_context_nil. constructor. - - rewrite !subst_context_snoc; constructor; auto. - simpl. rewrite (eq_context_upto_length X). - apply eq_term_upto_univ_substs; auto. - - rewrite !subst_context_snoc; constructor; auto; - simpl; rewrite (eq_context_upto_length X). - apply eq_term_upto_univ_substs; auto. reflexivity. - apply eq_term_upto_univ_substs; auto. + - rewrite !subst_context_snoc; constructor; eauto. + depelim p; constructor; simpl; intuition auto; + rewrite -(length_of X); + apply eq_term_upto_univ_substs; auto. reflexivity. 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 (smash_context ctx x) (smash_context ctx' y). Proof. induction x in ctx, ctx', y |- *; intros eqctx eqt; inv eqt; simpl; - try split; auto; try constructor; auto. + try split; auto; try constructor; auto. depelim X0 => /=. - apply IHx; auto. apply eq_context_upto_cat; auto. - constructor; auto. constructor. + constructor; pcuic. - apply IHx; auto. eapply eq_context_upto_subst_context; eauto. typeclasses eauto. Qed. Lemma eq_context_upto_nth_error Σ Re Rle ctx ctx' n : eq_context_upto Σ Re Rle ctx ctx' -> - rel_option (eq_decl_upto Σ Re Rle) (nth_error ctx n) (nth_error ctx' n). + 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. - constructor. split; auto. constructor. now simpl. - constructor. - - destruct n; simpl; auto. - constructor. constructor; simpl; auto. split; auto. - constructor; auto. + constructor. depelim p; constructor; intuition auto; + now constructor. Qed. Lemma eq_context_impl : @@ -1695,46 +1938,75 @@ Proof. induction h. - constructor. - constructor; auto. - eapply eq_term_upto_univ_impl. 5:eauto. all: try eassumption. - now transitivity Re'. - auto. - - constructor; auto. - all: eapply eq_term_upto_univ_impl. 5:eauto. 9:eauto. all: try eassumption. all:auto. - now transitivity Re'. -Qed. - -Section ContextUpTo. - Context (Σ : global_env). - Context (Re : Universe.t -> Universe.t -> Prop). - Context (ReR : RelationClasses.Reflexive Re). - Context (ReS : RelationClasses.Symmetric Re). - Context (ReT : RelationClasses.Transitive Re). - Context (Rle : Universe.t -> Universe.t -> Prop). - Context (RleR : RelationClasses.Reflexive Rle). - Context (RleS : RelationClasses.Symmetric Rle). - Context (RleT : RelationClasses.Transitive Rle). - - Notation eq_ctx := (eq_context_upto Σ Re Rle). - - Global Instance eq_ctx_refl : Reflexive eq_ctx. - Proof. now intros ?; apply eq_context_upto_refl. Qed. - - Global Instance eq_ctx_sym : Symmetric eq_ctx. - Proof. - intros x y. now apply eq_context_upto_sym. - Qed. - - Global Instance eq_ctx_trans : Transitive eq_ctx. - Proof. - intros Γ0 Γ1 Γ2 H. induction H in Γ2 |- *. - - intros H2; inversion H2; subst; constructor; auto. - - intros H2; inversion H2; subst; constructor; auto. - all:etransitivity; eauto. - - intros H2; inversion H2; subst; constructor; auto. - all: etransitivity; eauto. - Qed. - -End ContextUpTo. + depelim p; constructor; auto. + all:eapply eq_term_upto_univ_impl. 5,10,15:tea. all:eauto. + all:now transitivity Re'. +Qed. + +Lemma eq_term_upto_univ_it_mkLambda_or_LetIn Σ Re Rle : + RelationClasses.Reflexive Re -> + Proper (eq_context_upto Σ Re Re ==> eq_term_upto_univ Σ Re Rle ==> eq_term_upto_univ Σ Re Rle) it_mkLambda_or_LetIn. +Proof. + intros he Γ Δ eq u v h. + induction eq in u, v, h, he |- *. + - assumption. + - simpl. cbn. apply IHeq => //. + destruct p; cbn; constructor ; tas; try reflexivity. +Qed. + +Lemma eq_term_upto_univ_it_mkLambda_or_LetIn_r Σ Re Rle Γ : + RelationClasses.Reflexive Re -> + respectful (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) + (it_mkLambda_or_LetIn Γ) (it_mkLambda_or_LetIn Γ). +Proof. + intros he u v h. + induction Γ as [| [na [b|] A] Γ ih ] in u, v, h |- *. + - assumption. + - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. + all: auto. + - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. + all: auto. +Qed. + +Lemma eq_term_it_mkLambda_or_LetIn {cf:checker_flags} Σ φ Γ : + respectful (eq_term Σ φ) (eq_term Σ φ) + (it_mkLambda_or_LetIn Γ) (it_mkLambda_or_LetIn Γ). +Proof. + apply eq_term_upto_univ_it_mkLambda_or_LetIn_r; exact _. +Qed. + +Lemma eq_term_upto_univ_it_mkProd_or_LetIn Σ Re Rle Γ : + RelationClasses.Reflexive Re -> + respectful (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) + (it_mkProd_or_LetIn Γ) (it_mkProd_or_LetIn Γ). +Proof. + intros he u v h. + induction Γ as [| [na [b|] A] Γ ih ] in u, v, h |- *. + - assumption. + - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. + all: auto. + - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. + all: auto. +Qed. + +Lemma eq_term_it_mkProd_or_LetIn {cf:checker_flags} Σ φ Γ: + respectful (eq_term Σ φ) (eq_term Σ φ) + (it_mkProd_or_LetIn Γ) (it_mkProd_or_LetIn Γ). +Proof. + eapply eq_term_upto_univ_it_mkProd_or_LetIn ; exact _. +Qed. + +Lemma eq_term_it_mkLambda_or_LetIn_inv {cf:checker_flags} Σ φ Γ u v : + eq_term Σ φ (it_mkLambda_or_LetIn Γ u) (it_mkLambda_or_LetIn Γ v) -> + eq_term Σ φ u v. +Proof. + revert u v. induction Γ as [| [na [b|] A] Γ ih ] ; intros u v h. + - assumption. + - simpl in h. cbn in h. apply ih in h. inversion h. subst. + assumption. + - simpl in h. cbn in h. apply ih in h. inversion h. subst. + assumption. +Qed. Definition compare_term `{checker_flags} (le : bool) Σ φ (t u : term) := if le then leq_term Σ φ t u else eq_term Σ φ t u. @@ -1754,29 +2026,26 @@ Definition eq_opt_term `{checker_flags} (le : bool) Σ φ (t u : option term) := end. Definition eq_decl `{checker_flags} le Σ φ (d d' : context_decl) := - eq_binder_annot d.(decl_name) d'.(decl_name) * - eq_opt_term false Σ φ d.(decl_body) d'.(decl_body) * compare_term le Σ φ d.(decl_type) d'.(decl_type). + compare_decls (eq_term Σ φ) (if le then leq_term Σ φ else eq_term Σ φ) d d'. Definition eq_context `{checker_flags} le Σ φ (Γ Δ : context) := - All2 (eq_decl le Σ φ) Γ Δ. + eq_context_gen (eq_term Σ φ) (if le then leq_term Σ φ else eq_term Σ φ) Γ Δ. -Lemma lift_eq_decl `{checker_flags} le Σ ϕ n k d d' : +Lemma lift_compare_decls `{checker_flags} le Σ ϕ n k d d' : eq_decl le Σ ϕ d d' -> eq_decl le Σ ϕ (lift_decl n k d) (lift_decl n k d'). Proof. - destruct d, d', decl_body, decl_body0; - unfold eq_decl, map_decl; cbn; intuition auto using lift_compare_term, lift_eq_term. + intros []; destruct le; constructor; cbn; intuition auto using lift_compare_term, lift_eq_term, lift_leq_term. Qed. Lemma lift_eq_context `{checker_flags} le Σ φ l l' n k : eq_context le Σ φ l l' -> eq_context le Σ φ (lift_context n k l) (lift_context n k l'). Proof. - induction l in l', n, k |- *; intros; destruct l'; rewrite -> ?lift_context_snoc0. - constructor. - all: inversion X; subst. constructor. - - apply All2_length in X1. rewrite X1. - now apply lift_eq_decl. - - now apply IHl. + unfold eq_context. + induction 1; rewrite -> ?lift_context_snoc0. constructor. + constructor; auto. + eapply lift_compare_decls in p. + now rewrite (All2_fold_length X). Qed. Lemma eq_term_upto_univ_mkApps_inv Σ Re Rle u l u' l' : @@ -1898,10 +2167,9 @@ Proof. induction 1; intros; constructor; intuition auto. all:try solve [now symmetry]. all:eauto using R_global_instance_flip. - - eapply Forall2_sym. eapply Forall2_map_inv in r. - eapply Forall2_map. solve_all. - eapply All2_sym. solve_all. - simpl in *. subst. now eapply eq_term_upto_univ_sym. + * 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. now eapply eq_term_upto_univ_sym. diff --git a/safechecker/theories/PCUICEqualityDec.v b/pcuic/theories/PCUICEqualityDec.v similarity index 85% rename from safechecker/theories/PCUICEqualityDec.v rename to pcuic/theories/PCUICEqualityDec.v index 0c12c3d60..137130724 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/pcuic/theories/PCUICEqualityDec.v @@ -39,7 +39,7 @@ Section EqualityDec. eq_termp_napp pb Σ napp t u. Proof. pose proof hΣ'. - apply eqb_term_upto_univ_impl. + apply PCUICEquality.eqb_term_upto_univ_impl. - intros u1 u2. eapply (check_eqb_universe_spec' G (global_ext_uctx Σ)). + sq. now eapply wf_ext_global_uctx_invariants. @@ -55,6 +55,20 @@ Section EqualityDec. * sq; now eapply wf_ext_global_uctx_invariants. * sq; now eapply global_ext_uctx_consistent. * assumption. + - intros u1 u2. + destruct pb. + + eapply (check_eqb_universe_spec' G (global_ext_uctx Σ)). + * sq. now eapply wf_ext_global_uctx_invariants. + * sq; now eapply global_ext_uctx_consistent. + * assumption. + + simpl. + intros cu. + eapply eq_universe_leq_universe. + revert cu. + eapply (check_eqb_universe_spec' G (global_ext_uctx Σ)). + * sq. now eapply wf_ext_global_uctx_invariants. + * sq; now eapply global_ext_uctx_consistent. + * assumption. Qed. Definition eqb_termp pb := (eqb_termp_napp pb 0). @@ -86,15 +100,6 @@ Section EqualityDec. all: apply check_eqb_universe_refl. Qed. - Definition eqb_binder_annot {A} (b b' : binder_annot A) : bool := - eqb b.(binder_relevance) b'.(binder_relevance). - - Lemma eq_binder_annot_reflect {A} na na' : reflect (eq_binder_annot (A:=A) na na') (eqb_binder_annot na na'). - Proof. - unfold eq_binder_annot, eqb_binder_annot. - destruct (eqb_spec na.(binder_relevance) na'.(binder_relevance)); constructor; auto. - Qed. - Fixpoint eqb_ctx (Γ Δ : context) : bool := match Γ, Δ with | [], [] => true @@ -108,7 +113,7 @@ Section EqualityDec. end. Lemma eqb_binder_annot_spec {A} na na' : eqb_binder_annot (A:=A) na na' -> eq_binder_annot (A:=A) na na'. - Proof. apply (elimT (eq_binder_annot_reflect _ _)). Qed. + Proof. case: eqb_annot_reflect => //. Qed. Lemma eqb_ctx_spec : forall Γ Δ, @@ -121,16 +126,14 @@ Section EqualityDec. all: try discriminate. - constructor. - simpl in h. apply andb_andI in h as [[[h1 h2]%andb_and h3]%andb_and h4]. - constructor. + constructor; auto; constructor; auto. + now apply eqb_binder_annot_spec in h1. + eapply eqb_term_spec. assumption. + eapply eqb_term_spec. assumption. - + eapply ih. assumption. - simpl in h. apply andb_and in h as [[h1 h2]%andb_and h3]. - constructor. + constructor; auto; constructor. + now apply eqb_binder_annot_spec. + eapply eqb_term_spec. assumption. - + eapply ih. assumption. Qed. Definition eqb_opt_term (t u : option term) := @@ -158,7 +161,8 @@ Section EqualityDec. intro H. rtoProp. apply eqb_opt_term_spec in H1. eapply eqb_term_spec in H0; tea. eapply eqb_binder_annot_spec in H. - repeat split; eauto. + destruct d as [na [b|] ty], d' as [na' [b'|] ty']; simpl in * => //; + repeat constructor; eauto. Qed. Definition eqb_context (Γ Δ : context) := forallb2 eqb_decl Γ Δ. @@ -168,6 +172,7 @@ Section EqualityDec. Proof. unfold eqb_context, eq_context. intro HH. apply forallb2_All2 in HH. + eapply PCUICContextRelation.All2_fold_All2. eapply All2_impl; try eassumption. cbn. apply eqb_decl_spec. Qed. diff --git a/pcuic/theories/PCUICExchange.v b/pcuic/theories/PCUICExchange.v new file mode 100644 index 000000000..4c028d39a --- /dev/null +++ b/pcuic/theories/PCUICExchange.v @@ -0,0 +1,260 @@ + +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Morphisms. +From MetaCoq.Template Require Import config utils. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction + PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICTyping PCUICWeakeningEnv + PCUICClosed PCUICReduction PCUICPosition PCUICGeneration + PCUICSigmaCalculus PCUICRename PCUICOnFreeVars. + +Require Import ssreflect ssrbool. +From Equations Require Import Equations. + +Implicit Types cf : checker_flags. + +(* l, r, p -> r, l, p *) +Definition exchange_renaming l r p := + fun i => + if p <=? i then + if p + r <=? i then + if p + r + l <=? i then i + else i - r + else i + l + else i. + +Variant exchange_renaming_spec l r p i : nat -> Type := +| exch_below : i < p -> exchange_renaming_spec l r p i i +| exch_right : p <= i < p + r -> exchange_renaming_spec l r p i (i + l) +| exch_left : p + r <= i < p + r + l -> exchange_renaming_spec l r p i (i - r) +| exch_above : p + r + l <= i -> exchange_renaming_spec l r p i i. + +Lemma exchange_renamingP l r p i : + exchange_renaming_spec l r p i (exchange_renaming l r p i). +Proof. + unfold exchange_renaming. + case: leb_spec_Set; [|constructor; auto]. + elim: leb_spec_Set; [|constructor; auto]. + elim: leb_spec_Set; [|constructor; auto]. + intros. + constructor 4; auto. +Qed. + +Lemma shiftn_exchange_renaming n l r p : + shiftn n (exchange_renaming l r p) =1 + exchange_renaming l r (n + p). +Proof. + intros i. + case: exchange_renamingP. + * case: shiftnP; try lia. + case: exchange_renamingP; lia. + * case: shiftnP; try lia. + case: exchange_renamingP; lia. + * case: shiftnP; try lia. + case: exchange_renamingP; lia. + * case: shiftnP; try lia. + case: exchange_renamingP; lia. +Qed. + +Lemma exchange_renaming_lift_renaming l r p i k : + i < p -> + exchange_renaming l r p (lift_renaming (S i) 0 k) = + lift_renaming (S i) 0 + (shiftn (p - S i) (exchange_renaming l r 0) k). +Proof. + intros ip. + rewrite shiftn_exchange_renaming. + rewrite /lift_renaming /=. + case: exchange_renamingP; try lia; intros Hp. + all: case: exchange_renamingP; lia. +Qed. + +Definition exchange_contexts Γ Γl Γr Δ := + (Γ ,,, rename_context (strengthen 0 #|Γl|) Γr ,,, + rename_context (lift_renaming #|Γr| 0) Γl ,,, + rename_context (exchange_renaming #|Γl| #|Γr| 0) Δ). + +Definition exchange_rename Γl Γr Δ i := + if Δ <=? i then + if Δ + Γr <=? i then + if Δ + Γr + Γl <=? i then ren_id + else (lift_renaming Γr (Γl - S (i - Γr - Δ))) + else (shiftn (Γr - S (i - Δ)) (strengthen 0 Γl)) + else (exchange_renaming Γl Γr (Δ - S i)). + +Lemma lookup_exchange_contexts Γ Γl Γr Δ i : + nth_error (exchange_contexts Γ Γl Γr Δ) (exchange_renaming #|Γl| #|Γr| #|Δ| i) = + option_map (map_decl (rename (exchange_rename #|Γl| #|Γr| #|Δ| i))) + (nth_error (Γ ,,, Γl,,, Γr,,, Δ) i). +Proof. + rewrite /exchange_renaming /exchange_contexts /exchange_rename. + case: (leb_spec_Set #|Δ| i) => hΔ. + * case: leb_spec_Set => hΓr. + + case: leb_spec_Set => hΓl. + - do 6 (rewrite nth_error_app_ge; len; try lia => //). + assert (i - #|Δ| - #|Γl| - #|Γr| = i - #|Δ| - #|Γr| - #|Γl|) as -> by lia. + now rewrite rename_ren_id map_decl_id option_map_id. + - rewrite nth_error_app_ge; len; try lia => //. + rewrite nth_error_app_lt; len; try lia => //. + rewrite nth_error_app_ge; len; try lia => //. + rewrite nth_error_app_ge; len; try lia => //. + rewrite nth_error_app_lt; len; try lia => //. + rewrite nth_error_rename_context. + assert (i - #|Δ| - #|Γr| = i - #|Γr| - #|Δ|) as -> by lia. + apply option_map_ext => //. + intros d. apply map_decl_ext => t. + now rewrite shiftn_lift_renaming Nat.add_0_r. + + rewrite nth_error_app_ge; len; try lia => //. + rewrite nth_error_app_ge; len; try lia => //. + rewrite nth_error_app_lt; len; try lia => //. + rewrite nth_error_app_ge; len; try lia => //. + rewrite nth_error_app_lt; len; try lia => //. + rewrite nth_error_rename_context. + assert (i + #|Γl| - #|Δ| - #|Γl| = i - #|Δ|) as -> by lia. + reflexivity. + * rewrite nth_error_app_lt; len; try lia => //. + rewrite nth_error_app_lt; len; try lia => //. + rewrite nth_error_rename_context. + now rewrite shiftn_exchange_renaming Nat.add_0_r. +Qed. + +(* +Lemma exchange_renaming_add Γl Γr Δ n : + exchange_renaming Γl Γr Δ n = n + exchange_renaming Γl Γr Δ 0. +Proof. + case: exchange_renamingP; case: exchange_renamingP; simpl; try lia. + - intros. + *) + +Lemma exchange_rename_Δ Γl Γr Δ i (k : nat) : + (* noccur_between_ctx 0 Γl Γr -> *) + i < Δ -> + (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *) + exchange_renaming Γl Γr Δ (S i + k) = + S (i + exchange_renaming Γl Γr (Δ - S i) k). +Proof. + rewrite /exchange_renaming. + repeat nat_compare_specs; lia. +Qed. + +Lemma exchange_rename_Γr Γl Γr Δ i (k : nat) : + (* noccur_between_ctx 0 Γl Γr -> *) + Δ <= i < Δ + Γr -> + k < Γr - S (i - Δ) \/ Γr - S (i - Δ) + Γl <= k -> + (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *) + exchange_renaming Γl Γr Δ (S i + k) = + S (i + Γl + strengthen (Γr - S (i - Δ)) Γl k). +Proof. + rewrite /exchange_renaming /strengthen. + repeat nat_compare_specs. +Qed. +(* +Lemma exchange_rename_Γl Γl Γr Δ i (k : nat) : + (* noccur_between_ctx 0 Γl Γr -> *) + Δ + Γr <= i < Δ + Γr + Γl -> + (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *) + exchange_renaming Γl Γr Δ (S i + k) = + S (i + exchange_renaming Γl Γr (Δ - S i) k). +Proof. + rewrite /exchange_renaming. + repeat nat_compare_specs; lia. +Qed. *) + + +Lemma exchange_lift_rename {Γ Γl Γr Δ : context} {i d} : + noccur_between_ctx 0 #|Γl| Γr -> + nth_error (Γ,,, Γl,,, Γr,,, Δ) i = Some d -> + rename_decl (fun k => exchange_renaming #|Γl| #|Γr| #|Δ| (S (i + k))) d = + rename_decl (fun k => S (exchange_renaming #|Γl| #|Γr| #|Δ| i + exchange_rename #|Γl| #|Γr| #|Δ| i k)) d. +Proof. + intros nocc hlen. + move: hlen. + case: lookup_declP => // d' Hi hnth [=]; intros ->; [|move: hnth; len in Hi]. + { apply map_decl_ext, rename_ext => k. + rewrite {2}/exchange_renaming /exchange_rename. nat_compare_specs. + now apply exchange_rename_Δ. } + case: lookup_declP => // d' Hi' hnth [=]; intros ->; [|move: hnth; len in Hi']. + { eapply nth_error_noccur_between_ctx in nocc; eauto. + simpl in nocc. move: nocc. + apply rename_decl_ext_cond => k Hk. + rewrite {2}/exchange_renaming /exchange_rename. + repeat nat_compare_specs. + rewrite shiftn_strengthen_rel Nat.add_0_r //. + now rewrite exchange_rename_Γr. } + case: lookup_declP => // d' Hi'' hnth [=]; intros ->; [|move: hnth; len in Hi'']. + { apply map_decl_ext, rename_ext => k. + rewrite /exchange_renaming /exchange_rename /lift_renaming; + repeat nat_compare_specs. } + { move/nth_error_Some_length => hlen. + apply map_decl_ext, rename_ext => k. + rewrite /exchange_renaming /exchange_rename; repeat nat_compare_specs. + now unfold ren_id. } +Qed. + +Lemma exchange_urenaming P Γ Γl Γr Δ : + noccur_between_ctx 0 #|Γl| Γr -> + urenaming P + (exchange_contexts Γ Γl Γr Δ) + (Γ ,,, Γl ,,, Γr ,,, Δ) + (exchange_renaming #|Γl| #|Γr| #|Δ|). +Proof. + intros nocc i d hpi hnth. + rewrite lookup_exchange_contexts hnth => /=. + eexists; split; eauto. + pose proof (exchange_lift_rename nocc hnth). + rewrite !rename_compose /lift_renaming /=. + destruct d as [na [b|] ty]; noconf H; simpl in *. + - split => //. + split => //. + f_equal. + rewrite !rename_compose. + rewrite /lift_renaming /= //. + - split => //. +Qed. + + +Lemma exchange_wf_local {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γl Γr Δ} : + noccur_between_ctx 0 #|Γl| Γr -> + wf_local Σ (Γ ,,, Γl ,,, Γr ,,, Δ) -> + wf_local Σ (exchange_contexts Γ Γl Γr Δ). +Proof. + intros nocc wf. + pose proof (env_prop_wf_local _ _ typing_rename_prop _ wfΣ _ wf). + simpl in X. rewrite /exchange_contexts. + eapply All_local_env_app_inv in X as [XΓ XΓ']. + apply wf_local_app_ind => //. + - rewrite rename_context_lift_context /strengthen /=. + eapply weakening_wf_local_eq; eauto with wf. + * admit. + * now len. + - intros wfstr. + apply All_local_env_fold. + eapply (All_local_env_impl_ind XΓ'). + intros Δ' t [T|] IH; unfold lift_typing; simpl. + * intros Hf. red. + eapply meta_conv_all. 2: reflexivity. + 2-3:now rewrite shiftn_exchange_renaming. + apply Hf. split. + + apply wf_local_app; auto. + apply All_local_env_fold in IH. apply IH. + + setoid_rewrite shiftn_exchange_renaming. apply exchange_urenaming. + - intros [s Hs]; exists s. red. + rewrite -/(lift_context #|Γ''| 0 Δ). + rewrite Nat.add_0_r !lift_rename. apply Hs. + split. + + apply wf_local_app; auto. + apply All_local_env_fold in IH. apply IH. + + apply (weakening_renaming Γ Δ Γ''). +Qed. + +Lemma exchange_typing `{cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} {t T} : + wf_local Σ (Γ ,,, Γ'') -> + Σ ;;; Γ ,,, Γ' |- t : T -> + Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| t : lift #|Γ''| #|Γ'| T. +Proof. + intros wfext Ht. + rewrite !lift_rename. + eapply (env_prop_typing _ _ typing_rename_prop); eauto. + split. + - eapply weakening_wf_local; eauto with pcuic. + - now apply weakening_renaming. +Qed. diff --git a/pcuic/theories/PCUICGeneration.v b/pcuic/theories/PCUICGeneration.v index 40755651e..ee4058295 100644 --- a/pcuic/theories/PCUICGeneration.v +++ b/pcuic/theories/PCUICGeneration.v @@ -5,11 +5,6 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst PCUICTyping. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. -Derive NoConfusion NoConfusionHom for term. -Derive NoConfusion NoConfusionHom for context_decl. -Derive NoConfusion NoConfusionHom for list. -Derive NoConfusion NoConfusionHom for option. - Section Generation. Context `{cf : config.checker_flags}. diff --git a/pcuic/theories/PCUICGlobalEnv.v b/pcuic/theories/PCUICGlobalEnv.v index bc59d5ee4..f588f6e46 100644 --- a/pcuic/theories/PCUICGlobalEnv.v +++ b/pcuic/theories/PCUICGlobalEnv.v @@ -21,12 +21,12 @@ Proof. destruct H2 as [HH1 [HH HH3]]. subst udecl. destruct d as [decl|decl]; simpl in *. ++ destruct decl; simpl in *. - destruct cst_universes ; [ + destruct cst_universes0 ; [ eapply (HH (l, ct, l') Hctr) | apply ConstraintSetFact.empty_iff in Hctr ; contradiction ]. ++ destruct decl. simpl in *. - destruct ind_universes ; [ + destruct ind_universes0 ; [ eapply (HH (l, ct, l') Hctr) | apply ConstraintSetFact.empty_iff in Hctr; contradiction ]. @@ -35,12 +35,12 @@ Proof. subst udecl. destruct d as [decl|decl]. all: simpl in *. ++ destruct decl. simpl in *. - destruct cst_universes ; [ + destruct cst_universes0 ; [ eapply (HH (l, ct, l') Hctr) | apply ConstraintSetFact.empty_iff in Hctr; contradiction ]. ++ destruct decl. simpl in *. - destruct ind_universes; [ + destruct ind_universes0; [ eapply (HH (l, ct, l') Hctr) | apply ConstraintSetFact.empty_iff in Hctr; contradiction ]. @@ -79,9 +79,9 @@ Proof. apply ConstraintSet.union_spec in Hc. destruct Hc. apply ConstraintSet.union_spec; simpl. + left. destruct d. - destruct c, cst_universes. assumption. + destruct c, cst_universes0. assumption. apply ConstraintSetFact.empty_iff in H; contradiction. - destruct m, ind_universes. assumption. + destruct m, ind_universes0. assumption. apply ConstraintSetFact.empty_iff in H; contradiction. + apply ConstraintSet.union_spec; simpl. now right. diff --git a/pcuic/theories/PCUICInduction.v b/pcuic/theories/PCUICInduction.v index 22194a6b9..2c25e6051 100644 --- a/pcuic/theories/PCUICInduction.v +++ b/pcuic/theories/PCUICInduction.v @@ -1,11 +1,18 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import utils. -From MetaCoq.PCUIC Require Import PCUICAst. +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 PCUICSize. -Require Import List Program Lia. -Require Import BinPos. -Require Import Coq.Arith.Compare_dec Bool. +From Coq Require Import List. +From Equations Require Import Equations. +From Equations.Prop Require Import Subterm. + Set Asymmetric Patterns. +Import PCUICEnvTyping. + +(** Derive the well-founded subterm relation for terms. Not so useful + yet as it doesn't go throught lists. + *) +(* Derive Subterm for term. *) (** * Deriving a compact induction principle for terms @@ -30,9 +37,9 @@ Lemma term_forall_list_ind : (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 (p : inductive * nat) (t : term), - P t -> forall t0 : term, P t0 -> forall l : list (nat * term), - tCaseBrsProp P l -> P (tCase p t t0 l)) -> + (forall (ind : case_info) (p : predicate term), + tCasePredProp P P p -> forall c : term, P c -> forall l : list (branch term), + tCaseBrsProp P l -> P (tCase ind p c l)) -> (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)) -> @@ -45,36 +52,43 @@ Proof. destruct t; match goal with H : _ |- _ => apply H end; auto. - revert l. - fix auxl' 1. - destruct l; constructor; [|apply auxl']. - apply auxt. - revert brs. - fix auxl' 1. - destruct brs; constructor; [|apply auxl']. - apply auxt. - - revert mfix. - fix auxm 1. - destruct mfix; constructor; [|apply auxm]. - split; apply auxt. - revert mfix. - fix auxm 1. - destruct mfix; constructor; [|apply auxm]. - split; apply auxt. + * revert l. + fix auxl' 1. + destruct l; constructor; [|apply auxl']. + apply auxt. + * split. + generalize (pparams p). + fix auxl' 1. + destruct l; constructor; [|apply auxl']. apply auxt. + split. + + generalize (pcontext p). + fix auxc 1. + destruct l; constructor; [|apply auxc]. + destruct c. split. apply auxt. + simpl. destruct decl_body; simpl. apply auxt. constructor. + + apply auxt. + + * revert brs. + fix auxl' 1. + destruct brs; constructor; [|apply auxl']. + split. + + generalize (bcontext b). + fix auxc 1. + destruct l; constructor; [|apply auxc]. + destruct c. split. apply auxt. + simpl. destruct decl_body; simpl. apply auxt. constructor. + + apply auxt. + + * revert mfix. + fix auxm 1. + destruct mfix; constructor; [|apply auxm]. + split; apply auxt. + * revert mfix. + fix auxm 1. + destruct mfix; constructor; [|apply auxm]. + split; apply auxt. Defined. - -Inductive ForallT {A} (P : A -> Type) : list A -> Type := -| ForallT_nil : ForallT P [] -| ForallT_cons : forall (x : A) (l : list A), P x -> ForallT P l -> ForallT P (x :: l). - -Definition tCaseBrsType {A} (P : A -> Type) (l : list (nat * A)) := - ForallT (fun x => P (snd x)) l. - -Definition tFixType {A : Set} (P P' : A -> Type) (m : mfixpoint A) := - ForallT (fun x : def A => P x.(dtype) * P' x.(dbody))%type m. - Lemma size_decompose_app_rec t L : list_size size L + size t = size (decompose_app_rec t L).1 + list_size size (decompose_app_rec t L).2. Proof. @@ -108,7 +122,7 @@ Qed. Lemma decompose_app_size_tApp1 t1 t2 : size (decompose_app (tApp t1 t2)).1 < size (tApp t1 t2). Proof. - rewrite size_decompose_app with (t := tApp t1 t2). cbn. + rewrite -> size_decompose_app with (t := tApp t1 t2). cbn. pose proof (decompose_app_rec_length t1 [t2]). cbn in H. pose proof (list_size_length size (decompose_app_rec t1 [t2]).2). lia. @@ -128,7 +142,7 @@ Proof. Qed. Definition mkApps_decompose_app_rec t l : - mkApps t l = mkApps (fst (decompose_app_rec t l)) (snd (decompose_app_rec t l)). + mkApps t l = mkApps (fst (decompose_app_rec t l)) (snd (decompose_app_rec t l)). Proof. revert l; induction t; try reflexivity. intro l; cbn in *. @@ -174,7 +188,7 @@ Definition mkApps_decompose_app t : intro y. simpl. - rewrite (IHl y). + rewrite -> (IHl y). rewrite app_assoc; trivial. Defined. @@ -213,6 +227,18 @@ Definition mkApps_decompose_app t : From Equations Require Import Equations. +Lemma liftP_ctx_ind (P : term -> Type) (ctx : context) : + (forall y, size y < context_size size ctx -> P y) -> + All (ondecl P) ctx. +Proof. + induction ctx; simpl; constructor; auto. + * split. + + apply X; cbn. unfold decl_size. simpl. lia. + + destruct decl_body eqn:db; cbn. apply X; unfold decl_size. + rewrite db; simpl; lia. exact tt. + * apply IHctx; intros; apply X. lia. +Qed. + Lemma term_forall_mkApps_ind : forall P : term -> Type, (forall n : nat, P (tRel n)) -> @@ -223,13 +249,14 @@ Lemma term_forall_mkApps_ind : (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 : term, forall v, ~ isApp t -> P t -> All P v -> P (mkApps t v)) -> + (forall t : term, forall v, ~ isApp t -> P t -> v <> [] -> All P v -> P (mkApps t v)) -> (forall (s : kername) (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 (p : inductive * nat) (t : term), - P t -> forall t0 : term, P t0 -> forall l : list (nat * term), - tCaseBrsProp P l -> P (tCase p t t0 l)) -> + (forall (ind : case_info) (p : predicate term), + tCasePredProp P P p -> + forall c : term, P c -> forall l : list (branch term), + tCaseBrsProp P l -> P (tCase ind p c l)) -> (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)) -> @@ -250,17 +277,22 @@ Proof. destruct l; constructor. apply auxt. hnf; cbn; lia. apply auxt'. intros. apply auxt. hnf in *; cbn in *. lia. - - rewrite mkApps_decompose_app. + - 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). rewrite E in *. hnf in *; cbn in *. lia. + + 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. + pose proof (decompose_app_rec_notApp _ _ _ _ E). + eapply decompose_app_rec_inv in E. simpl in *. subst t => //. + induction l using rev_rec in E, auxt, t1, t2, t |- *. - * econstructor. + * constructor. * eapply All_app_inv. 2:{ econstructor. eapply auxt. hnf; cbn. - pose proof (decompose_app_size_tApp2 t1 t2). rewrite E in *. cbn in H. clear E. + 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. } destruct (isApp t1) eqn:Et1. -- destruct t1; try now inv Et1. @@ -268,11 +300,10 @@ Proof. eapply IHl. 2:{ eapply decompose_app_inv in E. rewrite <- mkApps_nested in E. - cbn in E. noconf E. rewrite H. - rewrite decompose_app_mkApps. reflexivity. - eapply decompose_app_notApp in E'. - now rewrite 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_nested in E. cbn in E. noconf E. intros. eapply auxt. @@ -281,13 +312,23 @@ Proof. econstructor. exfalso. pose proof (decompose_app_mkApps t1 [t2]). cbn in H. - cbn in E. rewrite H in E. + cbn in E. rewrite -> H in E. inversion E. destruct l; inv H3. now rewrite Et1. - - eapply X10; [apply auxt; hnf; cbn; lia.. | ]. rename brs into l. - 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. + - eapply X10; [|apply auxt; hnf; cbn; lia.. | ]. + repeat split; [| |apply auxt; hnf; cbn; unfold predicate_size; lia]. + * unfold MR in auxt. simpl in auxt. revert auxt. unfold predicate_size. + generalize (pparams p). + fix auxt' 1. + destruct l; constructor. apply auxt. hnf; cbn; lia. apply auxt'. intros. apply auxt. + hnf in *; cbn in *. lia. + * eapply liftP_ctx_ind. intros. apply auxt. red. simpl. unfold predicate_size. lia. + * rename brs into l. + revert l auxt. unfold MR; cbn. unfold branch_size. fix auxt' 1. + 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. - eapply X12; [apply auxt; hnf; cbn; lia.. | ]. rename mfix into l. revert l auxt. unfold MR; cbn. fix auxt' 1. destruct l; constructor. split. @@ -304,3 +345,308 @@ Proof. apply auxt'. intros. apply auxt. hnf in *; cbn in *. unfold mfixpoint_size, def_size in *. lia. Defined. + +Lemma liftP_ctx (P : term -> Type) : + (forall t, P t) -> + (forall ctx, All (ondecl P) ctx). +Proof. + induction ctx; simpl; constructor; auto. + split. + + apply X; cbn. + + destruct decl_body eqn:db; cbn. apply X; unfold decl_size. + exact tt. +Qed. + +Lemma ctx_length_ind (P : context -> Type) (p0 : P []) + (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (d :: Γ)) + Γ : P Γ. +Proof. + generalize (le_n #|Γ|). + generalize #|Γ| at 2. + induction n in Γ |- *. + destruct Γ; [|simpl; intros; elimtype False; lia]. + intros. apply p0. + intros. + destruct Γ; simpl in *. + apply p0. apply pS. intros. apply IHn. simpl. lia. +Qed. + +Lemma ctx_length_rev_ind (P : context -> Type) (p0 : P []) + (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (Γ ++ [d])) + Γ : P Γ. +Proof. + generalize (le_n #|Γ|). + generalize #|Γ| at 2. + induction n in Γ |- *. + destruct Γ using MCList.rev_ind; [|simpl; rewrite app_length; simpl; intros; elimtype False; try lia]. + intros. apply p0. + destruct Γ using MCList.rev_ind; simpl in *; rewrite ?app_length; simpl; intros Hlen. + intros. apply p0. + apply pS. intros. apply IHn. simpl. lia. +Qed. + +Lemma list_size_mapi_context_hom (size : context_decl -> nat) (l : context) (f : nat -> term -> term) : + (forall k x, size (map_decl (f k) x) = size x) -> + list_size size (mapi_context f l) = list_size size l. +Proof. + intros. + revert l. + fix auxl' 1. + destruct l; simpl. reflexivity. + f_equal. f_equal. apply H. apply auxl'. +Defined. + +Lemma decl_size_map_decl_hom (size : term -> nat) (d : context_decl) (f : term -> term) : + (forall x, size (f x) = size x) -> + decl_size size (map_decl f d) = decl_size size d. +Proof. + intros. + rewrite /map_decl /decl_size /=; destruct d as [na [b|] ty]; simpl; + f_equal; auto. +Defined. + +Lemma size_lift n k t : size (lift n k t) = size t. +Proof. + revert n k t. + fix size_lift 3. + destruct t; simpl; rewrite ?list_size_map_hom; try lia. + all:try now rewrite !size_lift. + all:try intros; auto. + - destruct x. simpl. unfold branch_size; cbn. + f_equal. + symmetry. + apply list_size_mapi_context_hom => k' x. + apply decl_size_map_decl_hom, size_lift. + symmetry; apply size_lift. + - f_equal. f_equal. f_equal. + unfold predicate_size; cbn. + 2:apply size_lift. + f_equal; [|apply size_lift]. + f_equal. cbn. + apply list_size_map_hom. intros. symmetry; auto. + unfold context_size. + apply list_size_mapi_context_hom => k' x. + apply decl_size_map_decl_hom, size_lift. + - unfold mfixpoint_size. + f_equal. + apply list_size_map_hom. intros. + simpl. destruct x. simpl. unfold def_size. simpl. + f_equal; symmetry; apply size_lift. + - unfold mfixpoint_size. + f_equal. + apply list_size_map_hom. intros. + simpl. destruct x. simpl. unfold def_size. simpl. + f_equal; symmetry; apply size_lift. +Qed. + +Definition on_local_decl (P : context -> term -> Type) + (Γ : context) (t : term) (T : option term) := + match T with + | Some T => (P Γ t * P Γ T)%type + | None => P Γ t + end. + +(* TODO: remove List.rev *) +Lemma list_size_rev {A} size (l : list A) + : list_size size (List.rev l) = list_size size l. +Proof. + induction l; simpl. reflexivity. + rewrite list_size_app IHl; cbn; lia. +Qed. + +Definition onctx_rel (P : context -> term -> Type) (Γ Δ : context) := + All_local_env (on_local_decl (fun Δ => P (Γ ,,, Δ))) Δ. + +Definition CasePredProp (P : context -> term -> Type) Γ (p : predicate term) := + All (P Γ) p.(pparams) × onctx_rel P Γ (pcontext p) × + P (Γ ,,, p.(pcontext)) p.(preturn). + +Definition CaseBrsProp P Γ (brs : list (branch term)) := + All (fun x : branch term => onctx_rel P Γ (bcontext x) * P (Γ ,,, bcontext x) (bbody x)) brs. + +Lemma term_forall_ctx_list_ind : + forall (P : context -> term -> Type), + (forall Γ (n : nat), P Γ (tRel n)) -> + (forall Γ (i : ident), P Γ (tVar i)) -> + (forall Γ (n : nat) (l : list term), All (P Γ) l -> P Γ (tEvar n l)) -> + (forall Γ s, P Γ (tSort s)) -> + (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P (vass n t :: Γ) t0 -> P Γ (tProd n t t0)) -> + (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), 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 -> + P Γ t -> + CaseBrsProp P Γ brs -> + P Γ (tCase ci p t brs)) -> + (forall Γ (s : projection) (t : term), P Γ t -> P Γ (tProj s t)) -> + (forall Γ (m : mfixpoint term) (n : nat), + All_local_env (on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) -> + tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tFix m n)) -> + (forall Γ (m : mfixpoint term) (n : nat), + All_local_env (on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) -> + tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tCoFix m n)) -> + (forall Γ p, P Γ (tPrim p)) -> + forall Γ (t : term), P Γ t. +Proof. + intros ????????????????? Γ t. + revert Γ t. set(foo:=CoreTactics.the_end_of_the_section). intros. + Subterm.rec_wf_rel aux t (MR lt size); unfold MR in *; simpl. clear H1. + assert (auxl : forall Γ {A} (l : list A) (f : A -> term), + list_size (fun x => size (f x)) l < size pr0 -> + All (fun x => P Γ (f x)) l). + { induction l; try solve [constructor]. + move=> f /= Hsize. + constructor. + * eapply aux => //. red. lia. + * apply IHl => //. lia. } + assert (forall mfix, context_size size (fix_context mfix) <= mfixpoint_size size mfix). + { induction mfix. simpl. auto. simpl. unfold fix_context. + unfold context_size. + rewrite list_size_rev /=. cbn. + rewrite size_lift. unfold context_size in IHmfix. + epose (list_size_mapi_rec_le (def_size size) (decl_size size) mfix + (fun (i : nat) (d : def term) => vass (dname d) ((lift0 i) (dtype d))) 1). + forward l. intros. destruct x; cbn; rewrite size_lift. lia. + unfold def_size, mfixpoint_size. lia. } + assert (auxΓ : forall Γ Δ, + context_size size Δ < size pr0 -> + onctx_rel P Γ Δ). + { move=> Γ Δ. + induction Δ; cbn. + - constructor. + - case: a => [na [b|] ty] /=; + rewrite {1}/decl_size /context_size /= => Hlt; constructor; auto. + + eapply IHΔ => //. unfold context_size. lia. + + simpl. apply aux => //. red. lia. + + simpl. split. + * apply aux => //. red. lia. + * apply aux=> //; red; lia. + + apply IHΔ => //; unfold context_size; lia. + + apply aux => //. red. lia. } + assert (forall m, list_size (fun x : def term => size (dtype x)) m < S (mfixpoint_size size m)). + { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } + assert (forall m, list_size (fun x : def term => size (dbody x)) m < S (mfixpoint_size size m)). + { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } + + move aux at top. move auxl at top. move auxΓ at top. + + destruct pr0; eauto; + (move: pr2=> /= /and3P [pr20 pr21 pr22] || move: pr2 => /= /andP [pr20 pr21] || idtac); + try match reverse goal with + |- context [tFix _ _] => idtac + | H : _ |- _ => solve [apply H; (eapply aux || eapply auxl); auto; red; simpl; try lia] + end. + + - eapply X10; eauto. + * red. split. + + eapply auxl; auto. simpl. unfold predicate_size, branch_size. + now change (fun x => size x) with size; lia. + + split. + ++ apply auxΓ. simpl. unfold predicate_size. lia. + ++ 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) => + aux Γ t ltac:(lia). + move: auxbr. + clear -auxΓ. + induction brs. simpl. constructor. + constructor. simpl in auxbr. + + 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. + - eapply X12; try (apply aux; red; simpl; lia). + apply auxΓ => //. simpl. specialize (H mfix). lia. + red. apply All_pair. split; apply auxl; simpl; auto. + + - eapply X13; try (apply aux; red; simpl; lia). + apply auxΓ => //. simpl. specialize (H mfix). lia. + red. apply All_pair. split; apply auxl; simpl; auto. +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 : + forall (P : term -> Type), + (forall (n : nat), P (tRel n)) -> + (forall (i : ident), P (tVar i)) -> + (forall (n : nat) (l : list term), All (P) l -> P (tEvar n l)) -> + (forall s, P (tSort s)) -> + (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> P (tProd n t t0)) -> + (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', size t' < size (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 : PCUICAst.predicate term) (c : term) (brs : list (branch term)), + tCasePredProp P P p -> P c -> + tCaseBrsProp P brs -> P (tCase ci p c brs)) -> + (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)) -> + (forall p, P (tPrim p)) -> + forall (t : term), P t. +Proof. + intros. + revert t. set(foo:=CoreTactics.the_end_of_the_section). intros. + Subterm.rec_wf_rel aux t (MR lt size); unfold MR in *; simpl. clear H0. + assert (auxl : forall {A} (l : list A) (f : A -> term), list_size (fun x => size (f x)) l < size pr1 -> + All (fun x => P (f x)) l). + { induction l; constructor. eapply aux. red. simpl in H. lia. apply IHl. simpl in H. lia. } + assert (forall m, list_size (fun x : def term => size (dtype x)) m < S (mfixpoint_size size m)). + { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } + assert (forall m, list_size (fun x : def term => size (dbody x)) m < S (mfixpoint_size size m)). + { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } + + move aux at top. move auxl at top. + + !destruct pr1; eauto; + try match reverse goal with + |- context [tFix _ _] => idtac + | H : _ |- _ => solve [apply H; (eapply aux || eapply auxl); red; simpl; try lia] + end. + + * eapply X10. 2:{ apply aux; simpl. simpl; lia. } + repeat split. + + revert aux; simpl; unfold predicate_size. + induction (pparams hh0); constructor; auto. + apply aux. simpl. lia. + apply IHl; intros. apply aux; simpl; lia. + + revert aux; simpl; unfold predicate_size. + induction (pcontext hh0); constructor; auto. + destruct a as [na [b|] ty]; constructor; simpl; + try (apply aux; cbn; lia). exact tt. + apply IHl; intros. apply aux; simpl; lia. + + apply aux; simpl. unfold predicate_size. lia. + + red. + revert aux; simpl. + clear. + induction hh1; simpl; constructor; auto. + revert aux. unfold branch_size. + induction (bcontext a); split; try constructor; auto. + apply aux. lia. + destruct a0 as [na [b|] ty]; constructor; simpl; + try (apply aux; cbn; lia). exact tt. + 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. + + * eapply X13; try (apply aux; red; simpl; lia). + red. apply All_pair. split; apply auxl; simpl; auto. +Defined. \ No newline at end of file diff --git a/pcuic/theories/PCUICInductiveInversion.v b/pcuic/theories/PCUICInductiveInversion.v index 8a886151c..fa51ef807 100644 --- a/pcuic/theories/PCUICInductiveInversion.v +++ b/pcuic/theories/PCUICInductiveInversion.v @@ -1,31 +1,27 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICWeakeningEnv PCUICWeakening + PCUICSigmaCalculus (* for smash_context lemmas, to move *) PCUICSubstitution PCUICClosed PCUICCumulativity PCUICGeneration PCUICReduction - PCUICEquality PCUICConfluence PCUICParallelReductionConfluence - PCUICContextConversion PCUICUnivSubstitution + PCUICEquality PCUICConfluence + PCUICContextConversion PCUICContextSubst PCUICUnivSubstitution PCUICConversion PCUICInversion PCUICContexts PCUICArities - PCUICParallelReduction PCUICCtxShape PCUICSpine PCUICInductives PCUICValidity. + PCUICSpine PCUICInductives PCUICValidity. -From Equations Require Import Equations. 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. Local Set SimplIsCbn. -Ltac len := autorewrite with len. -Hint Rewrite reln_length : len. +Implicit Types (cf : checker_flags) (Σ : global_env_ext). -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. +Hint Rewrite reln_length : len. Ltac substu := autorewrite with substu => /=. -Tactic Notation "len" "in" hyp(id) := - autorewrite with len in id; simpl in id. Tactic Notation "substu" "in" hyp(id) := autorewrite with substu in id; simpl in id. @@ -35,241 +31,6 @@ Proof. now intros H ->. Qed. (* TODO Move *) - -Lemma subst_consn_ids_ren n k f : (idsn n ⋅n (tRel k ⋅ ren f) =1 ren (ren_ids n ⋅n (subst_cons_gen k f)))%sigma. -Proof. - intros i. - destruct (Nat.leb_spec n i). - - rewrite subst_consn_ge idsn_length. auto. - unfold ren. f_equal. rewrite subst_consn_ge ren_ids_length; auto. - unfold subst_cons_gen. destruct (i - n) eqn:eqin. simpl. auto. simpl. reflexivity. - - assert (Hr:i < #|ren_ids n|) by (rewrite ren_ids_length; lia). - assert (Hi:i < #|idsn n|) by (rewrite idsn_length; lia). - destruct (subst_consn_lt Hi) as [x' [Hnth He]]. - destruct (subst_consn_lt Hr) as [x'' [Hnth' He']]. - rewrite (idsn_lt H) in Hnth. - rewrite (ren_ids_lt H) in Hnth'. - injection Hnth as <-. injection Hnth' as <-. rewrite He. - unfold ren. now rewrite He'. -Qed. - -Lemma subst_reli_lift_id i n t : i <= n -> - subst [tRel i] n (lift (S i) (S n) t) = (lift i n t). -Proof. - intros ltin. - sigma. - apply inst_ext. - unfold Upn. sigma. unfold shiftk at 1 => /=. - simpl. - rewrite ren_shiftk. rewrite subst_consn_ids_ren. - unfold lift_renaming. rewrite compose_ren. - intros i'. unfold ren, ids; simpl. f_equal. - elim: Nat.leb_spec => H'. unfold subst_consn, subst_cons_gen. - elim: nth_error_spec => [i'' e l|]. - rewrite ren_ids_length /= in l. lia. - rewrite ren_ids_length /=. - intros Hn. destruct (S (i + i') - n) eqn:?. lia. - elim: (Nat.leb_spec n i'). lia. lia. - unfold subst_consn, subst_cons_gen. - elim: nth_error_spec => [i'' e l|]. - rewrite (@ren_ids_lt n i') in e. rewrite ren_ids_length in l. auto. - noconf e. rewrite ren_ids_length in l. - elim: Nat.leb_spec; try lia. - rewrite ren_ids_length /=. - intros. destruct (i' - n) eqn:?; try lia. - elim: Nat.leb_spec; try lia. -Qed. - -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. - rewrite /expand_lets /expand_lets_k; len. - rewrite extended_subst_app /=. - rewrite subst_app_simpl. simpl. len. - rewrite !Nat.add_1_r. - rewrite subst_context_lift_id. f_equal. - rewrite Nat.add_succ_r. - rewrite subst_reli_lift_id //. - move: (context_assumptions_length_bound Γ); lia. -Qed. - -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 : - 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. - rewrite /expand_lets /expand_lets_k; len. - rewrite extended_subst_app /=. - rewrite subst_app_simpl. simpl. len. - rewrite !subst_empty lift0_id lift0_context. - epose proof (distr_lift_subst_rec _ [b] (context_assumptions Γ) (k + #|Γ|) 0). - rewrite !Nat.add_0_r in H. - f_equal. simpl in H. rewrite Nat.add_assoc. - rewrite <- H. - reflexivity. -Qed. - -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. - rewrite /expand_lets; apply expand_lets_k_vdef. -Qed. - -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. - 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. - rewrite /expand_lets_k_ctx lift_context_app subst_context_app /=; simpl. - unfold app_context. simpl. - rewrite /subst_context /fold_context /=. - f_equal. rewrite compose_map_decl. f_equal. -Qed. - -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. - rewrite !subst_extended_subst. - rewrite distr_subst. f_equal. - len. - now rewrite commut_lift_subst_rec. -Qed. - -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 /=; - autorewrite with len; f_equal; auto. - - rewrite IHΓ. - rewrite commut_lift_subst_rec. auto. lia. - rewrite distr_subst. now len. - - elim: Nat.leb_spec => //. lia. - - rewrite ? (lift_extended_subst _ 1); rewrite IHΓ. - rewrite !map_map_compose. apply map_ext. - intros x. - erewrite (commut_lift_subst_rec). lia_f_equal. - lia. -Qed. - -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. - unfold expand_lets, expand_lets_k; simpl; intros clx. - len. - rewrite !subst_extended_subst. - rewrite distr_subst. f_equal. - len. rewrite subst_closedn //. - rewrite Nat.add_assoc; eapply closedn_lift. - now rewrite Nat.add_comm. -Qed. - -Lemma map_expand_lets_subst_comm Γ s : - 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 Γ : - context_assumptions Γ = #|s| -> - subst0 (map (subst0 s) (extended_subst Γ 0)) =1 subst0 s ∘ expand_lets Γ. -Proof. - intros Hs x; unfold expand_lets, expand_lets_k. - rewrite distr_subst. f_equal. - len. - simpl. rewrite simpl_subst_k //. -Qed. - -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. - intros Hs; unfold expand_lets, expand_lets_k. - epose proof (distr_subst_rec _ _ _ 0 _). rewrite -> Nat.add_0_r in H. - rewrite -> H. clear H. f_equal. - len. - simpl. rewrite simpl_subst_k //. -Qed. - -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. - intros Hs. rewrite !subst_context_alt. - unfold expand_lets_ctx, expand_lets_k_ctx. - rewrite subst_context_alt lift_context_alt. len. - rewrite !mapi_compose. apply mapi_ext. - intros n x. unfold subst_decl, lift_decl. - rewrite !compose_map_decl. apply map_decl_ext. - intros. simpl. rewrite !Nat.add_0_r. - generalize (Nat.pred #|Δ| - n). intros. - rewrite map_subst_expand_lets_k //. -Qed. - -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. - intros Hs. rewrite !subst_context_alt. - unfold expand_lets_ctx, expand_lets_k_ctx. - rewrite subst_context_alt lift_context_alt. len. - rewrite !mapi_compose. apply mapi_ext. - intros n x. unfold subst_decl, lift_decl. - rewrite !compose_map_decl. apply map_decl_ext. - intros. simpl. - rewrite map_subst_expand_lets_k //. f_equal. - rewrite /expand_lets_k. lia_f_equal. -Qed. - -Lemma context_subst_subst_extended_subst inst s Δ : - context_subst Δ inst s -> - s = map (subst0 (List.rev inst)) (extended_subst Δ 0). -Proof. - intros sp. - induction sp. - - simpl; auto. - - rewrite List.rev_app_distr /= lift0_id. f_equal. - rewrite lift_extended_subst. - rewrite map_map_compose. rewrite IHsp. apply map_ext. - intros. rewrite (subst_app_decomp [_]). f_equal. - simpl. rewrite simpl_subst ?lift0_id //. - - simpl. len. - f_equal; auto. - rewrite IHsp. - rewrite distr_subst. f_equal. - simpl; len. - pose proof (context_subst_length2 sp). - rewrite -H. rewrite -(List.rev_length args). - rewrite -(Nat.add_0_r #|List.rev args|). - rewrite simpl_subst_rec; try lia. - now rewrite lift0_id. -Qed. - -Lemma spine_subst_extended_subst {cf:checker_flags} {Σ Γ inst s Δ} : - spine_subst Σ Γ inst s Δ -> - s = map (subst0 (List.rev inst)) (extended_subst Δ 0). -Proof. - intros [_ _ sp _]. now apply context_subst_subst_extended_subst in sp. -Qed. - (* Lemma spine_subst_extended_subst {cf:checker_flags} {Σ Γ inst s Δ} : spine_subst Σ Γ inst s Δ -> forall Γ', subst_context s 0 Γ' s = map (subst0 (List.rev inst)) (extended_subst Δ 0). @@ -283,42 +44,20 @@ Definition ind_subst mdecl ind u := inds (inductive_mind ind) u (ind_bodies mdec Ltac pcuic := intuition eauto 5 with pcuic || (try solve [repeat red; cbn in *; intuition auto; eauto 5 with pcuic || (try lia || congruence)]). -(** Inversion principles on inductive/coinductives types following from validity. *) +(** Inversion principle on constructor types following from validity. *) Lemma declared_constructor_valid_ty {cf:checker_flags} Σ Γ mdecl idecl i n cdecl u : wf Σ.1 -> wf_local Σ Γ -> - declared_constructor Σ.1 mdecl idecl (i, n) cdecl -> + declared_constructor Σ.1 (i, n) mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> isType Σ Γ (type_of_constructor mdecl cdecl (i, n) u). Proof. move=> wfΣ wfΓ declc Hu. - epose proof (env_prop_typing _ _ validity Σ wfΣ Γ (tConstruct i n u) - (type_of_constructor mdecl cdecl (i, n) u)). - forward X by eapply type_Construct; eauto. - simpl in X. - unfold type_of_constructor in X |- *. - destruct (on_declared_constructor _ declc); eauto. + eapply validity. eapply type_Construct; eauto. Qed. -Lemma declared_inductive_valid_type {cf:checker_flags} Σ Γ mdecl idecl i u : - wf Σ.1 -> - wf_local Σ Γ -> - declared_inductive Σ.1 mdecl i idecl -> - consistent_instance_ext Σ (ind_universes mdecl) u -> - isType Σ Γ (subst_instance_constr u (ind_type idecl)). -Proof. - move=> wfΣ wfΓ declc Hu. - pose declc as declc'. - apply on_declared_inductive in declc' as [onmind onind]; auto. - apply onArity in onind. - destruct onind as [s Hs]. - epose proof (PCUICUnivSubstitution.typing_subst_instance_decl Σ) as s'. - destruct declc. - specialize (s' [] _ _ _ _ u wfΣ H Hs Hu). - simpl in s'. eexists; eauto. - eapply (PCUICWeakening.weaken_ctx (Γ:=[]) Γ); eauto. -Qed. +Hint Resolve f_equal_nat : arith. Lemma type_tFix_inv {cf:checker_flags} (Σ : global_env_ext) Γ mfix idx T : wf Σ -> Σ ;;; Γ |- tFix mfix idx : T -> @@ -436,7 +175,7 @@ Proof. simpl in Hty. rewrite subst_context_nil /= in Hty. eapply refine_type; eauto. - rewrite simpl_subst_k //. now len. + rewrite simpl_subst_k //. len. apply subslet_cofix; auto. * reflexivity. - destruct (IHtyping1 wfΣ) as [d [[[Hnth wfcofix] ?] ?]]. @@ -506,624 +245,198 @@ Proof. - discriminate. Qed. -Lemma on_constructor_wf_args {cf:checker_flags} Σ ind mdecl idecl cshape cdecl : - wf Σ -> - declared_inductive Σ mdecl ind idecl -> - on_inductive (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl) - (onc : on_constructor (lift_typing typing) (Σ, ind_universes mdecl) - mdecl (inductive_ind ind) idecl (ind_indices oib) cdecl cshape), - wf_local (Σ, ind_universes mdecl) - (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cshape_args cshape). -Proof. - move=> wfΣ declm oi oib onc. - pose proof (on_cargs onc). simpl in X. - eapply sorts_local_ctx_wf_local in X => //. clear X. - eapply weaken_wf_local => //. - eapply wf_arities_context; eauto. destruct declm; eauto. - now eapply onParams. -Qed. - -Lemma on_constructor_subst {cf:checker_flags} Σ ind mdecl idecl cshape cdecl : - wf Σ -> - declared_inductive Σ mdecl ind idecl -> - on_inductive (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl) - (onc : on_constructor (lift_typing typing) (Σ, ind_universes mdecl) - mdecl (inductive_ind ind) idecl (ind_indices oib) cdecl cshape), - wf_global_ext Σ (ind_universes mdecl) * - wf_local (Σ, ind_universes mdecl) - (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cshape_args cshape) * - ∑ inst, - spine_subst (Σ, ind_universes mdecl) - (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, - cshape_args cshape) - ((to_extended_list_k (ind_params mdecl) #|cshape_args cshape|) ++ - (cshape_indices cshape)) inst - (ind_params mdecl ,,, ind_indices oib). -Proof. - move=> wfΣ declm oi oib onc. - pose proof (onc.(on_cargs)). simpl in X. - split. split. split. - 2:{ eapply (weaken_lookup_on_global_env'' _ _ (InductiveDecl mdecl)); pcuic. destruct declm; pcuic. } - red. split; eauto. simpl. eapply (weaken_lookup_on_global_env' _ _ (InductiveDecl mdecl)); eauto. - destruct declm; pcuic. - eapply sorts_local_ctx_wf_local in X => //. clear X. - eapply weaken_wf_local => //. - eapply wf_arities_context; eauto. destruct declm; eauto. - now eapply onParams. - destruct (on_ctype onc). - rewrite onc.(cstr_eq) in t. - rewrite -it_mkProd_or_LetIn_app in t. - eapply inversion_it_mkProd_or_LetIn in t => //. - unfold cstr_concl_head in t. simpl in t. - eapply inversion_mkApps in t as [A [ta sp]]. - eapply inversion_Rel in ta as [decl [wfΓ [nth cum']]]. - rewrite nth_error_app_ge in nth. len. lia. - autorewrite with len in nth. - all:auto. - assert ( (#|ind_bodies mdecl| - S (inductive_ind ind) + #|ind_params mdecl| + - #|cshape_args cshape| - - (#|cshape_args cshape| + #|ind_params mdecl|)) = #|ind_bodies mdecl| - S (inductive_ind ind)) by lia. - move: nth; rewrite H; clear H. destruct nth_error eqn:Heq => //. - simpl. - move=> [=] Hdecl. eapply (nth_errror_arities_context (Σ, ind_universes mdecl)) in Heq; eauto. - subst decl. - rewrite Heq in cum'; clear Heq c. - 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. } - rewrite lift_closed in cum' => //. - eapply typing_spine_strengthen in sp; pcuic. - move: sp. - rewrite (oib.(ind_arity_eq)). - rewrite -it_mkProd_or_LetIn_app. - move=> sp. simpl in sp. - apply (arity_typing_spine (Σ, ind_universes mdecl)) in sp as [[Hlen Hleq] [inst Hinst]] => //. - clear Hlen. - rewrite [_ ,,, _]app_context_assoc in Hinst. - now exists inst. - apply weaken_wf_local => //. - - rewrite [_ ,,, _]app_context_assoc in wfΓ. - eapply All_local_env_app_inv in wfΓ as [? ?]. - apply on_minductive_wf_params_indices => //. pcuic. -Qed. - -Lemma on_constructor_inst {cf:checker_flags} {Σ ind mdecl idecl cshape cdecl} u : - wf Σ.1 -> - declared_inductive Σ.1 mdecl ind idecl -> - on_inductive (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl) - (onc : on_constructor (lift_typing typing) (Σ.1, PCUICAst.ind_universes mdecl) - mdecl (inductive_ind ind) idecl (ind_indices oib) cdecl cshape), - consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_local Σ (subst_instance_context u - (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cshape_args cshape)) * - ∑ inst, - spine_subst Σ - (subst_instance_context u - (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, - cshape_args cshape)) - (map (subst_instance_constr u) - (to_extended_list_k (ind_params mdecl) #|cshape_args cshape|) ++ - map (subst_instance_constr u) (cshape_indices cshape)) inst - (subst_instance_context u (ind_params mdecl) ,,, - subst_instance_context u (ind_indices oib)). -Proof. - move=> wfΣ declm oi oib onc cext. - destruct (on_constructor_subst Σ.1 ind mdecl idecl _ cdecl wfΣ declm oi oib onc) as [[wfext wfl] [inst sp]]. - eapply wf_local_subst_instance in wfl; eauto. split=> //. - eapply spine_subst_inst in sp; eauto. - rewrite map_app in sp. rewrite -subst_instance_context_app. - eexists ; eauto. -Qed. -Hint Rewrite subst_instance_context_assumptions to_extended_list_k_length : len. +Section OnConstructor. + Context {cf:checker_flags} {Σ : global_env} {ind mdecl idecl cdecl} + {wfΣ: wf Σ} (declc : declared_constructor Σ ind mdecl idecl cdecl). -Require Import ssrbool. - -Lemma smash_context_app_def Γ na b ty : - smash_context [] (Γ ++ [{| decl_name := na; decl_body := Some b; decl_type := ty |}]) = - smash_context [] (subst_context [b] 0 Γ). -Proof. - now rewrite smash_context_app smash_context_acc /= subst_empty lift0_id lift0_context /= - subst_context_nil app_nil_r (smash_context_subst []). -Qed. - -Lemma smash_context_app_ass Γ na ty : - smash_context [] (Γ ++ [{| decl_name := na; decl_body := None; decl_type := ty |}]) = - smash_context [] Γ ++ [{| decl_name := na; decl_body := None; decl_type := ty |}]. -Proof. - now rewrite smash_context_app smash_context_acc /= subst_context_lift_id. -Qed. - -Lemma lift_context_add k k' n Γ : lift_context (k + k') n Γ = lift_context k n (lift_context k' n Γ). -Proof. - induction Γ => //. - rewrite !lift_context_snoc IHΓ; f_equal. - destruct a as [na [b|] ty]; rewrite /lift_decl /map_decl /=; simpl; f_equal; - len; rewrite simpl_lift //; try lia. -Qed. - -Lemma distr_lift_subst_context_rec n k s Γ k' : lift_context n (k' + k) (subst_context s k' Γ) = - subst_context (map (lift n k) s) k' (lift_context n (#|s| + k + k') Γ). -Proof. - rewrite !lift_context_alt !subst_context_alt. - rewrite !mapi_compose. - apply mapi_ext. - intros n' x. - rewrite /lift_decl /subst_decl !compose_map_decl. - apply map_decl_ext => y. len. - replace (Nat.pred #|Γ| - n' + (#|s| + k + k')) - with ((Nat.pred #|Γ| - n' + k') + #|s| + k) by lia. - rewrite -distr_lift_subst_rec. f_equal. lia. -Qed. - -Lemma subst_context_lift_id Γ k : subst_context [tRel 0] k (lift_context 1 (S k) Γ) = Γ. -Proof. - rewrite subst_context_alt lift_context_alt. - rewrite mapi_compose. - replace Γ with (mapi (fun k x => x) Γ) at 2. - 2:unfold mapi; generalize 0; induction Γ; simpl; intros; auto; congruence. - apply mapi_ext. - len. - intros n [? [?|] ?]; unfold lift_decl, subst_decl, map_decl; simpl. - generalize (Nat.pred #|Γ| - n). - intros. - now rewrite !Nat.add_succ_r !subst_rel0_lift_id. - now rewrite !Nat.add_succ_r !subst_rel0_lift_id. -Qed. - - -Definition option_all (p : term -> bool) (o : option term) : bool := - match o with - | None => true - | Some b => p b - end. - -Definition test_decl (p : term -> bool) d := - p d.(decl_type) && option_all p d.(decl_body). - -Lemma option_all_map f g x : option_all f (option_map g x) = option_all (f ∘ g) x. -Proof. - destruct x; reflexivity. -Qed. - -Lemma test_decl_map_decl f g x : test_decl f (map_decl g x) = test_decl (f ∘ g) x. -Proof. - now rewrite /test_decl /map_decl /= option_all_map. -Qed. - -Lemma option_all_ext f g x : f =1 g -> option_all f x = option_all g x. -Proof. - move=> Hf; destruct x; simpl => //; rewrite Hf; reflexivity. -Qed. - -Lemma test_decl_eq f g x : f =1 g -> test_decl f x = test_decl g x. -Proof. - intros Hf; rewrite /test_decl (Hf (decl_type x)) (option_all_ext f g) //. -Qed. - - -Lemma option_all_impl (f g : term -> bool) x : (forall x, f x -> g x) -> option_all f x -> option_all g x. -Proof. - move=> Hf; destruct x; simpl => //; apply Hf. -Qed. - -Lemma test_decl_impl (f g : term -> bool) x : (forall x, f x -> g x) -> test_decl f x -> test_decl g x. -Proof. - intros Hf; rewrite /test_decl. - move/andb_and=> [Hd Hb]. - apply/andb_and; split; eauto. - eapply option_all_impl; eauto. -Qed. - - -Lemma assumption_context_app_inv Γ Δ : assumption_context Γ -> assumption_context Δ -> - assumption_context (Γ ++ Δ). -Proof. - induction 1; try constructor; auto. -Qed. - -Lemma closedn_ctx_upwards k k' Γ : - closedn_ctx k Γ -> k <= k' -> - closedn_ctx k' Γ. -Proof. - induction Γ; auto. rewrite !closed_ctx_decl /=. - move/andb_and => [cla clΓ] le. - rewrite (IHΓ clΓ le). - rewrite (closed_decl_upwards _ _ cla) //. lia. -Qed. - -Lemma closedn_expand_lets k (Γ : context) t : - closedn (k + context_assumptions Γ) (expand_lets Γ t) -> - closedn (k + #|Γ|) t. -Proof. - revert k t. - induction Γ as [|[na [b|] ty] Γ] using ctx_length_rev_ind; intros k t; simpl; auto. - - now rewrite /expand_lets /expand_lets_k subst_empty lift0_id. - - len. - rewrite !expand_lets_vdef. - specialize (H (subst_context [b] 0 Γ) ltac:(len; lia)). - autorewrite with len in H. - intros cl. - specialize (H _ _ cl). - eapply (closedn_subst_eq' _ k) in H. - simpl in *. now rewrite Nat.add_assoc. - - len. - rewrite !expand_lets_vass. simpl. intros cl. - specialize (H Γ ltac:(len; lia)). - rewrite (Nat.add_comm _ 1) Nat.add_assoc in cl. - now rewrite (Nat.add_comm _ 1) Nat.add_assoc. -Qed. - -Lemma closedn_expand_lets_eq k (Γ : context) k' t : - closedn_ctx k Γ -> - closedn (k + k' + context_assumptions Γ) (expand_lets_k Γ k' t) = - closedn (k + k' + #|Γ|) t. -Proof. - revert k k' t. - induction Γ as [|[na [b|] ty] Γ] using ctx_length_rev_ind; intros k k' t; - rewrite ?closedn_ctx_app /= /id /=; simpl; auto. - - now rewrite /expand_lets /expand_lets_k /= subst_empty lift0_id. - - rewrite andb_true_r /id; move/andb_and=> [cld clΓ]. len. - rewrite !expand_lets_k_vdef. - simpl in cld |- *. move/andb_and: cld => /= [clb _]. - rewrite Nat.add_0_r in clb. - specialize (H (subst_context [b] 0 Γ) ltac:(len; lia)). - autorewrite with len in H. rewrite H /=. - relativize k. eapply closedn_ctx_subst. simpl. 3:rewrite Nat.add_0_r //. - 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. rewrite andb_true_r /=; 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_ctx_expand_lets k Γ Δ : - closedn_ctx k Γ -> - closedn_ctx (k + #|Γ|) Δ -> - closedn_ctx (k + context_assumptions Γ) (expand_lets_ctx Γ Δ). -Proof. - intros clΓ clΔ. - rewrite /expand_lets_ctx /expand_lets_k_ctx. - rewrite -(Nat.add_0_r (k + context_assumptions Γ)). - eapply closedn_ctx_subst; len; simpl. - replace (k + context_assumptions Γ + #|Γ|) with (context_assumptions Γ + (k + #|Γ|)) by lia. - eapply closedn_ctx_lift => //. - eapply forallb_impl. 2:eapply closedn_extended_subst_gen; eauto. - simpl; auto. -Qed. - -Lemma closedn_to_extended_list_k k Γ k' : - k' + #|Γ| <= k -> - forallb (closedn k) (to_extended_list_k Γ k'). -Proof. - move=> le. rewrite /to_extended_list_k. - eapply Forall_forallb; eauto. 2:{ intros x H; eapply H. } - eapply Forall_impl. eapply reln_list_lift_above. constructor. - simpl; intros. - destruct H as [n [-> leq]]. simpl. - eapply Nat.ltb_lt. lia. -Qed. - -Lemma map_subst_extended_subst Γ k : - map (subst0 (List.rev (to_extended_list_k Γ k))) (extended_subst Γ 0) = - all_rels Γ k 0. -Proof. - unfold to_extended_list_k. - - induction Γ in k |- *; simpl; auto. - destruct a as [na [b|] ty]; simpl. - f_equal. len. - rewrite lift0_id. - rewrite distr_subst. len. - rewrite simpl_subst_k. now len. - rewrite IHΓ. now rewrite Nat.add_1_r. - rewrite IHΓ. now rewrite Nat.add_1_r. - rewrite nth_error_rev. len => /= //. simpl; lia. - len. simpl. - rewrite Nat.sub_succ. rewrite List.rev_involutive. - change (0 - 0) with 0. rewrite Nat.sub_0_r. - f_equal. - rewrite reln_acc nth_error_app_ge; len => //. - simpl. now rewrite Nat.sub_diag /=. - rewrite -IHΓ. simpl. - rewrite reln_acc List.rev_app_distr /=. - rewrite (map_subst_app_decomp [tRel k]). - simpl. rewrite lift_extended_subst. - rewrite map_map_compose. apply map_ext. - intros x. f_equal. now rewrite Nat.add_1_r. - len. simpl. - rewrite simpl_subst // lift0_id //. -Qed. - -Lemma subst_ext_list_ext_subst Γ k' k t : - subst (List.rev (to_extended_list_k Γ k)) k' - (subst (extended_subst Γ 0) k' - (lift (context_assumptions Γ) (k' + #|Γ|) t)) = - subst (all_rels Γ k 0) k' t. -Proof. - epose proof (distr_subst_rec _ _ _ 0 _). - rewrite Nat.add_0_r in H. rewrite -> H. clear H. - 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 (all_rels Γ k 0) k' Δ. -Proof. - revert k k'; induction Δ using rev_ind; simpl; auto. - intros k k'; rewrite expand_lets_k_ctx_decl /map_decl /=. - rewrite !subst_context_app /=. - simpl; unfold app_context. - f_equal. specialize (IHΔ k (S k')). simpl in IHΔ. - rewrite -IHΔ. - destruct x; simpl. - destruct decl_body; simpl in * => //. - unfold subst_context, fold_context; simpl. - f_equal. - 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 Γ) = - subst_context (map (subst s k) s') 0 (subst_context s (#|s'| + k) Γ). -Proof. - rewrite !subst_context_alt. - rewrite !mapi_compose; len. - eapply mapi_ext. intros n x. - rewrite /subst_decl !compose_map_decl. - apply map_decl_ext. intros t. - rewrite Nat.add_0_r. - remember (Nat.pred #|Γ| - n) as i. - rewrite distr_subst_rec. lia_f_equal. -Qed. - -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 - (expand_lets_ctx Γ Δ)) = - subst_context (List.rev (to_extended_list_k (smash_context [] Γ) k)) 0 - (expand_lets_ctx Γ Δ). -Proof. - intros clΓ clΔ. - rewrite {1}/expand_lets_k_ctx. - rewrite closed_ctx_lift. - rewrite -(Nat.add_0_r (k + #|Γ|)). - eapply closedn_ctx_subst. simpl; len. - eapply closedn_ctx_expand_lets. eapply closedn_ctx_upwards; eauto. lia. - eapply closedn_ctx_upwards; eauto. lia. - rewrite forallb_rev. now eapply closedn_to_extended_list_k. - rewrite subst_subst_context. len. - rewrite map_rev extended_subst_to_extended_list_k. - rewrite (closed_ctx_subst _ (context_assumptions Γ + k)). - rewrite Nat.add_comm; eapply closedn_ctx_expand_lets => //. - eapply closedn_ctx_upwards; eauto. lia. - eapply closedn_ctx_upwards; eauto. lia. - reflexivity. -Qed. - -Lemma subst_extended_lift Γ k : - closed_ctx Γ -> - map (subst0 (List.rev (to_extended_list_k (smash_context [] Γ) k))) - (extended_subst Γ 0) = extended_subst Γ k. -Proof. - induction Γ in k |- *; intros cl; simpl; auto. - destruct a as [na [b|] ty] => /=. - len. - rewrite closed_ctx_decl in cl. move/andb_and: cl => [cld clΓ]. - simpl. f_equal. - rewrite distr_subst. len. - simpl in cld. - rewrite IHΓ //. f_equal. rewrite simpl_subst_k. - len. rewrite context_assumptions_smash_context /= //. - rewrite lift_closed //. now move/andb_and: cld => /= //. - rewrite IHΓ //. - - simpl map. - rewrite Nat.sub_diag. rewrite nth_error_rev. - len. simpl. rewrite context_assumptions_smash_context /=. lia. - len. rewrite List.rev_involutive /= context_assumptions_smash_context /=. - rewrite smash_context_acc /=. - f_equal; auto. rewrite reln_acc /=. - rewrite nth_error_app_ge. len. simpl. - rewrite context_assumptions_smash_context /=. lia. - len. simpl. - rewrite context_assumptions_smash_context /=. - replace (S (context_assumptions Γ) - 1 - context_assumptions Γ) with 0 by lia. - now simpl. - rewrite reln_acc List.rev_app_distr /=. - rewrite lift_extended_subst. - rewrite map_map_compose. - rewrite map_subst_lift1. - rewrite closed_ctx_decl in cl. move/andb_and: cl => [cld clΓ]. - now rewrite IHΓ // Nat.add_1_r. -Qed. - -Lemma closed_subst_map_lift s n k t : - closedn (#|s| + k) t -> - subst (map (lift0 n) s) k t = subst s (n + k) (lift n k t). -Proof. - remember (#|s| + k) as n'. - intros cl; revert n' t cl k Heqn'. - eapply (term_closedn_list_ind (fun n' t => forall k, n' = #|s| + k -> - subst (map (lift0 n) s) k t = subst s (n + k) (lift n k t))); - intros; simpl; f_equal; eauto. - - subst k. - simpl. - destruct (Nat.leb_spec k0 n0). - rewrite nth_error_map. - replace (n + n0 - (n + k0)) with (n0 - k0) by lia. - destruct nth_error eqn:eq => /= //. - destruct (Nat.leb_spec (n + k0) (n + n0)); try lia. - rewrite simpl_lift; try lia. lia_f_equal. - destruct (Nat.leb_spec (n + k0) (n + n0)); try lia. - len. - eapply nth_error_None in eq. lia. - destruct (Nat.leb_spec (n + k0) n0); try lia. - reflexivity. - - - rewrite map_map_compose. solve_all. - - rewrite (H0 (S k0)). lia. lia_f_equal. - - rewrite (H0 (S k0)). lia. lia_f_equal. - - rewrite (H1 (S k0)). lia. lia_f_equal. - - rewrite map_map_compose. solve_all. - - rewrite map_map_compose. len. - solve_all. rewrite map_def_map_def. - specialize (a _ H). specialize (b (#|fix_context m| + k0)). - forward b by lia. eapply map_def_eq_spec; auto. - autorewrite with len in b. - rewrite b. lia_f_equal. - - rewrite map_map_compose. len. - solve_all. rewrite map_def_map_def. - specialize (a _ H). specialize (b (#|fix_context m| + k0)). - forward b by lia. eapply map_def_eq_spec; auto. - autorewrite with len in b. - rewrite b. lia_f_equal. -Qed. - -Lemma subst_map_lift_lift_context (Γ : context) k s : - closedn_ctx #|s| Γ -> - subst_context (map (lift0 k) s) 0 Γ = - subst_context s k (lift_context k 0 Γ). -Proof. - induction Γ as [|[? [] ?] ?] in k |- *; intros cl; auto; - rewrite lift_context_snoc !subst_context_snoc /= /subst_decl /map_decl /=; - rewrite closed_ctx_decl in cl; move/andb_and: cl => [cld clΓ]. - - rewrite IHΓ //. f_equal. f_equal. f_equal; - len. - rewrite closed_subst_map_lift //. now move/andb_and: cld => /=. - lia_f_equal. - len. - rewrite closed_subst_map_lift //. now move/andb_and: cld => /=. - lia_f_equal. - - f_equal. apply IHΓ => //. - f_equal; len. rewrite closed_subst_map_lift //. - lia_f_equal. -Qed. + Lemma on_constructor_wf_args : + wf_local (Σ, ind_universes mdecl) + (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cstr_args cdecl). + Proof. + pose proof (on_declared_constructor declc) as [[onmind oib] [cunivs [hnth onc]]]. + pose proof (on_cargs onc). simpl in X. + eapply sorts_local_ctx_wf_local in X => //. clear X. + eapply weaken_wf_local => //. + eapply wf_arities_context; eauto. eapply declc. + now eapply onParams. + Qed. -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. - intros ->; induction Γ as [|[? [] ?] ?] in |- *; auto; - 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. - len. - rewrite commut_lift_subst_rec. lia. lia_f_equal. - - f_equal. apply IHΓ => //. - f_equal; len. rewrite commut_lift_subst_rec //; try lia. - lia_f_equal. -Qed. + Lemma on_constructor_subst : + wf_global_ext Σ (ind_universes mdecl) * + wf_local (Σ, ind_universes mdecl) + (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cstr_args cdecl) * + ∑ inst, + spine_subst (Σ, ind_universes mdecl) + (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, + cstr_args cdecl) + ((to_extended_list_k (ind_params mdecl) #|cstr_args cdecl|) ++ + (cstr_indices cdecl)) inst + (ind_params mdecl ,,, ind_indices idecl). + Proof. + 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. split; eauto. simpl. + eapply (weaken_lookup_on_global_env' _ _ (InductiveDecl mdecl)); eauto. + eapply declc. + eapply sorts_local_ctx_wf_local in X => //. clear X. + eapply weaken_wf_local => //. + eapply wf_arities_context; eauto; eapply declc. + now eapply onParams. + destruct (on_ctype onc). + rewrite onc.(cstr_eq) in t. + rewrite -it_mkProd_or_LetIn_app in t. + eapply inversion_it_mkProd_or_LetIn in t => //. + unfold cstr_concl_head in t. simpl in t. + eapply inversion_mkApps in t as [A [ta sp]]. + eapply inversion_Rel in ta as [decl [wfΓ [nth cum']]]. + rewrite nth_error_app_ge in nth. len. + len in nth. + all:auto. + assert ((#|ind_bodies mdecl| - S (inductive_ind ind.1) + #|ind_params mdecl| + + #|cstr_args cdecl| - + (#|cstr_args cdecl| + #|ind_params mdecl|)) = #|ind_bodies mdecl| - S (inductive_ind ind.1)) by lia. + move: nth; rewrite H; clear H. + case: nth_error_spec => // /= decl' Hdecl Hlen. + intros [= ->]. + eapply (nth_errror_arities_context (Σ := (Σ, ind_universes mdecl)) declc) in Hdecl; eauto. + 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. } + rewrite lift_closed in cum' => //. + eapply typing_spine_strengthen in sp; simpl. 2:pcuic. + 2:tea. + move: sp. + rewrite (oib.(ind_arity_eq)). + rewrite -it_mkProd_or_LetIn_app. + move=> sp. simpl in sp. + apply (arity_typing_spine (Σ, ind_universes mdecl)) in sp as [[Hlen' Hleq] [inst Hinst]] => //. + clear Hlen'. + rewrite [_ ,,, _]app_context_assoc in Hinst. + now exists inst. + apply weaken_wf_local => //. + + rewrite [_ ,,, _]app_context_assoc in wfΓ. + eapply All_local_env_app_inv in wfΓ as [? ?]. + eapply on_minductive_wf_params_indices, declc. + Qed. +End OnConstructor. + +Section OnConstructorExt. + Context {cf:checker_flags} {Σ : global_env_ext} {ind mdecl idecl cdecl} + {wfΣ: wf Σ} (declc : declared_constructor Σ ind mdecl idecl cdecl). + + 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)) * + ∑ inst, + spine_subst Σ + (subst_instance u + (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, + cstr_args cdecl)) + (map (subst_instance u) + (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)). + Proof. + intros cu. + destruct (on_constructor_subst declc) as [[wfext wfl] [inst sp]]. + eapply wf_local_subst_instance in wfl; eauto. split=> //. + eapply spine_subst_inst in sp; eauto. + rewrite map_app in sp. rewrite -subst_instance_app_ctx. + eexists ; eauto. + Qed. +End OnConstructorExt. -Lemma on_constructor_inst_pars_indices {cf:checker_flags} {Σ ind u mdecl idecl cshape cdecl Γ pars parsubst} : +Lemma on_constructor_inst_pars_indices {cf:checker_flags} {Σ ind u mdecl idecl cdecl Γ pars parsubst} : wf Σ.1 -> - declared_inductive Σ.1 mdecl ind idecl -> - on_inductive (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl) - (onc : on_constructor (lift_typing typing) (Σ.1, PCUICAst.ind_universes mdecl) - mdecl (inductive_ind ind) idecl (ind_indices oib) cdecl cshape), + declared_constructor Σ.1 ind mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - spine_subst Σ Γ pars parsubst (subst_instance_context u (ind_params mdecl)) -> - wf_local Σ (subst_instance_context u (ind_params mdecl) ,,, - subst_context (inds (inductive_mind ind) u (ind_bodies mdecl)) #|ind_params mdecl| - (subst_instance_context u (cshape_args cshape))) * + spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> + wf_local Σ (subst_instance u (ind_params mdecl) ,,, + subst_context (inds (inductive_mind ind.1) u (ind_bodies mdecl)) #|ind_params mdecl| + (subst_instance u (cstr_args cdecl))) * ∑ inst, spine_subst Σ - (Γ ,,, subst_context parsubst 0 (subst_context (ind_subst mdecl ind u) #|ind_params mdecl| - (subst_instance_context u (cshape_args cshape)))) - (map (subst parsubst #|cshape_args cshape|) - (map (subst (ind_subst mdecl ind u) (#|cshape_args cshape| + #|ind_params mdecl|)) - (map (subst_instance_constr u) (cshape_indices cshape)))) + (Γ ,,, subst_context parsubst 0 (subst_context (ind_subst mdecl ind.1 u) #|ind_params mdecl| + (subst_instance u (cstr_args cdecl)))) + (map (subst parsubst #|cstr_args cdecl|) + (map (subst (ind_subst mdecl ind.1 u) (#|cstr_args cdecl| + #|ind_params mdecl|)) + (map (subst_instance u) (cstr_indices cdecl)))) inst - (lift_context #|cshape_args cshape| 0 - (subst_context parsubst 0 (subst_instance_context u (ind_indices oib)))). + (lift_context #|cstr_args cdecl| 0 + (subst_context parsubst 0 (subst_instance u (ind_indices idecl)))). Proof. - move=> wfΣ declm oi oib onc cext sp. - destruct (on_constructor_inst u wfΣ declm oi oib onc) as [wfl [inst sp']]; auto. - rewrite !subst_instance_context_app in sp'. + move=> wfΣ declc cext sp. + (* destruct (on_declared_constructor declc) as []. .declm oi oib onc *) + destruct (on_constructor_inst declc u) as [wfl [inst sp']]; auto. + rewrite !subst_instance_app in sp'. eapply spine_subst_app_inv in sp' as [spl spr]; auto. rewrite (spine_subst_extended_subst spl) in spr. rewrite subst_context_map_subst_expand_lets in spr; try now len. rewrite subst_instance_to_extended_list_k in spr. 2:now len. rewrite lift_context_subst_context. - rewrite -app_context_assoc in spr. + rewrite app_assoc in spr. eapply spine_subst_subst_first in spr; eauto. - 2:eapply subslet_inds; eauto. - autorewrite with len in spr. + 2:eapply subslet_inds; eauto; eapply declc. + len in spr. rewrite subst_context_app in spr. - assert (closed_ctx (subst_instance_context u (ind_params mdecl)) /\ closedn_ctx #|ind_params mdecl| (subst_instance_context u (ind_indices oib))) + assert (closed_ctx (subst_instance u (ind_params mdecl)) /\ closedn_ctx #|ind_params mdecl| (subst_instance u (ind_indices idecl))) as [clpars clinds]. - { unshelve epose proof (on_minductive_wf_params_indices _ _ _ _ wfΣ _ oib). - pcuic. eapply closed_wf_local in X => //. - rewrite closedn_ctx_app in X; simpl; eauto. + { pose proof (on_minductive_wf_params_indices declc). + eapply closed_wf_local in X => //. + 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| + #|cshape_args cshape|) (subst_instance_context u (ind_indices oib))) + 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. - rewrite (closed_ctx_subst(inds (inductive_mind ind) u (ind_bodies mdecl)) _ (subst_context (List.rev _) _ _)) in spr. + rewrite (closed_ctx_subst (inds (inductive_mind ind.1) u (ind_bodies mdecl)) _ (subst_context (List.rev _) _ _)) in spr. { len. - rewrite -(Nat.add_0_r (#|cshape_args cshape| + #|ind_params mdecl|)). + rewrite -(Nat.add_0_r (#|cstr_args cdecl| + #|ind_params mdecl|)). eapply closedn_ctx_subst. len. - rewrite -(subst_instance_context_assumptions u). + rewrite -(subst_instance_assumptions u). eapply closedn_ctx_expand_lets. eapply closedn_ctx_upwards; eauto. lia. len. eapply closedn_ctx_upwards; eauto. lia. rewrite forallb_rev. eapply closedn_to_extended_list_k. now len. } - autorewrite with len in spr. - split. - { autorewrite with len in spr. apply spr. } + len in spr. split => //. apply spr. eapply spine_subst_weaken in spr. 3:eapply (spine_dom_wf _ _ _ _ _ sp); eauto. 2:eauto. rewrite app_context_assoc in spr. eapply spine_subst_subst in spr; eauto. 2:eapply sp. - autorewrite with len in spr. + len in spr. rewrite {4}(spine_subst_extended_subst sp) in spr. rewrite subst_context_map_subst_expand_lets_k in spr; try now len. rewrite List.rev_length. now rewrite -(context_subst_length2 sp). rewrite expand_lets_k_ctx_subst_id' in spr. now len. now len. rewrite -subst_context_map_subst_expand_lets_k in spr; try len. - rewrite context_assumptions_smash_context /=. now len. - rewrite subst_subst_context in spr. autorewrite with len in spr. + rewrite subst_subst_context in spr. len in spr. rewrite subst_extended_lift // in spr. rewrite lift_extended_subst in spr. rewrite (map_map_compose _ _ _ _ (subst (List.rev pars) _)) in spr. assert (map (fun x : term => - subst (List.rev pars) #|cshape_args cshape| - (lift0 #|cshape_args cshape| x)) - (extended_subst (subst_instance_context u (ind_params mdecl)) 0) = + subst (List.rev pars) #|cstr_args cdecl| + (lift0 #|cstr_args cdecl| x)) + (extended_subst (subst_instance u (ind_params mdecl)) 0) = (map (fun x : term => - (lift0 #|cshape_args cshape| + (lift0 #|cstr_args cdecl| (subst (List.rev pars) 0 x))) - (extended_subst (subst_instance_context u (ind_params mdecl)) 0)) + (extended_subst (subst_instance u (ind_params mdecl)) 0)) ). eapply map_ext => x. now rewrite -(commut_lift_subst_rec _ _ _ 0). rewrite H in spr. clear H. - rewrite -(map_map_compose _ _ _ _ (lift0 #|cshape_args cshape|)) in spr. + rewrite -(map_map_compose _ _ _ _ (lift0 #|cstr_args cdecl|)) in spr. rewrite -(spine_subst_extended_subst sp) in spr. rewrite subst_map_lift_lift_context in spr. rewrite -(context_subst_length sp). @@ -1157,7 +470,6 @@ Proof. depelim Hsp. eapply invert_cumul_ind_l in c as [i'' [args'' [? ?]]]; auto. eapply red_mkApps_tInd in r as [? [eq ?]]; auto. solve_discr. - noconf H. noconf H0. exists nil. intuition auto. clear i0. revert args' a. clear -b wfΣ wfΓ. induction b; intros args' H; depelim H; constructor. @@ -1192,7 +504,7 @@ Proof. eapply (context_subst_subst [{| decl_name := na; decl_body := Some b; decl_type := ty |}] [] [b] Γ'). rewrite -{2} (subst_empty 0 b). eapply context_subst_def. constructor. now rewrite List.rev_involutive in Hisub. - now autorewrite with len in H2. + now len in H2. rewrite map_map_compose in Hargs. assert (map (subst0 isub ∘ subst [b] #|Γ'|) args = map (subst0 (isub ++ [b])) args) as <-. { eapply map_ext => x. simpl. @@ -1238,7 +550,7 @@ Proof. intuition auto. destruct X1 as [isub [[[Hisub [Htl [Hind Hu]]] Hargs] Hs]]. exists (isub ++ [hd]). rewrite List.rev_app_distr. - autorewrite with len in Hu. + len in Hu. intuition auto. 2:lia. * apply make_context_subst_spec_inv. apply make_context_subst_spec in Hisub. @@ -1284,23 +596,22 @@ Qed. 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' -> - forall (Hdecl : declared_constructor Σ.1 mdecl idecl (i, n) cdecl), - let '(onind, oib, existT cshape (hnth, onc)) := on_declared_constructor wfΣ Hdecl in + declared_constructor Σ.1 (i, n) mdecl idecl cdecl -> (i = i') * (* Universe instances match *) - R_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cshape_indices cshape|) u u' * + R_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' * consistent_instance_ext Σ (ind_universes mdecl) u' * - (#|args| = (ind_npars mdecl + context_assumptions cshape.(cshape_args))%nat) * + (#|args| = (ind_npars mdecl + context_assumptions cdecl.(cstr_args))%nat) * ∑ parsubst argsubst parsubst' argsubst', - let parctx := (subst_instance_context u (ind_params mdecl)) in - let parctx' := (subst_instance_context u' (ind_params mdecl)) in + let parctx := (subst_instance u (ind_params mdecl)) in + let parctx' := (subst_instance u' (ind_params mdecl)) in let argctx := (subst_context parsubst 0 ((subst_context (inds (inductive_mind i) u mdecl.(ind_bodies)) #|ind_params mdecl| - (subst_instance_context u cshape.(cshape_args))))) in + (subst_instance u cdecl.(cstr_args))))) in let argctx2 := (subst_context parsubst' 0 ((subst_context (inds (inductive_mind i) u' mdecl.(ind_bodies)) #|ind_params mdecl| - (subst_instance_context u' cshape.(cshape_args))))) in - let argctx' := (subst_context parsubst' 0 (subst_instance_context u' oib.(ind_indices))) in + (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' * @@ -1316,16 +627,14 @@ Lemma Construct_Ind_ind_eq {cf:checker_flags} {Σ} (wfΣ : wf Σ.1): (** Indices match *) All2 (fun par par' => Σ ;;; Γ |- par = par') (map (subst0 (argsubst ++ parsubst) ∘ - subst (inds (inductive_mind i) u mdecl.(ind_bodies)) (#|cshape.(cshape_args)| + #|ind_params mdecl|) - ∘ (subst_instance_constr u)) - cshape.(cshape_indices)) + subst (inds (inductive_mind i) u mdecl.(ind_bodies)) (#|cdecl.(cstr_args)| + #|ind_params mdecl|) + ∘ (subst_instance u)) + cdecl.(cstr_indices)) (skipn mdecl.(ind_npars) args')). - Proof. intros Γ n i args u i' args' u' mdecl idecl cdecl h declc. - unfold on_declared_constructor. - destruct (on_declared_constructor _ declc). destruct s as [? [_ onc]]. - unshelve epose proof (env_prop_typing _ _ validity _ _ _ _ _ h) as vi'; eauto using typing_wf_local. + destruct (on_declared_constructor declc) as [[onmind onind] [? [_ onc]]]. + unshelve epose proof (env_prop_typing _ _ validity_env _ _ _ _ _ h) as vi'; eauto using typing_wf_local. eapply inversion_mkApps in h; auto. destruct h as [T [hC hs]]. apply inversion_Construct in hC @@ -1334,51 +643,40 @@ Proof. eapply typing_spine_strengthen in hs. 3:eapply htc. all:eauto. destruct (declared_constructor_inj isdecl declc) as [? [? ?]]. subst mdecl' idecl' cdecl'. clear isdecl. - destruct p as [onmind onind]. clear onc. + pose proof (on_constructor_inst declc _ const). destruct declc as [decli declc]. - remember (on_declared_inductive wfΣ decli). clear onmind onind. - destruct p. - rename o into onmind. rename o0 into onind. - destruct declared_constructor_inv as [cshape [_ onc]]. - simpl in onc. unfold on_declared_inductive in Heqp. - injection Heqp. intros indeq _. - move: onc Heqp. rewrite -indeq. - intros onc Heqp. clear Heqp. simpl in onc. - pose proof (on_constructor_inst u wfΣ decli onmind onind onc const). - destruct onc as [argslength conclhead cshape_eq [cs' t] cargs cinds]; simpl. + destruct onc as [argslength conclhead cdecl_eq [cs' t] cargs cinds]; simpl. simpl in *. unfold type_of_constructor in hs. simpl in hs. - unfold cdecl_type in cshape_eq. - rewrite cshape_eq in hs. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in hs. - rewrite !subst_it_mkProd_or_LetIn subst_instance_context_length Nat.add_0_r in hs. - rewrite subst_instance_constr_mkApps subst_mkApps subst_instance_context_length 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. assert (Hind : inductive_ind i < #|ind_bodies mdecl|). - { red in decli. destruct decli. clear -e. - now eapply nth_error_Some_length in e. } + { destruct decli. + now eapply nth_error_Some_length in H0. } rewrite (subst_inds_concl_head i) in hs => //. rewrite -it_mkProd_or_LetIn_app in hs. - assert(ind_npars mdecl = PCUICAst.context_assumptions (ind_params mdecl)). + assert(ind_npars mdecl = context_assumptions (ind_params mdecl)). { now pose (onNpars onmind). } assert (closed_ctx (ind_params mdecl)). { destruct onmind. red in onParams. now apply closed_wf_local in onParams. } eapply mkApps_ind_typing_spine in hs as [isubst [[[Hisubst [Hargslen [Hi Hu]]] Hargs] Hs]]; auto. subst i'. - eapply (isType_mkApps_Ind wfΣ decli) in vi' as (parsubst & argsubst & (spars & sargs) & cons) => //. - unfold on_declared_inductive in sargs. simpl in sargs. rewrite -indeq in sargs. clear indeq. + eapply (isType_mkApps_Ind_inv wfΣ decli) in vi' as (parsubst & argsubst & (spars & sargs) & cons) => //. split=> //. split=> //. split; auto. split => //. - now autorewrite with len in Hu. - now rewrite Hargslen context_assumptions_app !context_assumptions_subst !subst_instance_context_assumptions; lia. + now len in Hu. + now rewrite Hargslen context_assumptions_app !context_assumptions_subst !subst_instance_assumptions; lia. - exists (skipn #|cshape.(cshape_args)| isubst), (firstn #|cshape.(cshape_args)| isubst). + exists (skipn #|cdecl.(cstr_args)| isubst), (firstn #|cdecl.(cstr_args)| isubst). apply make_context_subst_spec in Hisubst. move: Hisubst. rewrite List.rev_involutive. move/context_subst_app. - rewrite !subst_context_length !subst_instance_context_length. - rewrite context_assumptions_subst subst_instance_context_assumptions -H. + rewrite !subst_context_length !subst_instance_length. + rewrite context_assumptions_subst subst_instance_assumptions -H. move=> [argsub parsub]. rewrite closed_ctx_subst in parsub. now rewrite closedn_subst_instance_context. @@ -1390,27 +688,27 @@ Proof. (*rewrite -Heqp in spars sargs. simpl in *. clear Heqp. *) exists parsubst, argsubst. assert(wfar : wf_local Σ - (Γ ,,, subst_instance_context u' (arities_context (ind_bodies mdecl)))). + (Γ ,,, subst_instance u' (arities_context (ind_bodies mdecl)))). { eapply weaken_wf_local => //. eapply wf_local_instantiate => //; destruct decli; eauto. eapply wf_arities_context => //; eauto. } - assert(wfpars : wf_local Σ (subst_instance_context u (ind_params mdecl))). + assert(wfpars : wf_local Σ (subst_instance u (ind_params mdecl))). { eapply on_minductive_wf_params => //; eauto. } intuition auto; try split; auto. - apply weaken_wf_local => //. - - pose proof (subslet_length a0). rewrite subst_instance_context_length in H1. + - pose proof (subslet_length a0). rewrite subst_instance_length in H1. rewrite -H1 -subst_app_context. - eapply (substitution_wf_local _ _ (subst_instance_context u (arities_context (ind_bodies mdecl) ,,, ind_params mdecl))); eauto. - rewrite subst_instance_context_app; eapply subslet_app; eauto. + eapply (substitution_wf_local _ _ (subst_instance u (arities_context (ind_bodies mdecl) ,,, ind_params mdecl))); eauto. + rewrite subst_instance_app; eapply subslet_app; eauto. now rewrite closed_ctx_subst ?closedn_subst_instance_context. eapply (weaken_subslet _ _ _ _ []) => //. now eapply subslet_inds; eauto. rewrite -app_context_assoc. eapply weaken_wf_local => //. - rewrite -subst_instance_context_app. + rewrite -subst_instance_app_ctx. apply a. - - exists (map (subst_instance_univ u') (cshape_sorts cshape)). split. + - exists (map (subst_instance_univ u') x). split. move/onParams: onmind. rewrite /on_context. pose proof (wf_local_instantiate Σ (InductiveDecl mdecl) (ind_params mdecl) u'). move=> H'. eapply X in H'; eauto. @@ -1418,16 +716,16 @@ Proof. 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_instance_context u' (ind_params mdecl)))) => //. + (subst_instance u' (ind_params mdecl)))) => //. simpl. eapply weaken_wf_local => //. rewrite closed_ctx_subst => //. now rewrite closedn_subst_instance_context. - simpl. rewrite -(subst_instance_context_length u' (ind_params mdecl)). - eapply (subst_sorts_local_ctx _ _ _ (subst_instance_context u' (arities_context (ind_bodies mdecl)))) => //. + simpl. rewrite -(subst_instance_length u' (ind_params mdecl)). + eapply (subst_sorts_local_ctx _ _ _ (subst_instance u' (arities_context (ind_bodies mdecl)))) => //. eapply weaken_wf_local => //. rewrite -app_context_assoc. eapply weaken_sorts_local_ctx => //. - rewrite -subst_instance_context_app. + rewrite -subst_instance_app_ctx. eapply sorts_local_ctx_instantiate => //; destruct decli; eauto. eapply (weaken_subslet _ _ _ _ []) => //. now eapply subslet_inds; eauto. @@ -1442,22 +740,21 @@ Proof. rewrite (firstn_app_left _ 0). { rewrite !map_length to_extended_list_k_length. lia. } rewrite /= app_nil_r. - rewrite skipn_all_app_eq. - len. lia. + rewrite skipn_all_app_eq ?lengths //. rewrite !map_map_compose. - assert (#|cshape.(cshape_args)| <= #|isubst|). + assert (#|cdecl.(cstr_args)| <= #|isubst|). apply context_subst_length in argsub. - autorewrite with len in argsub. + len in argsub. now apply firstn_length_le_inv. - rewrite -(firstn_skipn #|cshape.(cshape_args)| isubst). + rewrite -(firstn_skipn #|cdecl.(cstr_args)| isubst). rewrite -[map _ (to_extended_list_k _ _)] - (map_map_compose _ _ _ (subst_instance_constr u) + (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 -to_extended_list_k_map_subst. - rewrite subst_instance_context_length. lia. + rewrite subst_instance_length. lia. rewrite map_subst_app_to_extended_list_k. rewrite firstn_length_le => //. @@ -1470,16 +767,16 @@ Proof. - rewrite it_mkProd_or_LetIn_app. unfold type_of_constructor in vty. - rewrite cshape_eq in vty. move: vty. - rewrite !subst_instance_constr_it_mkProd_or_LetIn. - rewrite !subst_it_mkProd_or_LetIn subst_instance_context_length Nat.add_0_r. - rewrite subst_instance_constr_mkApps subst_mkApps subst_instance_context_length. + rewrite cdecl_eq in vty. move: vty. + rewrite !subst_instance_it_mkProd_or_LetIn. + rewrite !subst_it_mkProd_or_LetIn subst_instance_length Nat.add_0_r. + rewrite subst_instance_mkApps subst_mkApps subst_instance_length. rewrite subst_inds_concl_head. all:simpl; auto. Qed. Notation "⋆" := ltac:(solve [pcuic]) (only parsing). -Lemma build_branches_type_red {cf:checker_flags} (p p' : term) (ind : inductive) +(*Lemma build_branches_type_red {cf:checker_flags} (p p' : term) (ind : inductive) (mdecl : PCUICAst.mutual_inductive_body) (idecl : PCUICAst.one_inductive_body) (pars : list term) (u : Instance.t) (brtys : list (nat × term)) Σ Γ : @@ -1498,10 +795,10 @@ Proof. intros _ [= <-]. exists []; split; auto. simpl. intros n. destruct a. destruct p0. - destruct (instantiate_params (subst_instance_context u (PCUICAst.ind_params mdecl)) + destruct (instantiate_params (subst_instance u (PCUICAst.ind_params mdecl)) pars (subst0 (inds (inductive_mind ind) u (PCUICAst.ind_bodies mdecl)) - (subst_instance_constr u t))). + (subst_instance u t))). destruct decompose_prod_assum. destruct chop. destruct map_option_out eqn:Heq. @@ -1522,13 +819,13 @@ Proof. eapply red1_mkApps_f. eapply (weakening_red1 Σ Γ [] c) => //. Qed. - +*) Lemma conv_decls_fix_context_gen {cf:checker_flags} Σ Γ mfix mfix1 : wf Σ.1 -> All2 (fun d d' => conv Σ Γ d.(dtype) d'.(dtype) * eq_binder_annot d.(dname) d'.(dname)) mfix mfix1 -> forall Γ' Γ'', conv_context Σ (Γ ,,, Γ') (Γ ,,, Γ'') -> - context_relation (fun Δ Δ' : PCUICAst.context => conv_decls Σ (Γ ,,, Γ' ,,, Δ) (Γ ,,, Γ'' ,,, Δ')) + All2_fold (fun Δ Δ' : context => conv_decls Σ (Γ ,,, Γ' ,,, Δ) (Γ ,,, Γ'' ,,, Δ')) (fix_context_gen #|Γ'| mfix) (fix_context_gen #|Γ''| mfix1). Proof. intros wfΣ. @@ -1537,18 +834,18 @@ Proof. destruct r as [r eqann]. assert(conv_decls Σ (Γ ,,, Γ' ,,, []) (Γ ,,, Γ'' ,,, []) - (PCUICAst.vass (dname x) (lift0 #|Γ'| (dtype x))) - (PCUICAst.vass (dname y) (lift0 #|Γ''| (dtype y)))). + (vass (dname x) (lift0 #|Γ'| (dtype x))) + (vass (dname y) (lift0 #|Γ''| (dtype y)))). { constructor; tas. - pose proof (context_relation_length convctx). + pose proof (All2_fold_length convctx). rewrite !app_length in H. assert(#|Γ'| = #|Γ''|) by lia. rewrite -H0. apply (weakening_conv _ _ []); auto. } - apply context_relation_app_inv. rewrite !List.rev_length; len. - now apply All2_length in X. - constructor => //. - eapply (context_relation_impl (P:= (fun Δ Δ' : PCUICAst.context => + apply All2_fold_app. len'; cbn. + now apply All2_length in X. + constructor => //. constructor. + eapply (All2_fold_impl (P:= (fun Δ Δ' : context => conv_decls Σ (Γ ,,, (vass (dname x) (lift0 #|Γ'| (dtype x)) :: Γ') ,,, Δ) (Γ ,,, (vass (dname y) (lift0 #|Γ''| (dtype y)) :: Γ'') ,,, Δ')))). @@ -1561,7 +858,7 @@ Qed. Lemma conv_decls_fix_context {cf:checker_flags} Σ Γ mfix mfix1 : wf Σ.1 -> All2 (fun d d' => conv Σ Γ d.(dtype) d'.(dtype) * eq_binder_annot d.(dname) d'.(dname)) mfix mfix1 -> - context_relation (fun Δ Δ' : PCUICAst.context => conv_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) + All2_fold (fun Δ Δ' : context => conv_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) (fix_context mfix) (fix_context mfix1). Proof. intros wfΣ a. @@ -1578,7 +875,7 @@ Proof. constructor. constructor. Qed. -Lemma declared_inductive_unique {Σ mdecl idecl p} (q r : declared_inductive Σ mdecl p idecl) : q = r. +Lemma declared_inductive_unique {Σ mdecl idecl p} (q r : declared_inductive Σ p mdecl idecl) : q = r. Proof. unfold declared_inductive in q, r. destruct q, r. @@ -1586,9 +883,9 @@ Proof. Qed. Lemma declared_inductive_unique_sig {cf:checker_flags} {Σ ind mib decl mib' decl'} - (decl1 : declared_inductive Σ mib ind decl) - (decl2 : declared_inductive Σ mib' ind decl') : - @sigmaI _ (fun '(m, d) => declared_inductive Σ m ind d) + (decl1 : declared_inductive Σ ind mib decl) + (decl2 : declared_inductive Σ ind mib' decl') : + @sigmaI _ (fun '(m, d) => declared_inductive Σ ind m d) (mib, decl) decl1 = @sigmaI _ _ (mib', decl') decl2. Proof. @@ -1597,23 +894,59 @@ Proof. reflexivity. Qed. +Lemma conv_context_rel_context_assumptions {cf:checker_flags} P Γ Δ Δ' : + conv_context_rel P Γ Δ Δ' -> + context_assumptions Δ = context_assumptions Δ'. +Proof. + induction 1; auto. + cbn. + depelim p; cbn; lia. +Qed. + Lemma invert_Case_Construct {cf:checker_flags} Σ (hΣ : ∥ wf Σ.1 ∥) - {Γ ind ind' npar pred i u brs args T} : - Σ ;;; Γ |- tCase (ind, npar) pred (mkApps (tConstruct ind' i u) args) brs : T -> - ind = ind'. + {Γ ci ind' pred i u brs args T} : + Σ ;;; Γ |- tCase ci pred (mkApps (tConstruct ind' i u) args) brs : T -> + ci.(ci_ind) = ind' /\ + exists br, + nth_error brs i = Some br /\ + (#|args| = ci.(ci_npar) + context_assumptions br.(bcontext))%nat. Proof. destruct hΣ as [wΣ]. intros h. apply inversion_Case in h as ih ; auto. destruct ih - as [uni [args' [mdecl [idecl [pty [indctx [pctx [ps [btys [? [? [? [? [ht0 [? ?]]]]]]]]]]]]]]]. - pose proof ht0 as typec. + as [mdecl [idecl [isdecl [indices [cinv cum]]]]]. + destruct cinv. + pose proof scrut_ty as typec. eapply inversion_mkApps in typec as [A' [tyc tyargs]]; auto. eapply (inversion_Construct Σ wΣ) in tyc as [mdecl' [idecl' [cdecl' [wfl [declc [Hu tyc]]]]]]. - epose proof (PCUICInductiveInversion.Construct_Ind_ind_eq _ ht0 declc); eauto. - destruct on_declared_constructor as [[onmind oib] [cs [? ?]]]. + epose proof (PCUICInductiveInversion.Construct_Ind_ind_eq _ scrut_ty declc); eauto. simpl in *. intuition auto. + subst. + destruct declc as (decli&nthctor). + cbn in nthctor. + pose proof (declared_inductive_unique_sig isdecl decli) as H; noconf H. + eapply All2i_nth_error_l in nthctor as H; eauto. + destruct H as (br&nth&(?&cc)&?). + exists br. + split; auto. destruct cc as [wf' cc]. + apply conv_context_rel_app in cc. + cbn in cc. + unfold case_branch_type, case_branch_type_gen, case_branch_context_gen in cc. + cbn in cc. + apply conv_context_rel_context_assumptions in cc. + unfold expand_lets_ctx, expand_lets_k_ctx in cc. + repeat (rewrite ?context_assumptions_subst_context + ?context_assumptions_lift_context + ?context_assumptions_subst_instance in cc). + rewrite map2_set_binder_name_context_assumptions in cc; [|lia]. + rewrite forget_types_length. + apply wf_branch_length. + eapply Forall2_All2 in wf_brs. + eapply All2_nth_error_Some_r in nth; eauto. + destruct nth as (?&?&?). + congruence. Qed. Lemma Proj_Construct_ind_eq {cf:checker_flags} Σ (hΣ : ∥ wf Σ.1 ∥) {Γ i i' pars narg c u l T} : @@ -1628,8 +961,6 @@ Proof. eapply inversion_mkApps in typec as [A' [tyc tyargs]]; auto. eapply (inversion_Construct Σ wΣ) in tyc as [mdecl' [idecl' [cdecl' [wfl [declc [Hu tyc]]]]]]. epose proof (PCUICInductiveInversion.Construct_Ind_ind_eq _ hc declc); eauto. - destruct on_declared_constructor as [[onmind oib] [cs [? ?]]]. - simpl in *. intuition auto. Qed. @@ -1649,24 +980,24 @@ Proof. eapply inversion_mkApps in typec as [A' [tyc tyargs]]; auto. eapply (inversion_Construct Σ wΣ) in tyc as [mdecl' [idecl' [cdecl' [wfl [declc [Hu tyc]]]]]]. pose proof (declared_inductive_unique_sig d.p1 declc.p1) as H; noconf H. - set (declc' := - (conj (let (x, _) := d in x) declc.p2) : declared_constructor Σ.1 mdecl idecl (i, c) cdecl'). - epose proof (PCUICInductiveInversion.Construct_Ind_ind_eq _ hc declc'); eauto. + clear H. + epose proof (PCUICInductiveInversion.Construct_Ind_ind_eq _ hc declc); eauto. simpl in X. - destruct (on_declared_projection wΣ d). + destruct (on_declared_projection d). set (oib := declared_inductive_inv _ _ _ _) in *. - simpl in *. - set (foo := (All2_nth_error_Some _ _ _ _)) in X. - clearbody foo. - destruct (ind_cshapes oib) as [|? []] eqn:Heq; try contradiction. - destruct foo as [t' [ntht' onc]]. - destruct c; simpl in ntht'; try discriminate. - noconf ntht'. - 2:{ rewrite nth_error_nil in ntht'. discriminate. } - destruct X as [[[_ Ru] Hl] Hpars]. rewrite Hl. + simpl in *. + destruct declc. + destruct (ind_ctors idecl) as [|? []] eqn:hctor in y; try contradiction. + simpl in H. + rewrite hctor /= in H0. + destruct y as [[[? ?] ?] ?]. + destruct (ind_cunivs oib) as [|? []] eqn:Heq; try contradiction. + destruct c; simpl in H0 => //. noconf H0. + intuition auto. + 2:{ rewrite nth_error_nil in H0. noconf H0. } + rewrite b0. destruct d as [decli [nthp parseq]]. - simpl in *. rewrite parseq. - destruct y as [[_ onps] onp]. lia. + simpl in *. rewrite parseq. lia. Qed. Ltac unf_env := @@ -1689,7 +1020,7 @@ Proof. solve_discr. rewrite smash_context_app_def. rewrite /subst1 subst_it_mkProd_or_LetIn in H. specialize (X (subst_context [b] 0 Δ) ltac:(len; lia) _ _ H). - simpl; autorewrite with len in X |- *. + simpl; len in X. len. destruct X; split; auto. simpl. rewrite extended_subst_app /= !subst_empty !lift0_id lift0_context. rewrite subst_app_simpl; len => /=. @@ -1699,7 +1030,7 @@ Proof. - rewrite it_mkProd_or_LetIn_app /=; intros H; depelim H. solve_discr. rewrite smash_context_app_ass. specialize (X Δ ltac:(len; lia) _ _ H). - simpl; autorewrite with len in X |- *. + simpl; len. destruct X; split; auto. simpl. eapply All_local_env_app; split. constructor; auto. @@ -1713,128 +1044,47 @@ Proof. apply context_assumptions_length_bound. now rewrite app_context_assoc. Qed. - -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. - - now rewrite /expand_lets_k_ctx /= Nat.add_0_r. - - rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. - rewrite /expand_lets_ctx expand_lets_k_ctx_decl /= it_mkProd_or_LetIn_app. - simpl. f_equal. rewrite app_length /=. - simpl. rewrite Nat.add_1_r Nat.add_succ_r. - now rewrite -(H Δ ltac:(lia) (S k)). - - rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. - rewrite /expand_lets_ctx expand_lets_k_ctx_decl /= it_mkProd_or_LetIn_app. - simpl. f_equal. rewrite app_length /=. - simpl. rewrite Nat.add_1_r Nat.add_succ_r. - now rewrite -(H Δ ltac:(lia) (S k)). -Qed. - -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 : - 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_cstr_head k Γ : - expand_lets Γ (tRel (k + #|Γ|)) = tRel (k + context_assumptions Γ). -Proof. - rewrite /expand_lets /expand_lets_k. - rewrite lift_rel_ge. lia. - rewrite subst_rel_gt. len. lia. - len. lia_f_equal. -Qed. - Lemma positive_cstr_closed_indices {cf:checker_flags} {Σ : global_env_ext} (wfΣ : wf Σ.1): - forall {i mdecl idecl cdecl ind_indices cs}, - on_constructor (lift_typing typing) (Σ.1, ind_universes mdecl) mdecl i idecl ind_indices cdecl cs -> - All (closedn (context_assumptions (ind_params mdecl ,,, cshape_args cs))) - (map (expand_lets (cshape_args cs ++ ind_params mdecl)) (cshape_indices cs)). + forall {i mdecl idecl cdecl}, + declared_constructor Σ.1 i mdecl idecl cdecl -> + All (closedn (context_assumptions (ind_params mdecl ,,, cstr_args cdecl))) + (map (expand_lets (cstr_args cdecl ++ ind_params mdecl)) (cstr_indices cdecl)). Proof. intros. - pose proof (X.(on_ctype_positive)). - rewrite X.(cstr_eq) in X0. unf_env. - rewrite -it_mkProd_or_LetIn_app in X0. - eapply positive_cstr_it_mkProd_or_LetIn in X0 as [hpars hpos]. + pose proof (on_declared_constructor H) as [[onmind oib] [cs [hnth onc]]]. + pose proof (onc.(on_ctype_positive)). + rewrite onc.(cstr_eq) in X. unf_env. + rewrite -it_mkProd_or_LetIn_app in X. + eapply positive_cstr_it_mkProd_or_LetIn in X as [hpars hpos]. rewrite app_context_nil_l in hpos. rewrite expand_lets_mkApps in hpos. unfold cstr_concl_head in hpos. - have subsrel := expand_lets_cstr_head (#|ind_bodies mdecl| - S i) (cshape_args cs ++ ind_params mdecl). - rewrite app_length (Nat.add_comm #|(cshape_args cs)|) Nat.add_assoc in subsrel. rewrite {}subsrel in hpos. + have subsrel := expand_lets_tRel (#|ind_bodies mdecl| - S (inductive_ind i.1)) (cstr_args cdecl ++ ind_params mdecl). + rewrite app_length (Nat.add_comm #|(cstr_args cdecl)|) Nat.add_assoc in subsrel. + rewrite {}subsrel in hpos. rewrite context_assumptions_app in hpos. depelim hpos; solve_discr. - noconf H0. noconf H1. eapply All_map_inv in a. eapply All_app in a as [ _ a]. - eapply All_map; eapply (All_impl a); clear; intros x H; len in H; simpl in H. - now rewrite context_assumptions_app. -Qed. - -Lemma smash_context_app_expand Γ Δ Δ' : - smash_context Γ (Δ ,,, Δ') = - smash_context [] Δ ,,, expand_lets_ctx Δ (smash_context Γ Δ'). -Proof. - rewrite smash_context_app smash_context_acc. - rewrite /expand_lets_k_ctx /app_context. f_equal. + eapply All_map; eapply (All_impl a); clear; intros x; len. Qed. -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. - rewrite -smash_context_lift -smash_context_subst /=; len. - lia_f_equal. -Qed. - -Lemma expand_lets_k_ctx_length Γ k Δ : #|expand_lets_k_ctx Γ k Δ| = #|Δ|. -Proof. now rewrite /expand_lets_k_ctx; len. Qed. -Hint Rewrite expand_lets_k_ctx_length : len. - -Lemma expand_lets_ctx_length Γ Δ : #|expand_lets_ctx Γ Δ| = #|Δ|. -Proof. now rewrite /expand_lets_ctx; len. Qed. -Hint Rewrite expand_lets_ctx_length : len. - -Lemma expand_lets_k_ctx_nil Γ k : expand_lets_k_ctx Γ k [] = []. -Proof. reflexivity. Qed. - -Lemma expand_lets_ctx_nil Γ : expand_lets_ctx Γ [] = []. -Proof. reflexivity. Qed. -Hint Rewrite expand_lets_k_ctx_nil expand_lets_ctx_nil : pcuic. - Lemma positive_cstr_arg_subst_instance {mdecl Γ} {t} u : positive_cstr_arg mdecl Γ t -> - positive_cstr_arg mdecl (subst_instance_context u Γ) (subst_instance_constr u t). + positive_cstr_arg mdecl (subst_instance u Γ) (subst_instance u t). Proof. induction 1. - constructor 1; len. - now rewrite closedn_subst_instance_constr. - - rewrite subst_instance_constr_mkApps. econstructor 2; len => //; eauto. + now rewrite closedn_subst_instance. + - rewrite subst_instance_mkApps. econstructor 2; len => //; eauto. eapply All_map; solve_all. - now rewrite closedn_subst_instance_constr. + now rewrite closedn_subst_instance. - simpl. constructor 3; len => //. - now rewrite -subst_subst_instance_constr in IHX. + now rewrite subst_instance_subst in IHX. - simpl. constructor 4; len => //. - now rewrite closedn_subst_instance_constr. + now rewrite closedn_subst_instance. Qed. -Lemma declared_inductive_lookup_inductive {Σ ind mdecl idecl} : - declared_inductive Σ mdecl ind idecl -> - lookup_inductive Σ ind = Some (mdecl, idecl). -Proof. - rewrite /declared_inductive /lookup_inductive. - intros []. red in H. now rewrite /lookup_minductive H H0. -Qed. - Notation red_terms Σ Γ := (All2 (red Σ Γ)). Lemma red_terms_conv_terms {cf:checker_flags} {Σ : global_env_ext} Γ u u' : @@ -1879,9 +1129,9 @@ Proof. now eapply eq_terms_conv_terms. Qed. -Lemma nth_error_subst_instance_context u Γ n : - nth_error (subst_instance_context u Γ) n = - option_map (map_decl (subst_instance_constr u)) (nth_error Γ 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. @@ -1912,7 +1162,7 @@ Proof. eapply red_mkApps; eauto. eapply red_mkApps; eauto. eapply eq_term_upto_univ_napp_mkApps. - now rewrite Nat.add_0_r -(All2_length _ _ redl). + now rewrite Nat.add_0_r -(All2_length redl). apply eq. Qed. @@ -1981,16 +1231,16 @@ Qed. Lemma positive_cstr_arg_subst {cf:checker_flags} {Σ : global_env_ext} {ind mdecl idecl Γ t u u'} : wf Σ -> - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> R_opt_variance (eq_universe Σ) (leq_universe Σ) (ind_variance mdecl) u u' -> - wf_local Σ (subst_instance_context u (ind_arities mdecl) ,,, subst_instance_context u Γ) -> + wf_local Σ (subst_instance u (ind_arities mdecl) ,,, subst_instance u Γ) -> closedn_ctx #|ind_arities mdecl| Γ -> - Σ ;;; subst_instance_context u (ind_arities mdecl) ,,, subst_instance_context u Γ |- (subst_instance_constr u t) <= (subst_instance_constr u' t) -> - isType Σ (subst_instance_context u (ind_arities mdecl) ,,, subst_instance_context u Γ) (subst_instance_constr u t) -> + Σ ;;; subst_instance u (ind_arities mdecl) ,,, subst_instance u Γ |- (subst_instance u t) <= (subst_instance u' t) -> + isType Σ (subst_instance u (ind_arities mdecl) ,,, subst_instance u Γ) (subst_instance u t) -> positive_cstr_arg mdecl Γ t -> - (Σ ;;; subst_context (ind_subst mdecl ind u) 0 (subst_instance_context u Γ) |- (subst (ind_subst mdecl ind u) #|Γ| (subst_instance_constr u t)) <= - subst (ind_subst mdecl ind u') #|Γ| (subst_instance_constr u' t)). + (Σ ;;; 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. intros wfΣ decli cu ru cl wf cum isty pos. pose proof (proj1 decli) as declm. @@ -2002,14 +1252,14 @@ Proof. 2:{ eapply subslet_inds; eauto. } eapply isType_subst_gen in isty; eauto. 2:{ eapply subslet_inds; eauto. } - rewrite !subst_closedn ?closedn_subst_instance_constr //. - rewrite !subst_closedn ?closedn_subst_instance_constr // in cum; len; auto. + rewrite !subst_closedn ?closedn_subst_instance //. + rewrite !subst_closedn ?closedn_subst_instance // in cum; len; auto. now rewrite app_context_nil_l in cum. - - rewrite !subst_instance_constr_mkApps !subst_mkApps in cum |- *. + - rewrite !subst_instance_mkApps !subst_mkApps in cum |- *. simpl in cum. eapply cumul_mkApps_tRel in cum; eauto; cycle 1. - { rewrite nth_error_app_ge // subst_instance_context_length // - nth_error_subst_instance_context. + { rewrite nth_error_app_ge // subst_instance_length // + nth_error_subst_instance. unfold ind_arities, arities_context. rewrite rev_map_spec -map_rev. rewrite nth_error_map e /=. reflexivity. } @@ -2020,12 +1270,12 @@ Proof. rewrite /ind_subst !inds_spec !rev_mapi !nth_error_mapi. rewrite e /=. simpl. constructor. simpl. unfold R_global_instance. simpl. - assert(declared_inductive Σ mdecl {| + assert(declared_inductive Σ {| inductive_mind := inductive_mind ind; - inductive_ind := Nat.pred #|ind_bodies mdecl| - (k - #|ctx|) |} i). + inductive_ind := Nat.pred #|ind_bodies mdecl| - (k - #|ctx|) |} mdecl i). { split; auto. simpl. rewrite -e nth_error_rev; lia_f_equal. } rewrite (declared_inductive_lookup_inductive H) //. - eapply on_declared_inductive in H as [onmind onind] => //. simpl in *. + destruct (on_declared_inductive H) as [onmind onind] => //. simpl in *. rewrite e0 /ind_realargs /PCUICTypingDef.destArity. rewrite !onind.(ind_arity_eq). rewrite !destArity_it_mkProd_or_LetIn /=; len; simpl. @@ -2036,17 +1286,17 @@ Proof. 4:{ eapply (subslet_inds _ _ u); eauto. } all:eauto. 3:{ eapply All2_refl. intros x; eapply conv_refl'. } - rewrite app_context_nil_l // in cum. autorewrite with len in cum. + rewrite app_context_nil_l // in cum. len in cum. rewrite /ind_subst. { do 2 eapply All2_map. do 2 eapply All2_map_inv in cum. eapply All2_All in cum. apply All_All2_refl. - solve_all. autorewrite with len in b. - now rewrite !subst_closedn ?closedn_subst_instance_constr // in b |- *. } + solve_all. + now rewrite !subst_closedn ?closedn_subst_instance // in b |- *. } now rewrite app_context_nil_l. - simpl in cum |- *. eapply cumul_LetIn_subst; eauto. - rewrite - !subst_subst_instance_constr /= in IHpos. + rewrite !subst_instance_subst /= in IHpos. rewrite !distr_subst /= in IHpos. rewrite /subst1. eapply IHpos => //. eapply cumul_LetIn_inv in cum; eauto. @@ -2059,11 +1309,11 @@ Proof. destruct dom as [_ dom]. eapply substitution_conv in dom; rewrite ?app_context_nil_l; eauto. 2:{ eapply subslet_inds; eauto. } - rewrite ?app_context_nil_l ?closedn_subst_instance_context // in dom. - rewrite !subst_closedn ?closedn_subst_instance_constr // in dom; len; auto. - now rewrite !subst_closedn ?closedn_subst_instance_constr. + rewrite ?app_context_nil_l ?closedn_subst_instance // in dom. + rewrite !subst_closedn ?closedn_subst_instance // in dom; len; auto. + now rewrite !subst_closedn ?closedn_subst_instance. * cbn -[closedn_ctx] in IHpos. rewrite subst_context_snoc in IHpos. - autorewrite with len in IHpos. eapply IHpos; eauto. + rewrite map_length Nat.add_0_r in IHpos. eapply IHpos; eauto. simpl; constructor; auto. simpl in isty. eapply isType_tProd in isty as [Hty Ht]; eauto. rewrite closedn_ctx_cons /=. apply/andb_and; split; auto. simpl. @@ -2087,30 +1337,30 @@ Qed. Lemma positive_cstr_closed_args_subst_arities {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {u u' Γ} {i ind mdecl idecl cdecl ind_indices cs} : - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> on_constructor (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_context u (ind_params mdecl)) -> - wf_local Σ (subst_instance_context u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl) ,,, Γ)) -> + closed_ctx (subst_instance u (ind_params mdecl)) -> + wf_local Σ (subst_instance u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl) ,,, Γ)) -> All_local_env (fun (Γ : PCUICEnvironment.context) (t : term) (_ : option term) => positive_cstr_arg mdecl ([] ,,, (smash_context [] (ind_params mdecl) ,,, Γ)) t) Γ -> assumption_context Γ -> - cumul_ctx_rel Σ (subst_instance_context u (ind_arities mdecl) ,,, - subst_instance_context u + cumul_ctx_rel Σ (subst_instance u (ind_arities mdecl) ,,, + subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))) - (subst_instance_context u Γ) (subst_instance_context u' Γ) -> + (subst_instance u Γ) (subst_instance u' Γ) -> - wt_cumul_ctx_rel Σ (subst_instance_context u (smash_context [] (PCUICEnvironment.ind_params mdecl))) - (subst_context (ind_subst mdecl ind u) (context_assumptions (ind_params mdecl)) (subst_instance_context u Γ)) - (subst_context (ind_subst mdecl ind u') (context_assumptions (ind_params mdecl)) (subst_instance_context u' Γ)). + wt_cumul_ctx_rel Σ (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' Γ)). Proof. intros * decli cu onc onv cl wf cpos ass. intros cum. split. - 2:{ rewrite !subst_instance_context_app in wf. + 2:{ rewrite !subst_instance_app_ctx in wf. rewrite -app_context_assoc -(app_context_nil_l (_ ,,, _)) app_context_assoc in wf. eapply substitution_wf_local in wf; eauto. 2:{ eapply subslet_inds; eauto. } @@ -2122,69 +1372,65 @@ Proof. now len in wf. } revert cum. induction cpos; simpl; rewrite ?subst_context_nil ?subst_context_snoc; try solve [constructor; auto]. - all:len; intros cv; depelim cv; depelim wf. + all:rewrite ?map_length; intros cv; depelim cv; depelim wf. assert (isType Σ - (subst_instance_context u (ind_arities mdecl) ,,, - subst_instance_context u (smash_context [] (ind_params mdecl) ,,, Γ)) - (subst_instance_constr u t)). - { rewrite subst_instance_context_app app_context_assoc. simpl in l. - now rewrite ![map _ _]subst_instance_context_app subst_instance_context_app in l. } + (subst_instance u (ind_arities mdecl) ,,, + subst_instance u (smash_context [] (ind_params mdecl) ,,, Γ)) + (subst_instance u t)). + { rewrite subst_instance_app_ctx app_context_assoc. simpl in l. + now rewrite ![map _ _]subst_instance_app_ctx subst_instance_app_ctx in l. } depelim c. all:constructor. - eapply IHcpos. auto. now depelim ass. eapply cv. - constructor; auto. rewrite app_context_nil_l in t0. eapply positive_cstr_arg_subst in t0; eauto. - move: t0; len; simpl. - * rewrite subst_instance_context_smash /=. - rewrite subst_instance_context_app subst_instance_context_smash subst_context_app. - rewrite closed_ctx_subst ?closedn_subst_instance_context // ?closedn_smash_context; eauto. + move: t0; rewrite ?app_context_length ?smash_context_length; simpl. + * rewrite subst_instance_smash /=. + rewrite subst_instance_app_ctx subst_instance_smash subst_context_app. + rewrite closed_ctx_subst ?closedn_subst_instance // ?closedn_smash_context; eauto. now len; simpl. - * rewrite ![map _ _]subst_instance_context_app subst_instance_context_app in wf. - now rewrite subst_instance_context_app app_context_assoc. + * rewrite ![map _ _]subst_instance_app_ctx subst_instance_app_ctx in wf. + now rewrite subst_instance_app_ctx app_context_assoc. * eapply closed_wf_local in wf; eauto. rewrite closedn_subst_instance_context app_assoc in wf. now rewrite closedn_ctx_app /= in wf; move/andb_and: wf => [wfars wf]. - * now rewrite subst_instance_context_app app_context_assoc. + * now rewrite subst_instance_app_ctx app_context_assoc. - elimtype False; now depelim ass. - elimtype False; now depelim ass. Qed. Lemma positive_cstr_closed_args {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {u u'} - {ind mdecl idecl cdecl cs} : - declared_inductive Σ mdecl ind idecl -> - on_inductive (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl) - (onc : on_constructor (lift_typing typing) (Σ.1, ind_universes mdecl) - mdecl (inductive_ind ind) idecl (ind_indices oib) cdecl cs), + {ind mdecl idecl cdecl} : + declared_constructor Σ ind mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> R_opt_variance (eq_universe Σ) (leq_universe Σ) (ind_variance mdecl) u u' -> - cumul_ctx_rel Σ (subst_instance_context u (ind_arities mdecl) ,,, - subst_instance_context u + cumul_ctx_rel Σ (subst_instance u (ind_arities mdecl) ,,, + subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))) (smash_context [] - (subst_instance_context u + (subst_instance u (expand_lets_ctx (PCUICEnvironment.ind_params mdecl) - (cshape_args cs)))) + (cstr_args cdecl)))) (smash_context [] - (subst_instance_context u' + (subst_instance u' (expand_lets_ctx (PCUICEnvironment.ind_params mdecl) - (cshape_args cs)))) -> + (cstr_args cdecl)))) -> - wt_cumul_ctx_rel Σ (subst_instance_context u (smash_context [] (PCUICEnvironment.ind_params mdecl))) - (subst_context (inds (inductive_mind ind) u (ind_bodies mdecl)) (context_assumptions (ind_params mdecl)) + wt_cumul_ctx_rel Σ (subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))) + (subst_context (inds (inductive_mind ind.1) u (ind_bodies mdecl)) (context_assumptions (ind_params mdecl)) (smash_context [] - (subst_instance_context u + (subst_instance u (expand_lets_ctx (PCUICEnvironment.ind_params mdecl) - (cshape_args cs))))) - (subst_context (inds (inductive_mind ind) u' (ind_bodies mdecl)) (context_assumptions (ind_params mdecl)) + (cstr_args cdecl))))) + (subst_context (inds (inductive_mind ind.1) u' (ind_bodies mdecl)) (context_assumptions (ind_params mdecl)) ((smash_context [] - (subst_instance_context u' + (subst_instance u' (expand_lets_ctx (PCUICEnvironment.ind_params mdecl) - (cshape_args cs)))))). + (cstr_args cdecl)))))). Proof. - intros * decli onind oib onc cu Ru cx. + intros * declc cu Ru cx. + pose proof (on_declared_constructor declc) as [[onmind oib] [cs [? onc]]]. pose proof (onc.(on_ctype_positive)) as cpos. rewrite onc.(cstr_eq) in cpos. unf_env. rewrite -it_mkProd_or_LetIn_app in cpos. @@ -2194,23 +1440,24 @@ Proof. rewrite expand_lets_smash_context /= expand_lets_k_ctx_nil /= in hargs. eapply positive_cstr_closed_args_subst_arities in hargs; eauto. split. - - rewrite !subst_instance_context_smash /ind_subst /= in hargs |- *. + - rewrite !subst_instance_smash /ind_subst /= in hargs |- *. eapply hargs; eauto. - - destruct hargs as [hargs hwf]. now rewrite !subst_instance_context_smash in hwf |- *. - - eapply closed_wf_local; eauto; eapply on_minductive_wf_params; eauto. + - destruct hargs as [hargs hwf]. now rewrite !subst_instance_smash in hwf |- *. + - eapply declc. + - eapply closed_wf_local; eauto; eapply on_minductive_wf_params; eauto; eapply declc. - rewrite -app_context_assoc. rewrite -(expand_lets_smash_context _ []). - rewrite -smash_context_app_expand subst_instance_context_app subst_instance_context_smash. + rewrite -smash_context_app_expand subst_instance_app_ctx subst_instance_smash. eapply wf_local_smash_end; eauto. - rewrite -subst_instance_context_app app_context_assoc. - now epose proof (on_constructor_inst u wfΣ decli onind oib onc cu) as [wfarpars _]. + rewrite -subst_instance_app_ctx app_context_assoc. + now epose proof (on_constructor_inst declc _ cu) as [wfarpars _]. - eapply smash_context_assumption_context. constructor. - - now rewrite !(subst_instance_context_smash _ (expand_lets_ctx _ _)). + - now rewrite !(subst_instance_smash _ (expand_lets_ctx _ _)). Qed. Lemma red_subst_instance {cf:checker_flags} (Σ : global_env) (Γ : context) (u : Instance.t) (s t : term) : red Σ Γ s t -> - red Σ (subst_instance_context u Γ) (subst_instance_constr u s) - (subst_instance_constr u t). + red Σ (subst_instance u Γ) (subst_instance u s) + (subst_instance u t). Proof. intros H; apply clos_rt_rt1n in H. apply clos_rt1n_rt. @@ -2219,6 +1466,9 @@ Proof. econstructor 2. eapply r. auto. Qed. +From MetaCoq.PCUIC Require Import PCUICParallelReductionConfluence. +(* for nth_error lemma. should move *) + Lemma nth_error_decl_body_ass_ctx {Γ Δ i body} : assumption_context Γ -> option_map decl_body (nth_error (Γ ,,, Δ) i) = Some (Some body) -> @@ -2235,13 +1485,14 @@ Proof. by []. Qed. -Lemma red1_assumption_context_irrelevant Σ Γ Δ Γ' t t' : +(*Lemma red1_assumption_context_irrelevant Σ Γ Δ Γ' t t' : red1 Σ (Γ ,,, Δ) t t' -> assumption_context Γ -> #|Γ| = #|Γ'| -> red1 Σ (Γ' ,,, Δ) t t'. Proof. - remember (Γ ,,, Δ) as ctx. + (* subsummed by red_type_irrelevance *) + (*remember (Γ ,,, Δ) as ctx. intros H; revert Γ Δ Heqctx Γ'. induction H using red1_ind_all; intros; subst; try solve [econstructor; eauto; try solve_all]. @@ -2256,8 +1507,8 @@ Proof. now rewrite app_context_assoc in b0. - eapply cofix_red_body. solve_all. specialize (b0 Γ0 (Δ ,,, fix_context mfix0) ltac:(rewrite app_context_assoc; reflexivity) _ H H0). - now rewrite app_context_assoc in b0. -Qed. + now rewrite app_context_assoc in b0.*) +Admitted. Lemma red_assumption_context_app_irrelevant Σ Γ Δ Γ' t t' : red Σ (Γ ,,, Δ) t t' -> @@ -2281,7 +1532,7 @@ Proof. intros r ass eqc. now eapply (red_assumption_context_app_irrelevant _ _ [] Γ'). Qed. - +*) Lemma assumption_context_map f Γ : assumption_context Γ -> assumption_context (map_context f Γ). Proof. @@ -2289,28 +1540,9 @@ Proof. Qed. Lemma assumption_context_subst_instance u Γ : - assumption_context Γ -> assumption_context (subst_instance_context u Γ). + assumption_context Γ -> assumption_context (subst_instance u Γ). Proof. apply assumption_context_map. Qed. -Lemma eq_term_upto_univ_napp_impl {cf:checker_flags} (Σ : global_env) - (Re Re' Rle Rle' : Relation_Definitions.relation Universe.t) u u' t t' : - (forall x y : Universe.t, Re x y -> Re' (subst_instance_univ u x) (subst_instance_univ u' y)) -> - (forall x y : Universe.t, Rle x y -> Rle' (subst_instance_univ u x) (subst_instance_univ u' y)) -> - (forall x y : Instance.t, R_universe_instance Re x y -> R_universe_instance Re' (subst_instance_instance u x) - (subst_instance_instance u' y)) -> - (forall r n (x y : Instance.t), R_global_instance Σ Re Rle r n x y -> - R_global_instance Σ Re' Rle' r n (subst_instance_instance u x) (subst_instance_instance u' y)) -> - (forall r n (x y : Instance.t), R_global_instance Σ Re Re r n x y -> - R_global_instance Σ Re' Re' r n (subst_instance_instance u x) (subst_instance_instance u' y)) -> - forall n, eq_term_upto_univ_napp Σ Re Rle n t t' -> - eq_term_upto_univ_napp Σ Re' Rle' n (subst_instance_constr u t) (subst_instance_constr u' t'). -Proof. - intros Heq Hle Hi Hgil Hgie. - induction t in t', Re, Re', Rle, Rle', Heq, Hle, Hi, Hgil, Hgie |- * using - PCUICInduction.term_forall_list_ind; simpl; intros n' H; depelim H. - all:simpl; try solve [constructor; eauto; try solve_all]. -Qed. - Section Betweenu. Context (start : nat) (k : nat). @@ -2382,25 +1614,25 @@ Section UniverseClosedSubst. rewrite nth_error_app_lt //. Qed. *) - Lemma closedu_subst_instance_instance_app u u' t - : closedu_instance #|u'| t -> subst_instance_instance (u' ++ u) t = subst_instance_instance u' t. + 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_instance_lift u u' t - : closedu_instance #|u| t -> subst_instance_instance (u' ++ u) (lift_instance #|u'| t) = subst_instance_instance u t. + 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. intro H. eapply forallb_All in H. - rewrite /subst_instance_instance /lift_instance map_map_compose. apply All_map_eq. + 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|. -Proof. now rewrite /level_var_instance; len. Qed. +Proof. rewrite /level_var_instance; len. Qed. Hint Rewrite level_var_instance_length : len. Lemma lift_instance_length n i : #|lift_instance n i| = #|i|. @@ -2477,7 +1709,7 @@ Proof. specialize (IHinst _ H). now rewrite Nat.add_succ_r. Qed. -Lemma LSet_in_global_bounded {cf:checker_flags} {Σ 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. @@ -2622,7 +1854,7 @@ Qed. Lemma subst_instance_variance_cstrs l u i i' : CS.Equal (subst_instance_cstrs u (variance_cstrs l i i')) - (variance_cstrs l (subst_instance_instance u i) (subst_instance_instance u i')). + (variance_cstrs l (subst_instance u i) (subst_instance u i')). Proof. induction l in u, i, i' |- *; simpl; auto; destruct i, i'; simpl => //. @@ -2649,9 +1881,9 @@ Lemma cumul_inst_variance {cf:checker_flags} (Σ : global_env_ext) mdecl l v i i consistent_instance_ext Σ (ind_universes mdecl) u' -> R_universe_instance_variance (eq_universe Σ) (leq_universe Σ) l u u' -> forall t t', - cumul (Σ.1, v) (subst_instance_context i Γ) (subst_instance_constr i t) (subst_instance_constr i' t') -> - cumul Σ (subst_instance_context u Γ) - (subst_instance_constr u t) (subst_instance_constr u' t'). + cumul (Σ.1, v) (subst_instance i Γ) (subst_instance i t) (subst_instance i' t') -> + cumul Σ (subst_instance u Γ) + (subst_instance u t) (subst_instance u' t'). Proof. intros wfΣ onu onv vari cu cu' Ru t t'. intros cum. @@ -2662,17 +1894,18 @@ Proof. pose proof (consistent_instance_length cu'). rewrite -eqi' in H, H0. rewrite -H0 in cum. - assert (subst_instance_instance (u' ++ u) (lift_instance #|u'| i') = u) as subsu. - { rewrite closedu_subst_instance_instance_lift //. + assert (subst_instance (u' ++ u) (lift_instance #|u'| i') = u) as subsu. + { rewrite closedu_subst_instance_lift //. now rewrite H. rewrite eqi'. - erewrite subst_instance_instance_id => //. eauto. } - assert (subst_instance_instance (u' ++ u) i' = u') as subsu'. - { rewrite closedu_subst_instance_instance_app //. + erewrite subst_instance_id_mdecl => //. eauto. } + assert (subst_instance (u' ++ u) i' = u') as subsu'. + { rewrite closedu_subst_instance_app //. rewrite H0 //. rewrite eqi' //. - erewrite subst_instance_instance_id => //. eauto. } + erewrite subst_instance_id_mdecl => //. eauto. } eapply (cumul_subst_instance (Σ, v) _ (u' ++ u)) in cum; auto. - rewrite subst_instance_context_two in cum. - rewrite !subst_instance_constr_two in cum. + rewrite subst_instance_two in cum. + rewrite !subst_instance_two in cum. + rewrite subst_instance_two_context in cum. now rewrite subsu subsu' in cum. unfold valid_constraints. destruct check_univs eqn:checku => //. unfold valid_constraints0. @@ -2690,7 +1923,7 @@ Proof. destruct (ind_universes mdecl) as [[inst cstrs']|[inst cstrs']]. { simpl in vari => //. } rewrite !satisfies_union. len. - autorewrite with len in lenl. + len in lenl. intuition auto. - rewrite -satisfies_subst_instance_ctr //. assert(ConstraintSet.Equal (subst_instance_cstrs u' cstrs') @@ -2736,9 +1969,9 @@ Lemma conv_inst_variance {cf:checker_flags} (Σ : global_env_ext) mdecl l v i i' consistent_instance_ext Σ (ind_universes mdecl) u' -> R_universe_instance_variance (eq_universe Σ) (leq_universe Σ) l u u' -> forall t t', - conv (Σ.1, v) (subst_instance_context i Γ) (subst_instance_constr i t) (subst_instance_constr i' t') -> - conv Σ (subst_instance_context u Γ) - (subst_instance_constr u t) (subst_instance_constr u' t'). + conv (Σ.1, v) (subst_instance i Γ) (subst_instance i t) (subst_instance i' t') -> + conv Σ (subst_instance u Γ) + (subst_instance u t) (subst_instance u' t'). Proof. intros wfΣ onu onv vari cu cu' Ru t t'. intros cum. @@ -2749,17 +1982,17 @@ Proof. pose proof (consistent_instance_length cu'). rewrite -eqi' in H, H0. rewrite -H0 in cum. - assert (subst_instance_instance (u' ++ u) (lift_instance #|u'| i') = u) as subsu. - { rewrite closedu_subst_instance_instance_lift //. + assert (subst_instance (u' ++ u) (lift_instance #|u'| i') = u) as subsu. + { rewrite closedu_subst_instance_lift //. now rewrite H. rewrite eqi'. - erewrite subst_instance_instance_id => //. eauto. } - assert (subst_instance_instance (u' ++ u) i' = u') as subsu'. - { rewrite closedu_subst_instance_instance_app //. + erewrite subst_instance_id_mdecl => //. eauto. } + assert (subst_instance (u' ++ u) i' = u') as subsu'. + { rewrite closedu_subst_instance_app //. rewrite H0 //. rewrite eqi' //. - erewrite subst_instance_instance_id => //. eauto. } + erewrite subst_instance_id_mdecl => //. eauto. } eapply (conv_subst_instance (Σ, v) _ (u' ++ u)) in cum; auto. - rewrite subst_instance_context_two in cum. - rewrite !subst_instance_constr_two in cum. + rewrite subst_instance_two in cum. + rewrite !subst_instance_two subst_instance_two_context in cum. now rewrite subsu subsu' in cum. unfold valid_constraints. destruct check_univs eqn:checku => //. unfold valid_constraints0. @@ -2777,7 +2010,7 @@ Proof. destruct (ind_universes mdecl) as [[inst cstrs']|[inst cstrs']]. { simpl in vari => //. } rewrite !satisfies_union. len. - autorewrite with len in lenl. + len in lenl. intuition auto. - rewrite -satisfies_subst_instance_ctr //. assert(ConstraintSet.Equal (subst_instance_cstrs u' cstrs') @@ -2814,7 +2047,7 @@ Proof. constructor. now rewrite !Universes.Universe.val_make in Ra. Qed. -Lemma All2_local_env_inst {cf:checker_flags} (Σ : global_env_ext) mdecl l v i i' u u' Γ' Γ : +Lemma All2_fold_inst {cf:checker_flags} (Σ : global_env_ext) mdecl l v i i' u u' Γ' Γ : wf Σ -> on_udecl_prop Σ (ind_universes mdecl) -> on_variance (ind_universes mdecl) (Some l) -> @@ -2822,8 +2055,8 @@ Lemma All2_local_env_inst {cf:checker_flags} (Σ : global_env_ext) mdecl l v i i consistent_instance_ext Σ (ind_universes mdecl) u' -> variance_universes (PCUICEnvironment.ind_universes mdecl) l = Some (v, i, i') -> R_universe_instance_variance (eq_universe Σ) (leq_universe Σ) l u u' -> - cumul_ctx_rel (Σ.1, v) (subst_instance_context i Γ') (subst_instance_context i Γ) (subst_instance_context i' Γ) -> - cumul_ctx_rel Σ (subst_instance_context u Γ') (subst_instance_context u Γ) (subst_instance_context u' Γ). + cumul_ctx_rel (Σ.1, v) (subst_instance i Γ') (subst_instance i Γ) (subst_instance i' Γ) -> + cumul_ctx_rel Σ (subst_instance u Γ') (subst_instance u Γ) (subst_instance u' Γ). Proof. unfold cumul_ctx_rel. intros wfΣ onu onv cu cu' vari Ru. @@ -2831,16 +2064,16 @@ Proof. constructor. intros H; depelim H. econstructor; auto. depelim c. simpl. - rewrite -subst_instance_context_app in c, c0. simpl in c0 |- *. - rewrite -subst_instance_context_app. + rewrite -subst_instance_app_ctx in c, c0. simpl in c0 |- *. + rewrite -subst_instance_app_ctx. constructor. reflexivity. eapply conv_inst_variance; eauto. eapply cumul_inst_variance; eauto. intros H; depelim H; simpl in *. depelim c. constructor; auto. constructor; auto. - rewrite -subst_instance_context_app in c. - rewrite -subst_instance_context_app. + rewrite -subst_instance_app_ctx in c. + rewrite -subst_instance_app_ctx. eapply cumul_inst_variance; eauto. Qed. @@ -2888,16 +2121,15 @@ Proof. rewrite -(Nat.add_0_r #|s|) simpl_subst_rec /= // ?lift0_id //; lia. Qed. - -Lemma All2_local_env_impl' (P Q : context -> context -> option (term * term) -> term -> term -> Type) +(* Lemma All2_fold_impl' (P Q : context -> context -> term -> term -> Type) (par par' : context) : - All2_local_env P par par' -> - (forall (par0 par'0 : PCUICEnvironment.context) (o : option (term * term)) (x y : term), + All2_fold P par par' -> + (forall (par0 par'0 : context) (o : option (term * term)) (x y : term), P par0 par'0 o x y -> Q par0 par'0 o x y) -> - All2_local_env Q par par'. + All2_fold Q par par'. Proof. intros H HP; induction H; constructor; auto. -Qed. +Qed. *) Lemma map_map_subst_expand_lets (s : list term) (Γ : context) l k : context_assumptions Γ = #|s| -> @@ -2930,7 +2162,7 @@ Proof. now rewrite /expand_lets expand_lets_k_app. Qed. -Hint Rewrite closedn_subst_instance_constr : pcuic. +Hint Rewrite closedn_subst_instance : pcuic. Lemma subst_conv_closed {cf : checker_flags} {Σ : global_env_ext} {Γ Γ0 Γ1 Δ : context} {s s' : list term} {T U : term} : @@ -2953,75 +2185,75 @@ Proof. reflexivity. Qed. -Lemma subst_instance_constr_expand_lets u Γ t : - subst_instance_constr u (expand_lets Γ t) = - expand_lets (subst_instance_context u Γ) (subst_instance_constr u t). +Lemma subst_instance_expand_lets u Γ t : + subst_instance u (expand_lets Γ t) = + expand_lets (subst_instance u Γ) (subst_instance u t). Proof. rewrite /expand_lets /expand_lets_k. - rewrite -subst_subst_instance_constr. - rewrite extended_subst_subst_instance_constr. + rewrite subst_instance_subst. + rewrite subst_instance_extended_subst. f_equal. - rewrite lift_subst_instance_constr. len; f_equal. + rewrite subst_instance_lift. len; f_equal. Qed. -Hint Rewrite subst_instance_constr_expand_lets closedn_subst_instance_constr : substu. +Hint Rewrite subst_instance_expand_lets closedn_subst_instance : substu. -Lemma subst_instance_context_expand_lets u Γ Δ : - subst_instance_context u (expand_lets_ctx Γ Δ) = - expand_lets_ctx (subst_instance_context u Γ) (subst_instance_context u Δ). +Lemma subst_instance_expand_lets_ctx u Γ Δ : + subst_instance u (expand_lets_ctx Γ Δ) = + expand_lets_ctx (subst_instance u Γ) (subst_instance u Δ). Proof. rewrite /expand_lets_ctx /expand_lets_k_ctx. rewrite !subst_instance_subst_context !subst_instance_lift_context; len. - now rewrite -extended_subst_subst_instance_constr. + now rewrite -subst_instance_extended_subst. Qed. Lemma inductive_cumulative_indices {cf:checker_flags} {Σ : global_env_ext} (wfΣ : wf Σ.1) : forall {ind mdecl idecl u u' napp}, - declared_inductive Σ mdecl ind idecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl), + declared_inductive Σ ind mdecl idecl -> on_udecl_prop Σ (ind_universes mdecl) -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) napp u u' -> forall Γ pars pars' parsubst parsubst', - spine_subst Σ Γ pars parsubst (subst_instance_context u (ind_params mdecl)) -> - spine_subst Σ Γ pars' parsubst' (subst_instance_context u' (ind_params mdecl)) -> + spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> + spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> All2 (conv Σ Γ) pars pars' -> - let indctx := subst_instance_context u oib.(ind_indices) in - let indctx' := subst_instance_context u' oib.(ind_indices) in + let indctx := subst_instance u idecl.(ind_indices) in + let indctx' := subst_instance u' idecl.(ind_indices) in let pindctx := subst_context parsubst 0 indctx in let pindctx' := subst_context parsubst' 0 indctx' in cumul_ctx_rel Σ Γ (smash_context [] pindctx) (smash_context [] pindctx'). Proof. - intros * decli oib onu cu cu' Ru Γ * spu spu' cpars *. move: Ru. + intros * decli. + destruct (on_declared_inductive decli) as [onmind oib]. + intros onu cu cu' Ru Γ * spu spu' cpars *. move: Ru. unfold R_global_instance. pose proof decli as decli'. assert (closed_ctx - (subst_instance_context u + (subst_instance u (PCUICEnvironment.ind_params mdecl))) as clpu. { eapply closed_wf_local; eauto; eapply on_minductive_wf_params; eauto. } assert (closed_ctx - (subst_instance_context u' + (subst_instance u' (PCUICEnvironment.ind_params mdecl))) as clpu'. { eapply closed_wf_local; eauto; eapply on_minductive_wf_params; eauto. } assert (closed_ctx - (subst_instance_context u + (subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl)))) as clspu. - { rewrite subst_instance_context_smash. now eapply closedn_smash_context. } - eapply on_declared_inductive in decli' as [onind _]; eauto. + { rewrite subst_instance_smash. now eapply closedn_smash_context. } + clear decli'. assert (wf_local Σ (smash_context [] - (subst_instance_context u (PCUICEnvironment.ind_params mdecl)) ,,, + (subst_instance u (PCUICEnvironment.ind_params mdecl)) ,,, smash_context [] - (subst_instance_context u + (subst_instance u (expand_lets_ctx (PCUICEnvironment.ind_params mdecl) - (ind_indices oib))))). - { pose proof (on_minductive_wf_params_indices_inst _ _ _ _ _ wfΣ (proj1 decli) oib cu) as wf. + (ind_indices idecl))))). + { pose proof (on_minductive_wf_params_indices_inst decli _ cu) as wf. eapply wf_local_smash_context in wf; auto. - rewrite subst_instance_context_app smash_context_app_expand in wf. + rewrite subst_instance_app_ctx smash_context_app_expand in wf. rewrite expand_lets_smash_context expand_lets_k_ctx_nil in wf. - now rewrite subst_instance_context_expand_lets. } + now rewrite subst_instance_expand_lets_ctx. } destruct global_variance eqn:gv. { move:gv. simpl. rewrite (declared_inductive_lookup_inductive decli). @@ -3037,24 +2269,24 @@ Proof. unfold ind_respects_variance in respv. destruct variance_universes as [[[v i] i']|] eqn:vu => //. simpl => Ru. - pose proof (onVariance onind) as onvari. + pose proof (onVariance onmind) as onvari. rewrite indv in onvari. - eapply All2_local_env_inst in respv. + eapply All2_fold_inst in respv. 8:eauto. all:eauto. move: respv. rewrite !expand_lets_smash_context. autorewrite with pcuic. - rewrite !subst_instance_context_smash /= => args. + rewrite !subst_instance_smash /= => args. eapply (weaken_cumul_ctx _ Γ) in args => //. 4:eapply spu. 2:{ eapply closed_wf_local; eauto. } 2:{ rewrite closedn_ctx_app; apply /andb_and. split => //. simpl. len. simpl. eapply closedn_smash_context => //. len; simpl. - pose proof (on_minductive_wf_params_indices_inst _ _ _ _ _ wfΣ (proj1 decli) oib cu') as wf'. + pose proof (on_minductive_wf_params_indices_inst decli _ cu') as wf'. eapply closed_wf_local in wf'; eauto. - rewrite subst_instance_context_app in wf'. + rewrite subst_instance_app_ctx in wf'. rewrite closedn_ctx_app in wf'. move/andb_and: wf'=> [_ clargs]. - simpl in clargs; autorewrite with len in clargs. + simpl in clargs; len in clargs. eapply closedn_smash_context => //. rewrite closedn_subst_instance_context. rewrite -(Nat.add_0_l (context_assumptions (ind_params _))). @@ -3072,7 +2304,7 @@ Proof. move: args. rewrite subst_context_nil /= - !smash_context_subst /= subst_context_nil; len. rewrite !subst_instance_subst_context. - rewrite !extended_subst_subst_instance_constr. + rewrite !subst_instance_extended_subst. rewrite (subst_context_subst_context (List.rev pars)) /=; len. rewrite -(spine_subst_extended_subst spu). rewrite !subst_instance_lift_context. len. @@ -3091,68 +2323,67 @@ Proof. 4:eapply subslet_untyped_subslet; eapply spu'. { simpl. eapply wf_local_smash_end; eauto. rewrite -app_context_assoc. eapply weaken_wf_local; eauto. eapply spu. - rewrite -subst_instance_context_app. - apply (on_minductive_wf_params_indices_inst _ _ _ _ _ wfΣ (proj1 decli) oib cu). } + rewrite -subst_instance_app_ctx. + apply (on_minductive_wf_params_indices_inst decli _ cu). } 2:{ eapply spine_subst_conv; eauto. - eapply context_relation_subst_instance; eauto. apply spu. + eapply All2_fold_subst_instance; eauto. apply spu. eapply on_minductive_wf_params; eauto. } simpl. - rewrite -(subst_instance_context_smash u _ []). - rewrite -(subst_instance_context_smash u' _ []). + rewrite -(subst_instance_smash u _ []). + rewrite -(subst_instance_smash u' _ []). eapply cumul_ctx_subst_instance => //. eapply weaken_wf_local; pcuic. eapply spu. eapply on_minductive_wf_params; eauto. } Qed. +Hint Resolve declared_inductive_minductive : core. +Hint Resolve declared_constructor_inductive : core. + Lemma constructor_cumulative_indices {cf:checker_flags} {Σ : global_env_ext} (wfΣ : wf Σ.1) : - forall {ind mdecl idecl cdecl cs u u' napp}, - declared_inductive Σ mdecl ind idecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl), - on_constructor (lift_typing typing) (Σ.1, ind_universes mdecl) mdecl (inductive_ind ind) idecl - (ind_indices oib) cdecl cs -> + forall {c mdecl idecl cdecl u u' napp}, + declared_constructor Σ c mdecl idecl cdecl -> on_udecl_prop Σ (ind_universes mdecl) -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) napp u u' -> + R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef c.1) napp u u' -> forall Γ pars pars' parsubst parsubst', - spine_subst Σ Γ pars parsubst (subst_instance_context u (ind_params mdecl)) -> - spine_subst Σ Γ pars' parsubst' (subst_instance_context u' (ind_params mdecl)) -> + spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> + spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> All2 (conv Σ Γ) pars pars' -> let argctx := - (subst_context (ind_subst mdecl ind u) #|ind_params mdecl| (subst_instance_context u (cshape_args cs))) + (subst_context (ind_subst mdecl c.1 u) #|ind_params mdecl| (subst_instance u (cstr_args cdecl))) in let argctx' := - (subst_context (ind_subst mdecl ind u') #|ind_params mdecl| (subst_instance_context u' (cshape_args cs))) + (subst_context (ind_subst mdecl c.1 u') #|ind_params mdecl| (subst_instance u' (cstr_args cdecl))) in let pargctx := subst_context parsubst 0 argctx in let pargctx' := subst_context parsubst' 0 argctx' in cumul_ctx_rel Σ Γ (smash_context [] pargctx) (smash_context [] pargctx') * All2 (conv Σ (Γ ,,, smash_context [] pargctx)) - (map (subst parsubst (context_assumptions (cshape_args cs))) - (map (expand_lets argctx) (map (subst_instance_constr u) (cshape_indices cs)))) - (map (subst parsubst' (context_assumptions (cshape_args cs))) - (map (expand_lets argctx') (map (subst_instance_constr u') (cshape_indices cs)))). -Proof. - intros * decli oib onc onu cu cu' Ru Γ * spu spu' cpars *. move: Ru. + (map (subst parsubst (context_assumptions (cstr_args cdecl))) + (map (expand_lets argctx) (map (subst_instance u) (cstr_indices cdecl)))) + (map (subst parsubst' (context_assumptions (cstr_args cdecl))) + (map (expand_lets argctx') (map (subst_instance u') (cstr_indices cdecl)))). +Proof. + intros * declc. + destruct (on_declared_constructor declc) as [[onmind oib] [cs [hnth onc]]]. + intros onu cu cu' Ru Γ * spu spu' cpars *. move: Ru. unfold R_global_instance. - pose proof decli as decli'. - eapply on_declared_inductive in decli' as [onind _]; eauto. assert (closed_ctx - (subst_instance_context u + (subst_instance u (PCUICEnvironment.ind_params mdecl))) as clpu. { eapply closed_wf_local; eauto; eapply on_minductive_wf_params; eauto. } assert (closed_ctx - (subst_instance_context u' + (subst_instance u' (PCUICEnvironment.ind_params mdecl))) as clpu'. { eapply closed_wf_local; eauto; eapply on_minductive_wf_params; eauto. } assert (closed_ctx - (subst_instance_context u + (subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl)))) as clspu. - { rewrite subst_instance_context_smash. now eapply closedn_smash_context. } + { rewrite subst_instance_smash. now eapply closedn_smash_context. } destruct global_variance eqn:gv. { move:gv. - simpl. rewrite (declared_inductive_lookup_inductive decli). + simpl. rewrite (declared_inductive_lookup_inductive declc). rewrite oib.(ind_arity_eq). rewrite !destArity_it_mkProd_or_LetIn. simpl. rewrite app_context_nil_l context_assumptions_app. @@ -3166,15 +2397,15 @@ Proof. destruct variance_universes as [[[v i] i']|] eqn:vu => //. destruct respv as [args idx]. simpl => Ru. - pose proof (onVariance onind) as onvari. + pose proof (onVariance onmind) as onvari. rewrite indv in onvari. split. - { eapply All2_local_env_inst in args. + { eapply All2_fold_inst in args. 8:eauto. all:eauto. rewrite !expand_lets_smash_context in args. autorewrite with pcuic in args. - rewrite !subst_instance_context_smash /= in args. - rewrite subst_instance_context_app in args. + 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. } rewrite - !smash_context_subst !subst_context_nil in args. @@ -3187,10 +2418,10 @@ Proof. rewrite -(Nat.add_0_l (context_assumptions _)). eapply closedn_ctx_subst. len; simpl. 2:{ eapply declared_minductive_closed_inds; eauto. } - epose proof (on_constructor_wf_args _ _ _ _ _ _ wfΣ decli onind oib onc) as wf'; eauto. + epose proof (on_constructor_wf_args declc) as wf'; eauto. eapply closed_wf_local in wf'; eauto. rewrite closedn_ctx_app in wf'. move/andb_and: wf'=> [_ clargs]. - simpl in clargs; autorewrite with len in clargs. + simpl in clargs; len in clargs. rewrite closedn_subst_instance_context. rewrite Nat.add_comm. eapply closedn_ctx_expand_lets. @@ -3201,7 +2432,7 @@ Proof. pose proof (spine_subst_smash wfΣ spu') as sspu'. eapply (cumul_ctx_subst _ Γ _ _ [] _ _ (List.rev pars) (List.rev pars')) in args; eauto. 3:{ eapply All2_rev => //. } - 3:{ rewrite subst_instance_context_smash /=. + 3:{ rewrite subst_instance_smash /=. eapply subslet_untyped_subslet. eapply sspu. } 3:{ eapply subslet_untyped_subslet. eapply sspu'. } 2:{ rewrite - !app_context_assoc. eapply weaken_wf_local; eauto. @@ -3209,17 +2440,17 @@ Proof. move: args. rewrite subst_context_nil /= - !smash_context_subst /= subst_context_nil; len. rewrite !subst_instance_subst_context. - rewrite !extended_subst_subst_instance_constr. + rewrite !subst_instance_extended_subst. rewrite (subst_context_subst_context (inds _ u _)); len. rewrite (subst_context_subst_context (inds _ u' _)); len. - rewrite -(subst_instance_context_assumptions u). - rewrite -(subst_extended_subst _ _ 0). + rewrite -(subst_instance_assumptions u). + rewrite -(subst_extended_subst). rewrite (closed_ctx_subst (inds _ _ _)) //. - rewrite (subst_instance_context_assumptions u). - rewrite -(subst_instance_context_assumptions u'). - rewrite -(subst_extended_subst _ _ 0). + rewrite (subst_instance_assumptions u). + rewrite -(subst_instance_assumptions u'). + rewrite -(subst_extended_subst). rewrite (closed_ctx_subst (inds _ u' _)) //. - rewrite (subst_instance_context_assumptions u'). + rewrite (subst_instance_assumptions u'). rewrite (subst_context_subst_context (List.rev pars)) /=; len. rewrite -(spine_subst_extended_subst spu). rewrite !subst_instance_lift_context. len. @@ -3247,14 +2478,14 @@ Proof. simpl. rewrite -(map_map_compose _ _ _ _ (subst (List.rev pars') _)). evar (k : nat). - replace (context_assumptions (cshape_args cs)) with k. subst k. + replace (context_assumptions (cstr_args cdecl)) with k. subst k. unshelve eapply (conv_terms_subst _ _ _ _ _ _ _ _ _ wfΣ _ (spine_subst_smash wfΣ spu) (spine_subst_smash wfΣ spu')). { rewrite -app_context_assoc -smash_context_app_expand. eapply wf_local_smash_end; eauto. rewrite /argctx. apply weaken_wf_local; eauto. eapply spu. - destruct (on_constructor_inst u wfΣ decli onind _ onc cu) as [wfparargs _]. - rewrite !subst_instance_context_app in wfparargs. + destruct (on_constructor_inst declc _ cu) as [wfparargs _]. + rewrite !subst_instance_app_ctx in wfparargs. rewrite -app_context_assoc in wfparargs. - rewrite -(app_context_nil_l (subst_instance_context _ _ ,,, _)) in wfparargs. + rewrite -(app_context_nil_l (subst_instance _ _ ,,, _)) in wfparargs. rewrite app_context_assoc in wfparargs. eapply (substitution_wf_local _ []) in wfparargs; eauto. 2:{ eapply subslet_inds; eauto. } @@ -3262,62 +2493,62 @@ Proof. len in wfparargs. rewrite closed_ctx_subst // in wfparargs. } eapply All2_rev; eauto. - 2:{ subst k; len. now rewrite /argctx; len. } + 2:{ subst k; len. } len. simpl. rewrite !map_map_compose; eapply All2_map. eapply All2_map_inv in idx. - epose proof (positive_cstr_closed_indices wfΣ onc) as cli. + epose proof (positive_cstr_closed_indices _ declc) as cli. eapply All_map_inv in cli. - eapply All2_All in idx. solve_all. - rename a into cxy; rename b into clx. + eapply All2_All in idx. + eapply All_mix in idx; tea. clear cli. + eapply All_All2; tea. solve_all. + rename a into clx; rename b into cxy. rewrite -app_context_assoc; eapply weaken_conv; eauto. - { destruct (on_constructor_inst_pars_indices wfΣ decli onind _ onc cu spu) as [wfparargs _]. + { destruct (on_constructor_inst_pars_indices _ declc cu spu) as [wfparargs _]. rewrite -smash_context_app_expand. eapply closed_wf_local; eauto. eapply wf_local_smash_context; eauto. } { len. simpl. rewrite expand_lets_app in clx. - rewrite -(subst_instance_context_assumptions u (ind_params _)). + rewrite -(subst_instance_assumptions u (ind_params _)). rewrite (closedn_expand_lets_eq 0) // /=; len. rewrite context_assumptions_app in clx. rewrite (closedn_expand_lets_eq 0 (ind_params _)) // /= in clx; len. - now erewrite <- (closedn_subst_instance_context (u := u)). - rewrite Nat.add_comm. - epose proof (closedn_expand_lets_eq #|ind_params mdecl| _ 0 _). - rewrite Nat.add_0_r in H. rewrite /expand_lets. rewrite -> H; + now erewrite <- (closedn_subst_instance_context (u:=u)). + rewrite /expand_lets Nat.add_comm. + epose proof (closedn_expand_lets_eq #|ind_params mdecl| argctx 0). + rewrite Nat.add_0_r in H. len in H. rewrite -> H. rewrite Nat.add_comm in clx; eapply closedn_expand_lets in clx. - substu. now rewrite /argctx; len. + now substu. rewrite /argctx. rewrite -(Nat.add_0_l #|ind_params mdecl|). eapply closedn_ctx_subst; cbn. rewrite /ind_subst; len. - epose proof (on_constructor_inst u wfΣ decli onind _ onc cu) as [wfarpars _]; auto. - move/closed_wf_local: wfarpars. rewrite !subst_instance_context_app closedn_ctx_app. + epose proof (on_constructor_inst declc _ cu) as [wfarpars _]; auto. + move/closed_wf_local: wfarpars. rewrite !subst_instance_app_ctx closedn_ctx_app. now move/andb_and; len. rewrite /ind_subst. eapply declared_minductive_closed_inds; eauto. } { len. simpl. rewrite expand_lets_app in clx. - rewrite -(subst_instance_context_assumptions u' (ind_params _)). + rewrite -(subst_instance_assumptions u' (ind_params _)). rewrite (closedn_expand_lets_eq 0) // /=; len. rewrite context_assumptions_app in clx. rewrite (closedn_expand_lets_eq 0 (ind_params _)) // /= in clx; len. now erewrite <- (closedn_subst_instance_context (u := u')). rewrite Nat.add_comm. - epose proof (closedn_expand_lets_eq #|ind_params mdecl| _ 0 _). - rewrite Nat.add_0_r in H. rewrite /expand_lets. - relativize (context_assumptions argctx). rewrite -> H. + epose proof (closedn_expand_lets_eq #|ind_params mdecl| argctx' 0). + rewrite Nat.add_0_r in H. len in H. rewrite /expand_lets. + rewrite -> H. rewrite Nat.add_comm in clx; eapply closedn_expand_lets in clx. substu. now rewrite /argctx'; len. rewrite /argctx'. rewrite -(Nat.add_0_l #|ind_params mdecl|). eapply closedn_ctx_subst; cbn. rewrite /ind_subst; len. - epose proof (on_constructor_inst _ wfΣ decli onind _ onc cu') as [wfarpars _]; auto. - move/closed_wf_local: wfarpars. rewrite !subst_instance_context_app closedn_ctx_app. + epose proof (on_constructor_inst declc _ cu') as [wfarpars _]; auto. + move/closed_wf_local: wfarpars. rewrite !subst_instance_app_ctx closedn_ctx_app. now move/andb_and; len. - rewrite /ind_subst. eapply declared_minductive_closed_inds; eauto. - now rewrite /argctx /argctx'; len. } + rewrite /ind_subst. eapply declared_minductive_closed_inds; eauto. } rewrite smash_context_app smash_context_acc in cxy. - autorewrite with len in cxy. eapply conv_inst_variance in cxy. 8:eauto. all:eauto. - rewrite subst_instance_context_app in cxy. + rewrite subst_instance_app_ctx in cxy. epose proof (subst_conv_closed (Γ := []) wfΣ) as X3. rewrite !app_context_nil_l in X3. eapply X3 in cxy; clear X3; cycle 1. { eapply (subslet_inds _ _ u); eauto. } @@ -3325,51 +2556,49 @@ Proof. { now len. } { len. simpl. autorewrite with pcuic. now rewrite -context_assumptions_app. } { len. simpl. autorewrite with pcuic. now rewrite -context_assumptions_app. } - { destruct (on_constructor_inst u wfΣ decli onind _ onc cu) as [wfparargs _]. - rewrite subst_instance_context_app subst_instance_context_smash /=. - rewrite subst_instance_subst_context subst_instance_lift_context subst_instance_context_smash. - rewrite extended_subst_subst_instance_constr. - rewrite -(subst_instance_context_assumptions u (ind_params mdecl)). - rewrite -(subst_instance_context_length u (ind_params mdecl)). + { destruct (on_constructor_inst declc _ cu) as [wfparargs _]. + rewrite subst_instance_app_ctx subst_instance_smash /=. + rewrite subst_instance_subst_context subst_instance_lift_context subst_instance_smash. + rewrite subst_instance_extended_subst. + rewrite -(subst_instance_assumptions u (ind_params mdecl)). + rewrite -(subst_instance_length u (ind_params mdecl)). rewrite -smash_context_app_expand. eapply wf_local_smash_end; eauto. - now rewrite - !subst_instance_context_app app_context_assoc. } + now rewrite - !subst_instance_app_ctx app_context_assoc. } len in cxy; substu in cxy. rewrite -context_assumptions_app in cxy. - rewrite -{1}(subst_instance_context_assumptions u (_ ++ _)) in cxy. - rewrite -{1}(subst_instance_context_assumptions u' (_ ++ _)) in cxy. + rewrite -{1}(subst_instance_assumptions u (_ ++ _)) in cxy. + rewrite -{1}(subst_instance_assumptions u' (_ ++ _)) in cxy. rewrite -(expand_lets_subst_comm' _ _ 0) in cxy. { len. substu; cbn. eapply (closedn_expand_lets 0) in clx. red; rewrite -clx; now len. } rewrite -(expand_lets_subst_comm' _ _ 0) in cxy. { len. substu; cbn. eapply (closedn_expand_lets 0) in clx. red; rewrite -clx; now len. } - rewrite !subst_instance_context_app in cxy. + rewrite !subst_instance_app_ctx in cxy. rewrite !subst_context_app in cxy. len in cxy. rewrite (closed_ctx_subst (inds _ _ _ )) // in cxy. - rewrite (closed_ctx_subst (inds _ _ _ ) _ (subst_instance_context u (ind_params mdecl))) // in cxy. - rewrite (closed_ctx_subst (inds _ _ _ ) _ (subst_instance_context u' (ind_params mdecl))) // in cxy. - rewrite {2 4}/argctx; len. + rewrite (closed_ctx_subst (inds _ _ _ ) _ (subst_instance u (ind_params mdecl))) // in cxy. + rewrite (closed_ctx_subst (inds _ _ _ ) _ (subst_instance u' (ind_params mdecl))) // in cxy. + rewrite {2}/argctx; len. rewrite !expand_lets_app in cxy; len in cxy. - rewrite {2}/argctx /argctx'. + rewrite /argctx'. eapply conv_eq_ctx; eauto. - rewrite subst_instance_context_smash /=; f_equal. - rewrite subst_instance_subst_context subst_instance_lift_context subst_instance_context_smash /=. + rewrite subst_instance_smash /=; f_equal. + rewrite subst_instance_subst_context subst_instance_lift_context subst_instance_smash /=. rewrite /argctx /expand_lets_k_ctx. - rewrite extended_subst_subst_instance_constr. + rewrite subst_instance_extended_subst. rewrite subst_context_subst_context. - rewrite -(subst_instance_context_assumptions u). - rewrite -(subst_extended_subst _ _ 0). - rewrite subst_instance_context_assumptions. + rewrite -(subst_instance_assumptions u). + rewrite -(subst_extended_subst). + rewrite subst_instance_assumptions. rewrite (closed_ctx_subst (inds _ _ _ )) //. f_equal. len. simpl. rewrite (smash_context_subst []). now rewrite subst_context_lift_context_comm; try lia. } } { simpl. - pose proof decli as decli'. assert (wf_local Σ Γ) by apply spu. - epose proof (on_constructor_inst u wfΣ decli onind oib onc cu) as - [wfargs spinst]. + epose proof (on_constructor_inst declc _ cu) as [wfargs spinst]. intros Ru; split. { rewrite /pargctx /pargctx' /argctx /argctx'. rewrite !(smash_context_subst []). @@ -3378,59 +2607,59 @@ Proof. 4:eapply subslet_untyped_subslet; eapply spu'. { simpl. rewrite -app_context_assoc. eapply weaken_wf_local; eauto. - rewrite !subst_instance_context_app in wfargs. + rewrite !subst_instance_app_ctx in wfargs. rewrite -app_context_assoc in wfargs. - rewrite -(app_context_nil_l (subst_instance_context _ _ ,,, _)) in wfargs. + rewrite -(app_context_nil_l (subst_instance _ _ ,,, _)) in wfargs. rewrite app_context_assoc in wfargs. eapply (substitution_wf_local _ []) in wfargs; eauto. 2:{ eapply subslet_inds; eauto. } rewrite subst_context_app /= app_context_nil_l in wfargs. - autorewrite with len in wfargs. + len in wfargs. rewrite closed_ctx_subst // in wfargs. rewrite -(smash_context_subst []). eapply wf_local_smash_end => //. } 2:{ eapply spine_subst_conv; eauto. - eapply context_relation_subst_instance; eauto. + eapply All2_fold_subst_instance; eauto. eapply on_minductive_wf_params; eauto. } simpl. - assert (subst_context (ind_subst mdecl ind u) 0 (subst_instance_context u (ind_params mdecl)) = - (subst_instance_context u (ind_params mdecl))) as ispars. + 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. - rewrite -(subst_instance_context_length u (ind_params mdecl)). + rewrite -(subst_instance_length u (ind_params mdecl)). eapply (cumul_ctx_subst _ Γ); eauto. 4:{ eapply subslet_untyped_subslet. eapply PCUICArities.weaken_subslet; eauto; eapply subslet_inds; eauto. } 4:{ eapply subslet_untyped_subslet. eapply PCUICArities.weaken_subslet; eauto; eapply subslet_inds; eauto. } { simpl. rewrite - !app_context_assoc. eapply weaken_wf_local; eauto. rewrite app_context_assoc. eapply wf_local_smash_end; auto. - now rewrite !subst_instance_context_app in wfargs. } + now rewrite !subst_instance_app_ctx in wfargs. } 2:now eapply conv_inds. - rewrite - !(subst_instance_context_smash _ _ []). + rewrite - !(subst_instance_smash _ _ []). eapply cumul_ctx_subst_instance => //. rewrite -app_context_assoc. eapply weaken_wf_local; eauto. - rewrite !subst_instance_context_app in wfargs. + rewrite !subst_instance_app_ctx in wfargs. now eapply All_local_env_app_inv in wfargs as [wfargs _]. } { rewrite /pargctx. rewrite (smash_context_subst []). evar (i : nat). - replace (context_assumptions (cshape_args cs)) with i. subst i. + replace (context_assumptions (cstr_args cdecl)) with i. subst i. unshelve eapply (conv_terms_subst _ _ _ _ _ _ _ _ _ wfΣ _ spu spu'); eauto. { rewrite -app_context_assoc. eapply weaken_wf_local; eauto. - rewrite !subst_instance_context_app in wfargs. + rewrite !subst_instance_app_ctx in wfargs. rewrite -app_context_assoc in wfargs. - rewrite -(app_context_nil_l (subst_instance_context _ _ ,,, _)) in wfargs. + rewrite -(app_context_nil_l (subst_instance _ _ ,,, _)) in wfargs. rewrite app_context_assoc in wfargs. eapply (substitution_wf_local _ []) in wfargs; eauto. 2:{ eapply subslet_inds; eauto. } rewrite subst_context_app /= app_context_nil_l in wfargs. - autorewrite with len in wfargs. + len in wfargs. rewrite closed_ctx_subst // in wfargs. rewrite /argctx. eapply wf_local_smash_end => //. } eapply spine_subst_conv; eauto. - eapply context_relation_subst_instance; eauto. + eapply All2_fold_subst_instance; eauto. eapply on_minductive_wf_params; eauto. 2:subst i; len; rewrite /argctx; len; reflexivity. rewrite /expand_lets /expand_lets_k. @@ -3439,32 +2668,34 @@ Proof. intros. constructor. rewrite /argctx /argctx' /=; len. - rewrite !lift_subst_instance_constr. - rewrite !subst_extended_subst. - rewrite - !extended_subst_subst_instance_constr. len. + rewrite !subst_extended_subst_k. + rewrite - !subst_instance_extended_subst. len. eapply eq_term_upto_univ_substs; eauto. typeclasses eauto. - eapply eq_term_upto_univ_subst_instance_constr; eauto; typeclasses eauto. + eapply eq_term_upto_univ_lift. + eapply eq_term_upto_univ_subst_instance; eauto; typeclasses eauto. do 2 eapply All2_map. eapply All2_refl. intros x'. eapply eq_term_upto_univ_substs. typeclasses eauto. - eapply eq_term_upto_univ_subst_instance_constr; eauto; typeclasses eauto. + eapply eq_term_upto_univ_subst_instance; eauto; typeclasses eauto. eapply eq_term_inds; eauto. } } Qed. -Lemma declared_projection_constructor {cf:checker_flags} {Σ : global_env_ext} (wfΣ : wf Σ.1) : +Lemma declared_projection_constructor {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} : forall {mdecl idecl p pdecl}, - declared_projection Σ mdecl idecl p pdecl -> - ∑ cdecl, declared_constructor Σ mdecl idecl (p.1.1, 0) cdecl. + declared_projection Σ p mdecl idecl pdecl -> + ∑ cdecl, declared_constructor Σ (p.1.1, 0) mdecl idecl cdecl. Proof. intros * declp. - set (onp := on_declared_projection wfΣ declp). + set (onp := on_declared_projection declp). set (oib := declared_inductive_inv _ _ _ _) in *. clearbody onp. destruct oib. simpl in *. destruct onp. - destruct ind_cshapes as [|[] []] eqn:cseq => //. - depelim onConstructors. exists x. - split; eauto. eapply declp. simpl. now rewrite H. + destruct ind_ctors as [|? []] eqn:cseq => //. + destruct y as [[[? ?] ?] ?]. + destruct ind_cunivs as [|? []] eqn:cseq' => //. + depelim onConstructors. exists c. + split; eauto. eapply declp. simpl. now rewrite cseq. Qed. Lemma length_nil {A} (l : list A) : #|l| = 0 -> l = []. @@ -3494,16 +2725,16 @@ Hint Resolve assumption_context_fold assumption_context_expand_lets_ctx assumption_context_subst_context assumption_context_lift_context : pcuic. Lemma subst_inds_smash_params {cf:checker_flags} {Σ : global_env_ext} {mdecl ind idecl u} {wfΣ : wf Σ} : - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> subst_context (inds (inductive_mind ind) u (ind_bodies mdecl)) 0 - (subst_instance_context u (smash_context [] (PCUICEnvironment.ind_params mdecl))) = - (subst_instance_context u (smash_context [] (PCUICEnvironment.ind_params mdecl))). + (subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))) = + (subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))). Proof. intros decli cu. rewrite closed_ctx_subst //. eapply closed_wf_local; eauto. - rewrite subst_instance_context_smash /= //. + rewrite subst_instance_smash /= //. eapply wf_local_smash_context; auto. now eapply on_minductive_wf_params; pcuic. Qed. @@ -3526,37 +2757,36 @@ Qed. Lemma subslet_projs_smash {cf:checker_flags} (Σ : global_env_ext) i mdecl idecl : forall (wfΣ : wf Σ.1) - (Hdecl : declared_inductive Σ.1 mdecl i idecl), - let oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ Hdecl in - match ind_cshapes oib return Type with - | [cs] => + (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 oib) cs -> + idecl (ind_indices idecl) cdecl -> forall Γ t u, let indsubst := inds (inductive_mind i) u (ind_bodies mdecl) in untyped_subslet Γ - (projs_inst i (ind_npars mdecl) (context_assumptions (cshape_args cs)) t) + (projs_inst i (ind_npars mdecl) (context_assumptions (cstr_args cdecl)) t) (lift_context 1 0 (subst_context (inds (inductive_mind i) u (ind_bodies mdecl)) (context_assumptions (ind_params mdecl)) - (subst_instance_context u (expand_lets_ctx (ind_params mdecl) (smash_context [] (cshape_args cs)))))) + (subst_instance u (expand_lets_ctx (ind_params mdecl) (smash_context [] (cstr_args cdecl)))))) | _ => True end. Proof. - intros wfΣ Hdecl oib. - destruct ind_cshapes as [|cs []] eqn:Heq; trivial. + intros wfΣ Hdecl. + destruct ind_ctors as [|cdecl []] eqn:hcdecl => //. intros onp. simpl. intros Γ t u. destruct onp. assert (#|PCUICEnvironment.ind_projs idecl| >= - PCUICEnvironment.context_assumptions (cshape_args cs)). lia. + PCUICEnvironment.context_assumptions (cstr_args cdecl)). lia. clear on_projs_all. - induction (cshape_args cs) as [|[? [] ?] ?]. + induction (cstr_args cdecl) as [|[? [] ?] ?]. - simpl. constructor. - simpl. apply IHc. now simpl in H. - simpl. rewrite smash_context_acc /=. simpl. rewrite /subst_decl {2}/map_decl /=. rewrite /expand_lets_ctx {1}/map_decl /= /expand_lets_k_ctx. rewrite !lift_context_snoc /= subst_context_snoc /=; len. - rewrite !subst_context_snoc; len. + rewrite !subst_context_snoc. rewrite lift_context_snoc. constructor. apply IHc. simpl in H. lia. Qed. @@ -3576,36 +2806,37 @@ Proof. simpl. now f_equal. Qed. -From MetaCoq.PCUIC Require Import PCUICContextRelation. - Lemma projection_cumulative_indices {cf:checker_flags} {Σ : global_env_ext} (wfΣ : wf Σ.1) : forall {mdecl idecl p pdecl u u' }, - declared_projection Σ mdecl idecl p pdecl -> + declared_projection Σ p mdecl idecl pdecl -> on_udecl_prop Σ (ind_universes mdecl) -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef p.1.1) (ind_npars mdecl) u u' -> Σ ;;; projection_context mdecl idecl p.1.1 u |- - subst_instance_constr u pdecl.2 <= subst_instance_constr u' pdecl.2. + subst_instance u pdecl.2 <= subst_instance u' pdecl.2. Proof. intros * declp onudecl cu cu' Ru. - epose proof (declared_projection_constructor wfΣ declp) as [cdecl declc]. - destruct (on_declared_constructor wfΣ declc) as [_ [sort onc]]. + epose proof (declared_projection_constructor declp) as [cdecl declc]. + destruct (on_declared_constructor declc) as [_ [sort onc]]. destruct declc. simpl in d. pose proof (declared_inductive_unique d (let (x, _) := declp in x)). subst d. epose proof (declared_projection_type_and_eq wfΣ declp). - destruct (on_declared_projection wfΣ declp). + destruct (on_declared_projection declp). set (oib := declared_inductive_inv _ _ _ _) in *. simpl in X, y. - destruct ind_cshapes as [|[] []] eqn:cseq => //. - simpl in *. destruct y as [[[_ onps] onidx] onproj]. + destruct ind_ctors as [|? []] eqn:cstors => //. + destruct y as [[[H onps] onidx] onproj]. + simpl in *. + destruct ind_cunivs as [|? []] eqn:cseq => //. + simpl in *. destruct onc as [eqs onc]. noconf e. noconf eqs. simpl in X. destruct X as [_ [idecl' [[[idecl'nth _] pty] pty']]]. rewrite -pty. - destruct onc as [eqs onc]. rewrite cseq in eqs. noconf eqs. unfold R_global_instance in Ru. unfold global_variance, lookup_inductive, lookup_minductive in Ru. pose proof declp as declp'. - destruct declp' as [[? ?] ?]. red in H. rewrite H H0 in Ru. + 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. @@ -3613,7 +2844,7 @@ Proof. 2:{ rewrite app_context_nil_l context_assumptions_app in eq. eapply Nat.leb_nle in eq. - destruct onps. len in eq. + destruct onps. apply length_nil in on_projs_noidx. rewrite on_projs_noidx in eq. simpl in *. rewrite o.(onNpars) in eq. lia. } @@ -3623,18 +2854,21 @@ Proof. red in X. destruct variance_universes as [[[udecl i] i']|] eqn:vu => //. destruct X as [onctx _]. simpl in onctx. - eapply (All2_local_env_inst _ _ _ _ _ _ u u') in onctx; eauto. + eapply (All2_fold_inst _ _ _ _ _ _ u u') in onctx; eauto. 2:{ rewrite -eqv. - destruct (on_declared_projection wfΣ declp). + destruct (on_declared_projection declp). now apply (onVariance o). } - rewrite subst_instance_context_app in onctx. - epose proof (positive_cstr_closed_args (proj1 declp) o oib onc cu). rewrite eqv in X; simpl in X. + rewrite subst_instance_app_ctx in onctx. + have declc : declared_constructor Σ (p.1.1, 0) mdecl idecl cdecl. + { split; simpl; eauto. eapply declp. now rewrite cstors. } + epose proof (positive_cstr_closed_args declc cu). + rewrite eqv in X; simpl in X. specialize (X Ru). - rewrite - !(subst_instance_context_smash _ _ []) in X. + rewrite - !(subst_instance_smash _ _ []) in X. rewrite - !(expand_lets_smash_context _ []) in X. apply X in onctx. clear X. destruct onctx as [onctx wfctx]. - eapply context_relation_nth_ass in onctx. + eapply PCUICRedTypeIrrelevance.All2_fold_nth_ass in onctx. 2:{ rewrite nth_error_subst_context; len. simpl. rewrite nth_error_map nth_error_expand_lets. erewrite idecl'nth. simpl. reflexivity. } @@ -3642,51 +2876,54 @@ Proof. move:onctx => [decl' []]. destruct idecl' as [na [b|] ty]; simpl => //. intros Hd [[] Hd'']; discriminate. simpl. - rewrite nth_error_subst_context nth_error_map nth_error_expand_lets idecl'nth; len. + 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]. depelim Hty; simpl in *. rename c into Hty. - unfold PCUICTypingDef.cumul in Hty. + unfold PCUICConversionPar.cumul in Hty. move: Hty. - rewrite subst_instance_context_smash. len. simpl. + rewrite subst_instance_smash. len. simpl. epose proof (subslet_projs_smash _ _ _ _ wfΣ (let (x, _) := declp in x)). simpl in X. - rewrite cseq in X. + rewrite cstors in X. unfold projection_context. set (ind_decl := vass _ _). - specialize (X onps (smash_context [] (subst_instance_context u (ind_params mdecl)) ,, ind_decl) (tRel 0) u). + specialize (X onps (smash_context [] (subst_instance u (ind_params mdecl)) ,, ind_decl) (tRel 0) u). simpl in X. eapply untyped_subslet_skipn in X. rewrite skipn_lift_context in X. move => Hty. eapply (weakening_cumul _ _ _ [ind_decl]) in Hty; auto. - simpl in Hty. len in Hty. + simpl in Hty. eapply (substitution_untyped_cumul _ _ _ []) in Hty. 3:eapply X. 2:eauto. move: Hty; rewrite subst_context_nil /=. - rewrite skipn_length. len. simpl. lia. len. + rewrite skipn_length. len. simpl. len. rewrite /projection_type /=. fold (expand_lets_k (ind_params mdecl) p.2 ty). rewrite projs_inst_skipn. - assert (context_assumptions cshape_args - S (PCUICEnvironment.context_assumptions cshape_args - S p.2) = p.2) as -> by lia. + assert (context_assumptions (cstr_args cdecl) - + S (context_assumptions (cstr_args cdecl) - S p.2) = p.2) as -> by lia. clear X. - rewrite - subst_subst_instance_constr. - rewrite - (subst_subst_instance_constr u'). - rewrite - !subst_subst_instance_constr subst_instance_constr_projs. - rewrite !subst_subst_instance_constr. + rewrite subst_instance_subst. + rewrite (subst_instance_subst u'). + rewrite !subst_instance_subst [subst_instance _ (projs _ _ _)]subst_instance_projs. + rewrite - !subst_instance_subst. fold (expand_lets_k (ind_params mdecl) p.2 ty). - rewrite commut_lift_subst_rec. lia. - rewrite commut_lift_subst_rec. lia. + rewrite commut_lift_subst_rec => /lens. + rewrite commut_lift_subst_rec => /lens. rewrite distr_subst projs_subst_above. lia. - rewrite [map _ (inds _ _ _)](instantiate_inds _ u _ mdecl wfΣ (proj1 (proj1 declp)) cu). - rewrite - subst_subst_instance_constr. - rewrite [map _ (inds _ _ _)](instantiate_inds _ u' _ mdecl wfΣ (proj1 (proj1 declp)) cu'). - rewrite - subst_subst_instance_constr subst_instance_constr_projs. + rewrite (instantiate_inds _ u _ mdecl wfΣ (proj1 (proj1 declp)) cu). + rewrite subst_instance_subst. + rewrite (instantiate_inds _ u' _ mdecl wfΣ (proj1 (proj1 declp)) cu'). + rewrite subst_instance_subst. + rewrite ![subst_instance _ (projs _ _ _)]subst_instance_projs. rewrite distr_subst projs_subst_above. lia. rewrite projs_length !Nat.add_succ_r Nat.add_0_r /= //. - rewrite !lift_subst_instance_constr // projs_inst_0 //. - rewrite o.(onNpars) //. } + rewrite !subst_instance_lift // projs_inst_0 //. + rewrite o.(onNpars) //. } { simpl in Ru. constructor. eapply eq_term_leq_term. - eapply eq_term_upto_univ_subst_instance_constr; eauto. all:typeclasses eauto. + eapply eq_term_upto_univ_subst_instance; eauto. all:typeclasses eauto. } Qed. @@ -3708,44 +2945,121 @@ Proof. now rewrite declmi. } split; auto. simpl. rewrite H. - pose proof decli as decli'. - eapply on_declared_inductive in decli' as [onmi oni]; auto. + destruct (on_declared_inductive decli) as [onmi oni]; auto. rewrite oni.(ind_arity_eq) in Hargs |- *. rewrite !destArity_it_mkProd_or_LetIn. simpl. rewrite app_context_nil_l. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in Hargs. + rewrite !subst_instance_it_mkProd_or_LetIn in Hargs. rewrite -it_mkProd_or_LetIn_app in Hargs. eapply arity_typing_spine in Hargs; auto. destruct Hargs as [[Hl Hleq] ?]. rewrite Hl. - len. now rewrite context_assumptions_app Nat.leb_refl. + len. now rewrite Nat.leb_refl. eapply weaken_wf_local; auto. - rewrite -[_ ++ _]subst_instance_context_app. + rewrite -[_ ++ _]subst_instance_app_ctx. eapply on_minductive_wf_params_indices_inst; eauto with pcuic. Qed. -Lemma spine_subst_app {cf:checker_flags} Σ Γ Δ Δ' inst inst' insts : - wf Σ.1 -> - #|inst| = context_assumptions Δ -> - wf_local Σ (Γ ,,, Δ ,,, Δ') -> - spine_subst Σ Γ inst (skipn #|Δ'| insts) Δ * - spine_subst Σ Γ inst' (firstn #|Δ'| insts) (subst_context (skipn #|Δ'| insts) 0 Δ') -> - spine_subst Σ Γ (inst ++ inst') insts (Δ ,,, Δ'). +Lemma invert_cumul_ind_ind {cf} {Σ} {wfΣ : wf Σ} {Γ ind ind' u u' args args'} : + Σ ;;; Γ |- mkApps (tInd ind u) args <= mkApps (tInd ind' u') args' -> + (Reflect.eqb ind ind' * PCUICEquality.R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) #|args| u u' * + All2 (conv Σ Γ) args args'). Proof. - intros wfΣ len wf [[wfdom wfcodom cs subst] [wfdom' wfcodom' cs' subst']]. - split; auto. - now rewrite app_context_assoc. - eapply context_subst_app_inv; split; auto. - rewrite skipn_all_app_eq; try lia. auto. - rewrite (firstn_app_left _ 0) ?Nat.add_0_r // firstn_0 // app_nil_r //. - rewrite -(firstn_skipn #|Δ'| insts). - eapply subslet_app; auto. + intros ht; eapply invert_cumul_ind_l in ht as (? & ? & ? & ? & ?); auto. + eapply red_mkApps_tInd in r as (? & ? & ?); auto. solve_discr. + intuition auto. eapply eq_inductive_refl. + transitivity x0; auto. symmetry. now eapply red_terms_conv_terms. Qed. -Lemma context_assumptions_lift {n k Γ} : context_assumptions (lift_context n k Γ) = context_assumptions Γ. -Proof. apply context_assumptions_fold. Qed. -Lemma context_assumptions_subst {n k Γ} : context_assumptions (subst_context n k Γ) = context_assumptions Γ. -Proof. apply context_assumptions_fold. Qed. -Hint Rewrite @context_assumptions_lift @context_assumptions_subst : len. +Lemma ctx_inst_app_weak `{checker_flags} Σ (wfΣ : wf Σ.1) ind mdecl idecl (isdecl : declared_inductive Σ.1 ind mdecl idecl)Γ (wfΓ : wf_local Σ Γ) params args u v: + isType Σ Γ (mkApps (tInd ind u) args) -> + 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) + (List.rev (subst_instance v (ind_params mdecl ,,, ind_indices idecl))). +Proof. + intros [? ty_args] ? cparams cum. + pose proof (wt_ind_app_variance _ (x; ty_args)) as [mdecl' [idecl' gv]]. + rewrite (declared_inductive_lookup_inductive isdecl) in idecl'. noconf idecl'. + eapply invert_type_mkApps_ind in ty_args as [ty_args ?] ; eauto. + erewrite ind_arity_eq in ty_args. + 2: eapply PCUICInductives.oib ; eauto. + + assert (#|args| = ind_npars mdecl + context_assumptions (ind_indices idecl)). + { + repeat rewrite PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn in ty_args. + rewrite -it_mkProd_or_LetIn_app in ty_args. + apply arity_typing_spine in ty_args as ((eq&_)&_) ; auto. + 2:{ apply PCUICWeakening.weaken_wf_local ; eauto. + rewrite -/app_context -PCUICUnivSubstitution.subst_instance_app. + eapply on_minductive_wf_params_indices_inst ; eauto. + } + rewrite context_assumptions_app !context_assumptions_subst_instance in eq. + erewrite declared_minductive_ind_npars. + 2: eapply declared_inductive_minductive ; eauto. + lia. + } + + assert (cindices : ctx_inst Σ Γ (skipn (ind_npars mdecl) args) (subst_telescope (ctx_inst_sub cparams) 0 + (List.rev (subst_instance v (ind_indices idecl))))). + { + rewrite PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn in ty_args. + erewrite <- (firstn_skipn _ args) in ty_args. + apply typing_spine_ctx_inst in ty_args as (cparargs&?&ty_indices) ; auto. + 2:{ rewrite firstn_length_le. + 2:{ rewrite context_assumptions_subst_instance. + symmetry. + eapply PCUICDeclarationTyping.onNpars. + eapply on_declared_inductive ; eauto. + } + lia. + } + 2:{ rewrite <- PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn. + erewrite <- ind_arity_eq. + 2: eapply PCUICInductives.oib ; eauto. + eapply declared_inductive_valid_type ; eauto. + } + + 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. + eapply All2_app_inv in conv as [convpars _]. + 2:{ apply ctx_inst_length in cparams. + rewrite context_assumptions_rev in cparams. len in cparams. + rewrite List.firstn_length. lia. } + unshelve epose proof (inductive_cumulative_indices _ isdecl _ c H0 Ruv Γ). + { eapply (weaken_lookup_on_global_env' _ _ (InductiveDecl mdecl) _ (proj1 isdecl)). } + specialize (X (firstn (ind_npars mdecl) args) params). + unshelve epose proof (ctx_inst_spine_subst _ cparams); tea. + { eapply weaken_wf_local; tea. eapply (on_minductive_wf_params isdecl); tea. } + unshelve epose proof (ctx_inst_spine_subst _ cparargs); tea. + { eapply weaken_wf_local; tea. eapply (on_minductive_wf_params isdecl); tea. } + specialize (X _ _ X1 X0 convpars). simpl in X. + rewrite subst_telescope_subst_context. + eapply ctx_inst_smash. + rewrite subst_instance_it_mkProd_or_LetIn in ty_indices. + rewrite subst_it_mkProd_or_LetIn in ty_indices. + rewrite -(app_nil_r (skipn (ind_npars mdecl) args)) in ty_indices. + eapply typing_spine_ctx_inst in ty_indices as [argsi [isty sp]]; tea. + - eapply ctx_inst_cumul; tea. + apply (ctx_inst_smash.1 argsi). + { apply wf_local_app_inv. apply wf_local_smash_end; tea. + eapply substitution_wf_local; tea. eapply X1. + rewrite -app_context_assoc -subst_instance_app_ctx. + eapply weaken_wf_local; tea. + eapply (on_minductive_wf_params_indices_inst isdecl _ c). } + { apply wf_local_app_inv. apply wf_local_smash_end; tea. + eapply substitution_wf_local; tea. eapply X0. + rewrite -app_context_assoc -subst_instance_app_ctx. + eapply weaken_wf_local; tea. + eapply (on_minductive_wf_params_indices_inst isdecl _ H0). } + - len. rewrite List.skipn_length. lia. + - simpl. now rewrite subst_instance_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn in i. + } + + rewrite subst_instance_app_ctx List.rev_app_distr. + now eapply (ctx_inst_app cparams). +Qed. Lemma wf_local_vass {cf:checker_flags} Σ {Γ na A} s : Σ ;;; Γ |- A : tSort s -> wf_local Σ (Γ ,, vass na A). @@ -3786,111 +3100,72 @@ Proof. econstructor; eauto. Qed. -Lemma WfArity_build_case_predicate_type {cf:checker_flags} Σ - Γ ind u args mdecl idecl ps pty : +Lemma wf_set_binder_name {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {nas Δ} : + All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ -> + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, map2 set_binder_name nas Δ). +Proof. + intros ha wf. + apply wf_local_app_inv in wf as []. + eapply wf_local_app => //. + induction w in nas, ha |- *; depelim ha; cbn. constructor. + - constructor; eauto. apply IHw; auto. + destruct t0 as [s Hs]. exists s. + eapply context_conversion; tea. + eapply wf_local_app, IHw; eauto. + eapply eq_binder_annots_eq_ctx in ha. + eapply eq_context_upto_univ_conv_context. + eapply eq_context_upto_cat. + reflexivity. symmetry. apply ha. + - constructor; eauto. apply IHw; auto. + destruct t0 as [s Hs]. exists s. + eapply context_conversion; tea. + eapply wf_local_app, IHw; eauto. + eapply eq_binder_annots_eq_ctx in ha. + eapply eq_context_upto_univ_conv_context. + eapply eq_context_upto_cat. + reflexivity. symmetry. apply ha. + red. red in t1. + eapply context_conversion; tea. + eapply wf_local_app, IHw; eauto. + eapply eq_binder_annots_eq_ctx in ha. + eapply eq_context_upto_univ_conv_context. + eapply eq_context_upto_cat. + reflexivity. symmetry. apply ha. +Qed. + +Lemma WfArity_build_case_predicate_type {cf:checker_flags} {Σ Γ ci args mdecl idecl p ps} : wf Σ.1 -> - declared_inductive Σ.1 mdecl ind idecl -> - isType Σ Γ (mkApps (tInd ind u) args) -> + declared_inductive Σ.1 ci.(ci_ind) mdecl idecl -> + isType Σ Γ (mkApps (tInd ci p.(puinst)) (pparams p ++ args)) -> let params := firstn (ind_npars mdecl) args in wf_universe Σ ps -> - build_case_predicate_type ind mdecl idecl params u ps = Some pty -> - isWfArity Σ Γ pty. -Proof. - intros wfΣ isdecl X params wfps XX. unfold build_case_predicate_type in XX. - case_eq (instantiate_params - (subst_instance_context u (ind_params mdecl)) - params (subst_instance_constr u (ind_type idecl))); - [|intro e; rewrite e in XX; discriminate]. - intros ipars Hipars; rewrite Hipars in XX. cbn -[it_mkProd_or_LetIn] in XX. - case_eq (destArity [] ipars); - [|intro e; rewrite e in XX; discriminate]. - intros [ictx iu] Hictxs; rewrite Hictxs in XX; apply some_inj in XX. - subst pty. cbn -[it_mkProd_or_LetIn]. + wf_predicate mdecl idecl p -> + isWfArity Σ Γ (it_mkProd_or_LetIn (case_predicate_context ci mdecl idecl p) (tSort ps)). +Proof. + intros wfΣ isdecl X params wfps wfp. split. 2:{ eexists _, _. rewrite destArity_it_mkProd_or_LetIn. reflexivity. } + rewrite /case_predicate_context /case_predicate_context_gen. + have wfΓ := typing_wf_local X.π2. + eapply isType_mkApps_Ind_inv in X; tea. + destruct X as [parsubst [argsubst [[sppars spargs] cu]]]. + epose proof (isType_case_predicate (puinst p) (pparams p) ps wfΓ isdecl cu wfps). + rewrite (firstn_app_left _ 0) /= ?app_nil_r in sppars. + now rewrite (wf_predicate_length_pars wfp). + eapply spine_subst_smash in sppars;tea. specialize (X sppars). eapply isType_it_mkProd_or_LetIn; eauto. eapply isType_Sort; auto. - simpl. eapply wf_local_vass. - assert (wfΓ : wf_local Σ Γ). { destruct X as [s Hs]; pcuic. } - move:Hipars. - rewrite instantiate_params_. - destruct instantiate_params_subst as [[parsubst ty]|] eqn:ip => // => [= eqip]. - subst ipars. - pose proof (PCUICWeakeningEnv.on_declared_inductive wfΣ isdecl) as [onind oib]. - rewrite oib.(ind_arity_eq) in ip. - eapply PCUICSubstitution.instantiate_params_subst_make_context_subst in ip as - [ctx' [mparsubst dp]]. - rewrite subst_instance_constr_it_mkProd_or_LetIn in dp. - rewrite List.rev_length in dp. - rewrite decompose_prod_n_assum_it_mkProd in dp. noconf dp. - rewrite subst_instance_constr_it_mkProd_or_LetIn PCUICSubstitution.subst_it_mkProd_or_LetIn in Hictxs. - rewrite destArity_it_mkProd_or_LetIn /= app_context_nil_l in Hictxs. noconf Hictxs. - destruct X as [s Hs]. - eapply invert_type_mkApps_ind in Hs as [spargs cu]; eauto. - rewrite oib.(ind_arity_eq) in spargs. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in spargs. - rewrite -it_mkProd_or_LetIn_app in spargs. - eapply arity_typing_spine in spargs as [[lenargs leqs] [instsubst spsubst]]; auto. - 2:{ eapply weaken_wf_local; pcuic. rewrite -[_ ++ _]subst_instance_context_app. - eapply on_minductive_wf_params_indices_inst; eauto. } - have onp := onind.(onNpars). len in lenargs. - eapply make_context_subst_spec in mparsubst. rewrite List.rev_involutive in mparsubst. - rewrite -(firstn_skipn (ind_npars mdecl) args) in spsubst. - eapply spine_subst_app_inv in spsubst as [sppars spargs]; auto. - 2:{ len. rewrite firstn_length_le; lia. } - pose proof (PCUICContexts.context_subst_fun mparsubst sppars). subst parsubst. - len in sppars; len in spargs. len. - set (parsubst := skipn #|ind_indices oib| instsubst) in *. - eapply type_mkApps; eauto. - * econstructor; eauto. len. - eapply spargs. - * rewrite oib.(ind_arity_eq). cbn. instantiate (1 := iu). len. - rewrite -it_mkProd_or_LetIn_app. - rewrite subst_instance_constr_it_mkProd_or_LetIn. - eapply typing_spine_it_mkProd_or_LetIn_close'; eauto. - rewrite subst_instance_context_app. - eapply (spine_subst_weakening _ _ _ _ _ (subst_context _ 0 (subst_instance_context u (ind_indices oib)))) in sppars; eauto. - len in sppars. - 2:{ eapply spargs. } - eapply spine_subst_app; eauto. 3:split. - + rewrite /params; len. rewrite firstn_length_le; lia. - + rewrite -app_context_assoc. - eapply weaken_wf_local; eauto. len in spargs. eapply spargs. - rewrite -subst_instance_context_app. - eapply on_minductive_wf_params_indices_inst; eauto. - + len. rewrite map_skipn in sppars. - rewrite closed_ctx_lift in sppars. - eapply PCUICClosed.closed_wf_local; eauto. - eapply on_minductive_wf_params; pcuic. eapply isdecl. - instantiate (1 := all_rels (subst_context parsubst 0 (subst_instance_context u (ind_indices oib))) 0 - #|_| ++ - map (lift0 #|ind_indices oib|) (skipn #|ind_indices oib| instsubst)). - rewrite skipn_all_app_eq; len => //. - rewrite map_skipn. eapply sppars. - + rewrite firstn_app; len. rewrite Nat.sub_diag [firstn 0 _]firstn_0 /= // app_nil_r. - rewrite -> firstn_all2 by (len; lia). - rewrite skipn_all_app_eq; len => //. - relativize (subst_context (map _ _) _ _). - eapply spine_subst_to_extended_list_k; eauto. - eapply spargs. - len. rewrite subst_map_lift_lift_context. - fold parsubst. move: (context_subst_length sppars); len => <-. - epose proof (on_minductive_wf_params_indices_inst _ _ _ _ _ wfΣ (proj1 isdecl) oib cu). - eapply PCUICClosed.closed_wf_local in X; auto. move: X. - now rewrite subst_instance_context_app PCUICClosed.closedn_ctx_app /=; len => /andb_and [_ H]. - rewrite lift_context_subst_context //. - + eapply isType_weakening; eauto. - eapply spargs. - move: (f_equal (subst_instance_constr u) oib.(ind_arity_eq)). - rewrite -it_mkProd_or_LetIn_app subst_instance_constr_it_mkProd_or_LetIn => <-. - eapply declared_inductive_valid_type; eauto. + eapply wf_set_binder_name. + now eapply wf_pre_case_predicate_context_gen. + now eapply isType_it_mkProd_or_LetIn_wf_local in X. Qed. (* 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.(cshape_sort) then IntoAny else IntoPropSProp). + allowed_eliminations_subset f (if is_propositional cs.(cdecl_sort) then IntoAny else IntoPropSProp). Proof. destruct shapes as [|? []]; simpl. - rewrite nth_error_nil => //. @@ -3906,305 +3181,1257 @@ Proof. intros ->; constructor. Qed. -Lemma build_branches_type_wt {cf : checker_flags} (Σ : global_env × universes_decl) Γ ind mdecl idecl u - (c p pty : term) pctx ps (args : list term) (btys : list (nat × term)) : - wf Σ.1 -> - declared_inductive Σ.1 mdecl ind idecl -> - Σ ;;; Γ |- c : mkApps (tInd ind u) args -> - destArity [] pty = Some (pctx, ps) -> - build_case_predicate_type ind mdecl idecl (firstn (ind_npars mdecl) args) u ps = Some pty -> - Σ;;; Γ |- p : pty -> - is_allowed_elimination (global_ext_constraints Σ) ps (ind_kelim idecl) -> - map_option_out (build_branches_type ind mdecl idecl (firstn (ind_npars mdecl) args) u p) = Some btys -> - All (fun bty : nat × term => isType Σ Γ bty.2) btys. -Proof. - intros wfΣ decli Hc da bc Hp lebs Hb. - eapply forall_nth_error_All. - intros n [narg brty] nth. - eapply nth_branches_type in Hb as [br [Hbth Hbr]]; eauto. - simpl. - assert (declared_constructor Σ.1 mdecl idecl (ind, n) br). +Lemma forall_nth_error_All2i : + forall {A B} (P : nat -> A -> B -> Type) k l l', + #|l| = #|l'| -> + (forall i x y, nth_error l i = Some x -> nth_error l' i = Some y -> P (k + i) x y) -> + All2i P k l l'. +Proof. + intros A B P k l l' eq h. + induction l in k, eq, h, l' |- *. + - destruct l' => //. constructor. + - destruct l' => //. constructor. + + specialize (h 0 a b eq_refl eq_refl). now rewrite Nat.add_0_r in h. + + apply IHl. simpl in eq; lia. intros. specialize (h (S i) x y H H0). + simpl. now replace (S (k + i)) with (k + S i) by lia. +Qed. + +Definition ind_binder ind idecl p := + let indty := + mkApps (tInd ind p.(puinst)) + (map (lift0 #|ind_indices idecl|) p.(pparams) ++ to_extended_list (ind_indices idecl)) in + {| decl_name := {| + binder_name := nNamed (ind_name idecl); + binder_relevance := ind_relevance idecl |}; + decl_body := None; + decl_type := indty |}. + +Definition case_predicate_context' ind mdecl idecl p := + ind_binder ind idecl p :: subst_context (List.rev p.(pparams)) 0 + (subst_instance p.(puinst) + (expand_lets_ctx (ind_params mdecl) (ind_indices idecl))). + +Lemma case_predicate_context_alpha {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} + {ind mdecl idecl p} : + All2 (fun x y => eq_binder_annot x y.(decl_name)) + (forget_types (pcontext p)) (ind_binder ind idecl p :: ind_indices idecl) -> + All2 (compare_decls eq eq) (case_predicate_context' ind mdecl idecl p) + (case_predicate_context ind mdecl idecl p). +Proof. + rewrite /case_predicate_context /case_predicate_context_gen /case_predicate_context'. + rewrite /pre_case_predicate_context_gen. + fold (ind_binder ind idecl p). + intros a; depelim a. + destruct (pcontext p) eqn:pctx => //. simpl. + constructor. + { constructor. red. simpl. simpl in e. red in e. simpl in e. + rewrite -e. simpl in H. noconf H. reflexivity. + simpl. reflexivity. } + eapply All2_symP. intros ? ? []; constructor; auto; now symmetry. + eapply All2_map2_left_All3. + simpl in H. noconf H. + revert a. move: (map _ l0) => l a. + induction a. constructor. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + rewrite !lift_context_snoc /=. + rewrite subst_context_snoc /= subst_instance_cons subst_context_snoc. + constructor; auto. + destruct y as [na [b|] ty]; constructor; simpl; auto; reflexivity. +Qed. + +Notation "x → y" := (x -> y) (at level 99, right associativity, y at level 200). + +Lemma subslet_eq_context_alpha {cf} {Σ Γ s Δ Δ'} : + All2 (compare_decls eq eq) Δ Δ' → + subslet Σ Γ s Δ → + subslet Σ Γ s Δ'. +Proof. + intros eq subs. + induction subs in Δ', eq |- *; depelim eq; try constructor. + * depelim c; constructor; auto. now subst. + * depelim c; subst; constructor; auto. +Qed. + +Lemma eq_context_alpha_conv {cf} {Σ} {Γ Γ'} : + All2 (compare_decls eq eq) Γ Γ' -> conv_context Σ Γ Γ'. +Proof. + intros a. + eapply eq_context_upto_empty_conv_context. + eapply All2_fold_All2. + eapply (All2_impl a). + intros ?? []; constructor; subst; auto; reflexivity. +Qed. + +Lemma wf_local_alpha {cf} {Σ} {wfΣ : wf Σ} Γ Γ' : All2 (compare_decls eq eq) Γ Γ' -> + wf_local Σ Γ -> + wf_local Σ Γ'. +Proof. + induction 1; intros h; depelim h; try constructor; auto. + all:depelim r; constructor; subst; auto. + exists l0.π1. eapply context_conversion; eauto. + eapply l0.π2. + now apply eq_context_alpha_conv. + exists l0.π1. eapply context_conversion; eauto. + eapply l0.π2. + now apply eq_context_alpha_conv. + eapply context_conversion; eauto. + now apply eq_context_alpha_conv. +Qed. + +Lemma subslet_eq_context_alpha_dom {cf} {Σ} {wfΣ : wf Σ} {Γ Γ' s Δ} : + All2 (compare_decls eq eq) Γ Γ' → + subslet Σ Γ s Δ → + subslet Σ Γ' s Δ. +Proof. + intros eq subs. + induction subs in Γ', eq |- *; try constructor. + * 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. + * now eapply IHsubs. + * eapply context_conversion; tea. + eapply wf_local_alpha; tea. eapply typing_wf_local in t0. exact t0. + now eapply eq_context_alpha_conv. +Qed. + +Lemma alpha_eq_context_assumptions Δ Δ' : + All2 (compare_decls eq eq) Δ Δ' → + context_assumptions Δ = context_assumptions Δ'. +Proof. + induction 1; simpl; auto; try lia. + destruct r; simpl; auto; lia. +Qed. + +Lemma alpha_eq_extended_subst Δ Δ' k : + All2 (compare_decls eq eq) Δ Δ' → + extended_subst Δ k = extended_subst Δ' k. +Proof. + induction 1 in k |- *; simpl; auto. + destruct r; subst; simpl; auto. f_equal. apply IHX. + rewrite IHX (alpha_eq_context_assumptions l l') //. +Qed. + +Lemma alpha_eq_smash_context Δ Δ' : + All2 (compare_decls eq eq) Δ Δ' → + All2 (compare_decls eq eq) (smash_context [] Δ) (smash_context [] Δ'). +Proof. + induction 1. + * constructor. + * destruct x; depelim r; simpl; auto. + rewrite !(smash_context_acc _ [_]). + eapply All2_app; auto; repeat constructor; subst; simpl; auto. + 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 Δ Δ' : + All2 (compare_decls eq eq) Δ Δ' → + All2 (compare_decls eq eq) (lift_context n k Δ) (lift_context n k Δ'). +Proof. + induction 1. + * constructor. + * rewrite !lift_context_snoc; destruct x; depelim r; simpl; subst; auto; + constructor; auto; repeat constructor; subst; simpl; auto; + now rewrite (All2_length X). +Qed. + +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. + induction 1. + * constructor. + * rewrite !subst_context_snoc; destruct x; depelim r; simpl; subst; auto; + constructor; auto; repeat constructor; subst; simpl; auto; + now rewrite (All2_length X). +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. +Proof. + move/declared_inductive_type. + rewrite /idecl_binder => ->. + rewrite /ind_binder. *) + +Lemma expand_lets_ctx_tip Γ d : expand_lets_ctx Γ [d] = [map_decl (expand_lets Γ) d]. +Proof. rewrite /expand_lets_ctx /expand_lets_k_ctx /expand_lets /expand_lets_k. + simpl. rewrite (lift_context_app _ _ [] [_]) /= (subst_context_app _ _ [] [_]) /=. + f_equal. + now rewrite compose_map_decl. +Qed. + +Definition subst_let_expand_k args Δ k T := + (subst args k (expand_lets_k Δ k T)). + +Lemma map_subst_let_expand_k args Δ k l : + map (subst args k) (map (expand_lets_k Δ k) l) = + map (subst_let_expand_k args Δ k) l. +Proof. + now rewrite map_map_compose. +Qed. + +Lemma isType_mkApps_Ind_smash {cf:checker_flags} {Σ Γ ind u params args} {wfΣ : wf Σ} {mdecl idecl} : + declared_inductive Σ.1 ind mdecl idecl -> + isType Σ Γ (mkApps (tInd ind u) (params ++ args)) -> + #|params| = ind_npars mdecl -> + let parctx := subst_instance u mdecl.(ind_params) in + let argctx := subst_instance u idecl.(ind_indices) in + spine_subst Σ Γ params (List.rev params) (smash_context [] parctx) × + spine_subst Σ Γ args (List.rev args) (smash_context [] (subst_context_let_expand (List.rev params) parctx argctx)) × + consistent_instance_ext Σ (ind_universes mdecl) u. +Proof. + move=> isdecl isty hpars. + pose proof (isType_wf_local isty). + destruct isty as [s Hs]. + eapply invert_type_mkApps_ind in Hs as [sp cu]; tea. + move=> parctx argctx. + erewrite ind_arity_eq in sp. + 2: eapply PCUICInductives.oib ; eauto. + rewrite !subst_instance_it_mkProd_or_LetIn in sp. + rewrite -it_mkProd_or_LetIn_app /= in sp. + eapply arity_typing_spine in sp as [[hle hs] [insts sp]]; tea. + 2:{ rewrite -subst_instance_app. eapply weaken_wf_local => //. + now eapply (on_minductive_wf_params_indices_inst). } + eapply spine_subst_smash in sp; tea. + rewrite smash_context_app_expand in sp. + rewrite List.rev_app_distr in sp. + pose proof (declared_minductive_ind_npars isdecl) as hnpars. + eapply spine_subst_app_inv in sp as [sppars spargs]; tea. + 2:{ rewrite context_assumptions_smash_context /=. len. } + len in sppars. len in hle. len in spargs. + simpl in *. + assert (context_assumptions (ind_indices idecl) = #|List.rev args|) by (len; lia). + rewrite H skipn_all_app in sppars, spargs. + split => //. split => //. + rewrite -(Nat.add_0_r #|List.rev args|) firstn_app_2 firstn_0 // app_nil_r in spargs. + rewrite (smash_context_subst []). + rewrite -(expand_lets_smash_context _ []). + exact spargs. +Qed. + +Lemma subst_let_expand_it_mkProd_or_LetIn s Γ Δ T : + subst_let_expand s Γ (it_mkProd_or_LetIn Δ T) = + it_mkProd_or_LetIn (subst_context_let_expand s Γ Δ) (subst_let_expand_k s Γ #|Δ| T). +Proof. + rewrite /subst_let_expand /expand_lets. + rewrite expand_lets_it_mkProd_or_LetIn /= subst_it_mkProd_or_LetIn /=. + len. +Qed. + +Lemma subst_let_expand_k_mkApps s Γ k f args : + subst_let_expand_k s Γ k (mkApps f args) = + mkApps (subst_let_expand_k s Γ k f) (map (subst_let_expand_k s Γ k) args). +Proof. + rewrite /subst_let_expand_k. + now rewrite expand_lets_k_mkApps subst_mkApps map_map_compose. +Qed. + +Lemma to_extended_list_k_map_lift: + forall (n k : nat) (c : context), + to_extended_list_k c k = map (lift n (#|c| + k)) (to_extended_list_k c k). +Proof. + intros n k c. + pose proof (to_extended_list_k_spec c k). unf_term. + symmetry. solve_all. + destruct H as [x' [-> Hx]]. simpl. + destruct (leb_spec_Set (#|c| + k) x'). + - f_equal. lia. + - reflexivity. +Qed. + +Lemma expand_lets_k_to_extended_list_k Γ k : + map (expand_lets_k Γ k) (to_extended_list_k Γ k) = to_extended_list_k (smash_context [] Γ) k. +Proof. + rewrite /expand_lets_k -map_map_compose. + rewrite -extended_subst_to_extended_list_k. + f_equal. now rewrite Nat.add_comm -to_extended_list_k_map_lift. +Qed. + +Lemma map_subst_let_expand_k_to_extended_list_lift {cf} {Σ s Γ Δ k} : + spine_subst Σ Γ s (List.rev s) (smash_context [] Δ) -> + map (subst_let_expand_k (List.rev s) Δ k) (to_extended_list_k Δ k) = map (lift0 k) s. +Proof. + intros sp. + eapply spine_subst_subst_to_extended_list_k in sp. + rewrite /subst_let_expand_k. + rewrite -map_map_compose. + rewrite expand_lets_k_to_extended_list_k. + rewrite -{2}(Nat.add_0_r k). + rewrite PCUICLiftSubst.lift_to_extended_list_k -{2}sp !map_map_compose. + apply map_ext. intros x. + now rewrite commut_lift_subst_rec. +Qed. + +Lemma map_subst_let_expand_to_extended_list {cf} {Σ s Γ Δ} : + spine_subst Σ Γ s (List.rev s) (smash_context [] Δ) -> + map (subst_let_expand (List.rev s) Δ) (to_extended_list Δ) = s. +Proof. + intros sp. + specialize (map_subst_let_expand_k_to_extended_list_lift (k:=0) sp). + now rewrite map_lift0. +Qed. + +Lemma map_subst_let_expand_lift {s Γ k s'} : + #|s| = context_assumptions Γ -> k = #|Γ| -> + map (subst_let_expand s Γ) (map (lift0 k) s') = s'. +Proof. + intros hs hlen. + rewrite /subst_let_expand map_map_compose. + rewrite -{2}(map_id s'). apply map_ext => t. + rewrite /expand_lets /expand_lets_k /=. + sigma. rewrite hlen. + rewrite -subst_compose_assoc. + rewrite shiftn_Upn. sigma. + rewrite subst_consn_shiftn. 2:now len. + now rewrite subst_consn_shiftn; sigma. +Qed. + +Lemma subst_let_expand_k_0 s Γ : + subst_let_expand_k s Γ 0 =1 subst_let_expand s Γ. +Proof. reflexivity. Qed. + +Lemma subst_let_expand_k_lift s Γ n k t : + n = #|Γ| -> #|s| = context_assumptions Γ -> + subst_let_expand_k s Γ 0 (lift0 (n + k) t) = lift0 k t. +Proof. + intros. + rewrite -(simpl_lift _ _ _ _ 0); try lia. + rewrite subst_let_expand_k_0. + rewrite subst_let_expand_lift_id //. +Qed. + +Lemma expand_lets_k_0 Γ t : expand_lets_k Γ 0 t = expand_lets Γ t. +Proof. reflexivity. Qed. + +Lemma extended_subst_lift_context n (Γ : context) (k k' : nat) : + extended_subst (lift_context n k Γ) k' = + map (lift n (k + context_assumptions Γ + k')) (extended_subst Γ k'). +Proof. + pose proof (PCUICRename.rename_extended_subst). + rewrite -rename_context_lift_context. + rewrite lift_extended_subst -H. + rewrite (lift_extended_subst _ k'). + rewrite !map_map_compose. apply map_ext => t. + rewrite shiftn_lift_renaming; sigma. + apply inst_ext. + rewrite - !Upn_Upn (Nat.add_comm _ k') !Upn_Upn shiftn_Upn - !Upn_Upn. + move=> i; lia_f_equal. +Qed. + +Lemma subst_context_lift_context (n : nat) (Γ Δ : context) : + subst_context (extended_subst (lift_context n 0 Γ) 0) 0 (lift_context n (#|Γ| + context_assumptions Γ) Δ) = + lift_context n (context_assumptions Γ) (subst_context (extended_subst Γ 0) 0 Δ). +Proof. + rewrite {1}extended_subst_lift_context /= Nat.add_0_r. + now rewrite distr_lift_subst_context; len. +Qed. + +From MetaCoq.PCUIC Require Import PCUICRename. + +Lemma lift_context_lift_context n k k' Γ : + lift_context n (k + k') (lift_context k' k Γ) = lift_context (n + k') k Γ. +Proof. + rewrite - !rename_context_lift_context. + rewrite /PCUICRename.rename_context fold_context_k_compose. + apply fold_context_k_ext => i x. + rewrite !rename_inst !shiftn_lift_renaming !ren_lift_renaming. + sigma. apply inst_ext. + now rewrite Upn_compose Upn_compose shiftn_Upn shiftk_compose. +Qed. + +Lemma lift_context_subst_context_let_expand n s Γ Δ : + #|s| = context_assumptions Γ -> + lift_context n 0 (subst_context_let_expand s Γ Δ) = + subst_context_let_expand (map (lift0 n) s) (lift_context n 0 Γ) (lift_context n #|Γ| Δ). +Proof. + intros hlen. + rewrite /subst_context_let_expand. + rewrite distr_lift_subst_context. f_equal. + rewrite Nat.add_0_r hlen. + rewrite /expand_lets_ctx /expand_lets_k_ctx /=; autorewrite with len. + rewrite -lift_context_add Nat.add_comm lift_context_add. + rewrite -subst_context_lift_context. + rewrite -lift_context_add. + now rewrite lift_context_lift_context. +Qed. + +Lemma smash_context_app_expand_acc Γ Δ : + smash_context [] Γ ,,, expand_lets_ctx Γ Δ = + smash_context Δ Γ. +Proof. + rewrite (smash_context_acc Γ Δ). reflexivity. +Qed. + +Lemma expand_lets_ctx_app Δ Γ Γ' : + expand_lets_ctx Δ (Γ ,,, Γ') = expand_lets_ctx Δ Γ ,,, expand_lets_k_ctx Δ #|Γ| Γ'. +Proof. + rewrite /expand_lets_ctx /expand_lets_k_ctx lift_context_app subst_context_app; len => //. +Qed. + +Lemma lift_context_subst Γ p s n k : + context_subst Γ p s -> + context_subst (lift_context n k Γ) (map (lift n k) p) (map (lift n k) s). +Proof. + induction 1 in |- *; try constructor. + rewrite lift_context_snoc map_app /=; constructor; auto. + rewrite lift_context_snoc /= /lift_decl /map_decl /=. + rewrite (context_subst_length X). + rewrite distr_lift_subst. + now constructor. +Qed. + +Lemma subst_context_subst Γ p s sub k : + context_subst Γ p s -> + context_subst (subst_context sub k Γ) (map (subst sub k) p) (map (subst sub k) s). +Proof. + induction 1 in |- *; try constructor. + rewrite subst_context_snoc map_app /=; constructor; auto. + rewrite subst_context_snoc /= /subst_decl /map_decl /=. + rewrite (context_subst_length X). + rewrite distr_subst. + now constructor. +Qed. + +Lemma typing_expand_lets_gen {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Γ' t T} : + Σ ;;; Γ ,,, Δ ,,, Γ' |- t : T -> + Σ ;;; Γ ,,, smash_context [] Δ ,,, expand_lets_ctx Δ Γ' |- + expand_lets_k Δ #|Γ'| t : expand_lets_k Δ #|Γ'| T. +Proof. + intros Ht. + rewrite /expand_lets /expand_lets_k. + pose proof (typing_wf_local Ht). + rewrite -app_context_assoc in Ht. + eapply (weakening_typing (Γ'' := smash_context [] Δ)) in Ht. + len in Ht. simpl in Ht. simpl. + 2:{ eapply wf_local_smash_end; pcuic. now apply wf_local_app_inv in X. } + rewrite lift_context_app app_context_assoc Nat.add_0_r in Ht. + eapply (PCUICSubstitution.substitution _ _ _ _ _) in Ht; tea. + 2:{ eapply PCUICContexts.subslet_extended_subst. now apply wf_local_app_inv in X. } + now len in Ht. +Qed. + +Lemma wf_local_expand_lets {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Γ'} : + wf_local Σ (Γ ,,, Δ ,,, Γ') -> + wf_local Σ (Γ ,,, smash_context [] Δ ,,, expand_lets_ctx Δ Γ'). +Proof. + intros hwf. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + destruct (wf_local_app_inv hwf) as [wfΓΔ _]. + rewrite -app_context_assoc in hwf. + eapply (weakening_wf_local (Γ'' := smash_context [] Δ)) in hwf. + len in hwf. simpl in hwf. simpl. + 2:{ eapply wf_local_smash_end; pcuic. } + rewrite lift_context_app app_context_assoc Nat.add_0_r in hwf. + eapply (PCUICSubstitution.substitution_wf_local _ _ _ _ _) in hwf; tea. + now eapply PCUICContexts.subslet_extended_subst. +Qed. + +Lemma expand_lets_k_subst_comm Δ k s T : + expand_lets_k Δ k (subst0 s T) = + subst0 (map (expand_lets_k Δ k) s) (expand_lets_k Δ (#|s| + k) T). +Proof. + rewrite /expand_lets_k. + now rewrite distr_lift_subst distr_subst Nat.add_assoc map_map_compose; len. +Qed. + +Lemma subslet_smash_context {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Γ' Δ' s} : + subslet Σ (Γ ,,, Δ ,,, Γ') s Δ' -> + subslet Σ (Γ ,,, smash_context [] Δ ,,, expand_lets_ctx Δ Γ') + (map (expand_lets_k Δ #|Γ'|) s) (expand_lets_k_ctx Δ #|Γ'| Δ'). +Proof. + induction 1. + * simpl. constructor. + * simpl. rewrite /expand_lets_k_ctx lift_context_snoc subst_context_snoc. + constructor. apply IHX. len. + rewrite Nat.add_assoc. fold (expand_lets_k Δ (#|Δ0| + #|Γ'|) T). + eapply typing_expand_lets_gen in t0. + rewrite expand_lets_k_subst_comm in t0. + now rewrite -(subslet_length X). + * simpl. rewrite /expand_lets_k_ctx lift_context_snoc subst_context_snoc. + len. rewrite /subst_decl /lift_decl /map_decl /=. + eapply subslet_def. apply IHX. len. + rewrite !Nat.add_assoc. + fold (expand_lets_k Δ (#|Δ0| + #|Γ'|) t). + fold (expand_lets_k Δ (#|Δ0| + #|Γ'|) T). + eapply typing_expand_lets_gen in t0. + rewrite !expand_lets_k_subst_comm in t0. + now rewrite -(subslet_length X). + now rewrite expand_lets_k_subst_comm -(subslet_length X) Nat.add_assoc. +Qed. + +Lemma spine_subst_expand_lets {cf Σ} {wfΣ : wf Σ} {Γ Δ Γ'} {inst s Δ'} : + spine_subst Σ (Γ ,,, Δ ,,, Γ') inst s Δ' -> + spine_subst Σ (Γ ,,, smash_context [] Δ ,,, expand_lets_ctx Δ Γ') + (map (expand_lets_k Δ #|Γ'|) inst) (map (expand_lets_k Δ #|Γ'|) s) + (expand_lets_k_ctx Δ #|Γ'| Δ'). +Proof. + intros []. + split. + * rewrite -app_context_assoc. + rewrite smash_context_app_expand_acc. + eapply wf_local_app_inv in spine_dom_wf as [wfΔ wfΓ']. + eapply wf_local_app. now apply wf_local_app_inv in wfΔ. + eapply wf_local_rel_smash_context_gen; tea. + * eapply wf_local_app_inv in spine_codom_wf as [wfΔ wfΓ']. + rewrite - !app_context_assoc -expand_lets_ctx_app. + apply wf_local_app_inv in wfΔ as []. + eapply wf_local_app. + now apply wf_local_app_inv in a as []. + rewrite smash_context_app_expand_acc. + apply wf_local_rel_smash_context_gen; tea. + eapply wf_local_rel_app; tea. + * rewrite /expand_lets_k_ctx /expand_lets_k -map_map_compose -[map (fun t => _) s]map_map_compose. + eapply subst_context_subst. + now eapply lift_context_subst. + * now eapply subslet_smash_context. +Qed. + + +Lemma expand_lets_lift n k Γ t : + expand_lets (lift_context n k Γ) (lift n (#|Γ| + k) t) = + lift n (k + context_assumptions Γ) (expand_lets Γ t). +Proof. + rewrite /expand_lets /expand_lets_k /=. + rewrite extended_subst_lift_context Nat.add_0_r. + epose proof (distr_lift_subst_rec _ _ _ 0 (k + context_assumptions Γ)). + len. rewrite permute_lift. lia. rewrite !Nat.add_assoc /= in H. + relativize #|Γ|. erewrite <- H. 2:now len. + now len. +Qed. + +Lemma expand_lets_ctx_lift n k' Γ Δ : + k' = #|Γ| -> + expand_lets_ctx (lift_context n 0 Γ) (lift_context n k' Δ) = + lift_context n (context_assumptions Γ) (expand_lets_ctx Γ Δ). +Proof. + intros ->. + rewrite /expand_lets_ctx /expand_lets_k_ctx /=. + len. + rewrite distr_lift_subst_context. len. + rewrite -lift_context_add Nat.add_comm. + rewrite lift_context_lift_context. + now rewrite extended_subst_lift_context. +Qed. + +Lemma lift_context_expand_lets_ctx n Γ Δ : + lift_context n 0 (expand_lets_ctx Γ Δ) = + expand_lets_k_ctx Γ n (lift_context n 0 Δ). +Proof. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + rewrite lift_context_subst_context. f_equal. + rewrite - !rename_context_lift_context /rename_context !fold_context_k_compose. + apply fold_context_k_ext => i t. + rewrite !shiftn_lift_renaming; sigma. + apply inst_ext. now rewrite !Upn_compose shiftn_Upn. +Qed. + +Lemma subst_let_expand_app s Γ s' Δ k : + k = #|Δ| -> + #|s| = context_assumptions Γ -> + subst0 s ∘ + subst0 (map (lift0 #|s|) s') ∘ + (expand_lets (expand_lets_ctx Γ Δ) ∘ expand_lets_k Γ k) =1 + subst_let_expand (s' ++ s) (Γ ,,, Δ). +Proof. + intros hk hs t. + rewrite /subst_let_expand /expand_lets. + rewrite subst_app_decomp. f_equal. + rewrite !expand_lets_k_0. + rewrite expand_lets_app. len. + + rewrite /subst_context_let_expand /subst_let_expand_k. + rewrite {1}/expand_lets_k. + rewrite /expand_lets_ctx /expand_lets_k_ctx. len. subst k. + relativize #|Δ|. + erewrite expand_lets_subst_comm. + len. 2:now len. + rewrite expand_lets_lift. + now rewrite -Nat.add_comm -/(expand_lets_k Γ (context_assumptions Δ) (expand_lets Δ t)). +Qed. + +(* +Lemma subst_let_expand_app s Γ s' Δ k : + k = #|Δ| -> + #|s| = context_assumptions Γ -> + subst_let_expand (s' ++ s) (Γ ,,, Δ) = + + + subst0 s ∘ + subst0 (map (lift0 #|s|) s') ∘ + (expand_lets (expand_lets_ctx Γ Δ) ∘ expand_lets_k Γ k) =1 +Proof. + intros hk hs t. + rewrite /subst_let_expand /expand_lets. + rewrite subst_app_decomp. f_equal. + rewrite !expand_lets_k_0. + rewrite expand_lets_app. len. + + rewrite /subst_context_let_expand /subst_let_expand_k. + rewrite {1}/expand_lets_k. + rewrite /expand_lets_ctx /expand_lets_k_ctx. len. subst k. + relativize #|Δ|. + erewrite expand_lets_subst_comm. + len. 2:now len. + rewrite expand_lets_lift. + now rewrite -Nat.add_comm -/(expand_lets_k Γ (context_assumptions Δ) (expand_lets Δ t)). +Qed. *) + +(*Lemma arity_spine_to_extended_list {cf} {Σ} {wfΣ : wf Σ} {Γ Δ T} : + wf_local_rel Σ Γ Δ -> + arity_spine Σ (Γ ,,, Δ) (it_mkProd_or_LetIn (lift_context #|Δ| 0 Δ) (lift #|Δ| #|Δ| T)) (to_extended_list Δ) + (subst_let_expand (List.rev (to_extended_list Δ)) Δ T). +Proof. + rewrite /subst_let_expand. + induction Δ using ctx_length_rev_ind in Γ , T |- *. + - rewrite ?expand_lets_nil /= lift0_id subst_empty; constructor. + - intros wf. rewrite lift_context_app /= it_mkProd_or_LetIn_app /mkProd_or_LetIn /=. + eapply wf_local_rel_app_inv in wf as []. + depelim w; simpl in *. + * destruct l as [s Hs]. + rewrite ?expand_lets_vass [to_extended_list _]to_extended_list_k_app /= Nat.add_0_r. + constructor. eapply meta_conv. econstructor; eauto. eapply wf_local_app; tea; pcuic. + eapply wf_local_rel_app; tea. repeat constructor. red. now exists s. + rewrite nth_error_app_context_lt; len; try lia. + rewrite nth_error_app_context_ge; len; try lia. + rewrite Nat.sub_diag. reflexivity. + simpl. len. lia_f_equal. + rewrite app_context_assoc. + len. rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r /=. len. + replace [tRel #|Γ0|] with (map (lift0 #|Γ0|) [tRel 0]). 2:now simpl; rewrite Nat.add_0_r. + rewrite lift_context_add. rewrite -distr_lift_subst_context. + rewrite subst_context_lift_id /= Nat.add_0_r. + rewrite !Nat.add_1_r subst_reli_lift_id. lia. + rewrite subst_app_simpl. simpl. len. + eapply X => //. + * destruct l as [s Hs]. + rewrite ?expand_lets_vdef [to_extended_list _]to_extended_list_k_app /=. + constructor. + rewrite app_context_assoc. + len. rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r /=. len. + specialize (X Γ0). + forward X by len; lia. + specialize (X (vdef na b t :: Γ)). + specialize (X T). forward X by tas. + rewrite -(distr_lift_subst_context (#|Γ0| + 1) 0 [_]). + rewrite lift_context_add. + rewrite lift_context_subst_context. + + + + rewrite subst_context_lift_context_cancel + eapply wf_local_rel_subst. + replace [tRel #|Γ0|] with (map (lift0 #|Γ0|) [tRel 0]). 2:now simpl; rewrite Nat.add_0_r. + rewrite lift_context_add. rewrite -distr_lift_subst_context. + rewrite subst_context_lift_id /= Nat.add_0_r. + rewrite !Nat.add_1_r subst_reli_lift_id. lia. + eapply X => //. + rewrite expan + + + constructor. + eapply + +*) + +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)) + (subst_context (inds (inductive_mind ind) puinst (ind_bodies mdecl)) + #|ind_params mdecl| + (subst_instance puinst (cstr_args cdecl)))). + +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'). +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' -> + All2 (fun x y => P y x) ctx' ctx. +Proof. + induction 1; constructor; auto. +Qed. + +(* No need to worry about the name annotations in the proofs below, for all typing + purposes we can work with the simpler context not involving the renaming *) +Lemma pre_case_branch_context_eq ind mdecl params puinst bctx cdecl : + wf_branch_gen cdecl bctx -> + All2 (compare_decls eq eq) + (pre_case_branch_context ind mdecl params puinst cdecl) + (case_branch_context_gen ind mdecl params puinst bctx cdecl). +Proof. + unfold wf_branch_gen. intros wf%Forall2_All2. + rewrite /pre_case_branch_context /case_branch_context_gen. + eapply All2_fold_context_k. + rewrite /expand_lets_ctx /expand_lets_k_ctx /subst_context. + eapply All2_fold_fold_context => /=. + eapply All2_fold_fold_context. + eapply All2_fold_fold_context. + eapply All2_fold_map. + eapply All2_fold_impl_ind. + instantiate (1 := fun _ _ d d' => compare_decls eq eq d' d). + eapply All2_fold_All2; tea. + eapply All2_sym. + eapply All2_map2_left_All3; tea. + induction wf; constructor; auto. + destruct x, y as [na [b|] ty]; constructor; auto. + intros ? ? d d'; cbn; rewrite !fold_context_k_length !map_context_length !Nat.add_0_r. + intros H _ []; constructor; simpl; auto. now symmetry. + rewrite (All2_fold_length H). subst; reflexivity. + now symmetry. + rewrite (All2_fold_length H); subst; reflexivity. + rewrite (All2_fold_length H); subst; reflexivity. +Qed. + +Lemma pre_case_branch_context_length_args {ind mdecl params puinst cdecl} : + #|pre_case_branch_context ind mdecl params puinst cdecl| = #|cstr_args cdecl|. +Proof. + now rewrite /pre_case_branch_context; len. +Qed. +(* +Lemma noccur_between_lift {n k T} : noccur_between k n T -> + ∑ T', lift n k T' = T. +Proof. + revert k n T. + eapply term_noccur_between_list_ind; intros. + - destruct (leb_spec_Set (S i) k). + exists (tRel i). simpl. + nat_compare_specs => //. + destruct (leb_spec_Set (k + n) i). + exists (tRel (i - n)). simpl. + nat_compare_specs => //. lia_f_equal. + elimtype False. destruct H. lia. lia. + - exists (tVar i); reflexivity. + - admit. + - exists (tSort s); reflexivity. + - destruct X, X0. exists (tProd na x x0). + simpl. now rewrite e e0. + - destruct X, X0. exists (tLambda na x x0). + simpl. now rewrite e e0. + - admit. + - destruct X, X0. + simpl; exists (tApp x x0). + now rewrite /= e e0. + - now exists (tConst s u). + - now exists (tInd i u). + - now exists (tConstruct i c u). + - admit. + - destruct X. + now exists (tProj s x); simpl; rewrite e. + - admit. + - admit. +Admitted.*) + +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 Δ) + T. +Proof. + intros hty wf. + rewrite lift_it_mkProd_or_LetIn Nat.add_0_r. + pose proof (all_rels_subst_lift Σ Δ Γ [] T wfΣ). + rewrite lift0_id in X. simpl in X. + rewrite Nat.add_0_r in X. + rewrite -(app_nil_r (to_extended_list Δ)). + eapply arity_spine_it_mkProd_or_LetIn; tea. + rewrite /to_extended_list /to_extended_list_k. + eapply spine_subst_to_extended_list_k; tea. + constructor => //. + eapply conv_cumul. symmetry. now apply X. +Qed. + +Lemma isType_subst_all_rels {cf} {Σ} {wfΣ : wf Σ} {Γ Δ} {T} : + isType Σ (Γ ,,, Δ) T -> + isType Σ (Γ ,,, Δ) (subst0 (all_rels Δ 0 #|Δ|) (lift #|Δ| #|Δ| T)). +Proof. + intros [s Hs]; exists s. red in Hs |- *. + pose proof (typing_wf_local Hs). + eapply weakening_typing in Hs; tea. + rewrite -(app_nil_l (lift_context _ _ _)) -/(app_context _ _) app_context_assoc in Hs. + eapply substitution in Hs; tea. + eapply spine_subst_to_extended_list_k; tea. +Qed. + + +Lemma arity_spine_to_extended_list_app {cf} {Σ} {wfΣ : wf Σ} {Γ Δ} {T s T'} : + wf_local Σ (Γ ,,, Δ) -> + isType Σ (Γ ,,, Δ) T -> + arity_spine Σ (Γ ,,, Δ) (subst0 (all_rels Δ 0 #|Δ|) (lift #|Δ| #|Δ| T)) s T' -> + arity_spine Σ (Γ ,,, Δ) (lift0 #|Δ| (it_mkProd_or_LetIn Δ T)) (to_extended_list Δ ++ s) T'. +Proof. + intros isty wf. + rewrite lift_it_mkProd_or_LetIn Nat.add_0_r. + pose proof (all_rels_subst_lift Σ Δ Γ [] T wfΣ). + rewrite lift0_id in X. simpl in X. + rewrite Nat.add_0_r in X. + intros sp. + eapply arity_spine_it_mkProd_or_LetIn; tea. + rewrite /to_extended_list /to_extended_list_k. + eapply spine_subst_to_extended_list_k; tea. +Qed. + +Lemma typing_spine_to_extended_list_app {cf} {Σ} {wfΣ : wf Σ} {Γ Δ} {T s T'} : + wf_local Σ (Γ ,,, Δ) -> + isType Σ (Γ ,,, Δ) T -> + typing_spine Σ (Γ ,,, Δ) T s T' -> + typing_spine Σ (Γ ,,, Δ) (lift0 #|Δ| (it_mkProd_or_LetIn Δ T)) (to_extended_list Δ ++ s) T'. +Proof. + intros isty wf. + rewrite lift_it_mkProd_or_LetIn Nat.add_0_r. + intros sp. + eapply typing_spine_it_mkProd_or_LetIn'; tea. + rewrite /to_extended_list /to_extended_list_k. + eapply spine_subst_to_extended_list_k; tea. + eapply typing_spine_strengthen; tea. + eapply conv_cumul. symmetry. + epose proof (all_rels_subst_lift _ _ _ [] T wfΣ isty). + now rewrite /= lift0_id Nat.add_0_r in X. + rewrite -[X in lift _ X _](Nat.add_0_r #|Δ|). + rewrite -lift_it_mkProd_or_LetIn. + eapply isType_lift; tea. now len. + rewrite skipn_app List.skipn_all /= Nat.sub_diag skipn_0. + now eapply isType_it_mkProd_or_LetIn. +Qed. + +Lemma typing_spine_to_extended_list_k_app {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} {T s T'} : + wf_local Σ (Γ ,,, Δ ,,, Δ') -> + isType Σ (Γ ,,, Δ) T -> + typing_spine Σ (Γ ,,, Δ ,,, Δ') (lift0 #|Δ'| T) s T' -> + typing_spine Σ (Γ ,,, Δ ,,, Δ') (lift0 (#|Δ| + #|Δ'|) (it_mkProd_or_LetIn Δ T)) (to_extended_list_k Δ #|Δ'| ++ s) T'. +Proof. + intros isty wf sp. + rewrite !lift_it_mkProd_or_LetIn Nat.add_0_r. + eapply typing_spine_it_mkProd_or_LetIn'; tea. + rewrite /to_extended_list /to_extended_list_k. + rewrite -{1}(Nat.add_0_r #|Δ'|) reln_lift. + rewrite -Nat.add_comm lift_context_add. + eapply spine_subst_weakening;tea. + eapply spine_subst_to_extended_list_k; tea. + now apply wf_local_app_inv in isty. + eapply typing_spine_strengthen; tea. + eapply conv_cumul; symmetry. + eapply wf_local_app_inv in isty as []. + epose proof (all_rels_subst_lift _ _ _ Δ' T wfΣ a). + etransitivity; tea. + len. + rewrite -all_rels_lift Nat.add_comm. reflexivity. + rewrite -(Nat.add_0_r #|Δ|) -lift_it_mkProd_or_LetIn Nat.add_0_r. + rewrite -app_length. + replace #|Δ ++ Δ'| with (#|Δ ,,, Δ'|). + 2:now len. + eapply isType_lift; tea. now len. + rewrite -app_context_assoc. + rewrite skipn_app List.skipn_all /= Nat.sub_diag skipn_0. + now eapply isType_it_mkProd_or_LetIn. +Qed. + +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. +Qed. + +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) = + lift0 n (subst_let_expand s Γ T). +Proof. + intros hs cl. + now rewrite -{1}(closed_ctx_lift n 0 Γ) // subst_let_expand_lift. +Qed. + + +Lemma wf_case_predicate_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} + {Γ mdecl idecl ci p } {args : list term} : + declared_inductive Σ ci.(ci_ind) mdecl idecl -> + isType Σ Γ (mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ args)) -> + wf_predicate mdecl idecl p -> + let predctx := case_predicate_context ci mdecl idecl p in + wf_local Σ (Γ ,,, predctx). +Proof. + intros isdecl Hc wfp predctx. + 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. + now eapply isType_wf_local in i. +Qed. + +Definition case_branch_context_nopars ind mdecl puinst bctx cdecl := + (subst_context (inds (inductive_mind ind) puinst (ind_bodies mdecl)) + #|ind_params mdecl| + (subst_instance puinst (map2 set_binder_name bctx (cstr_args cdecl)))). + +Lemma wf_case_branches_types {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} + {Γ mdecl idecl ci p} ps (args : list term) brs : + declared_inductive Σ ci.(ci_ind) mdecl idecl -> + isType Σ Γ (mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ args)) -> + wf_predicate mdecl idecl p -> + let predctx := case_predicate_context ci mdecl idecl p in + Σ;;; Γ ,,, p.(pcontext) |- p.(preturn) : tSort ps -> + let ptm := it_mkLambda_or_LetIn p.(pcontext) p.(preturn) in + conv_context Σ (Γ ,,, p.(pcontext)) (Γ ,,, predctx) -> + wf_branches idecl brs -> + All2i (fun i cdecl br => + wf_local Σ (Γ ,,, subst_instance p.(puinst) (ind_params mdecl) ,,, + case_branch_context_nopars ci mdecl p.(puinst) (forget_types br.(bcontext)) cdecl) × + let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in + Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps) + 0 (ind_ctors idecl) brs. +Proof. + intros isdecl Hc wfp bc Hp ptm conv wfbrs. + destruct (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.typing_wf_universe _ Hp) wfp) as [wfty _]. + set wfcpc := wf_case_predicate_context isdecl Hc wfp. simpl in wfcpc. clearbody wfcpc. + have clipars : closed_ctx (subst_instance (puinst p) (ind_params mdecl)). + { rewrite closedn_subst_instance_context. + eapply (declared_inductive_closed_params isdecl). } + have wfΓ : (wf_local Σ Γ). + { now apply isType_wf_local in Hc. } + have lenpars : #|pparams p| = + context_assumptions (subst_instance (puinst p) (ind_params mdecl)). + { len. rewrite (wf_predicate_length_pars wfp) //. + apply (declared_minductive_ind_npars isdecl). } + eapply isType_mkApps_Ind_smash in Hc; tea. + 2:{ rewrite (declared_minductive_ind_npars isdecl). now len in lenpars. } + destruct Hc as [sppars [spargs cu]]. + eapply forall_nth_error_All2i. + now rewrite (Forall2_length wfbrs). + intros n cdecl br nth nth'. + red in wfbrs. eapply Forall2_All2 in wfbrs. + eapply All2_nth_error in wfbrs; tea. + assert (declared_constructor Σ.1 (ci.(ci_ind), n) mdecl idecl cdecl). split; eauto. - destruct (on_declared_constructor wfΣ H) as [[onind oib] [cs [nthc onc]]]. - clear oib. set (oib := declared_inductive_inv _ _ _ _) in *. - eapply branch_type_spec in Hbr; eauto. - unshelve eapply build_case_predicate_type_spec in bc. 2:eauto. - destruct bc as [parsubst [csub ptyeq]]. - destruct Hbr as [hnarg Hbr]. - specialize (Hbr _ csub). - simpl in Hbr. subst brty. - move: (destArity_spec [] pty). rewrite da. - simpl. intros ->. clear nth. - eapply (f_equal (destArity [])) in ptyeq. - rewrite !destArity_it_mkProd_or_LetIn /= in ptyeq. noconf ptyeq. - rewrite !app_context_nil_l in H0. subst pctx. - eapply PCUICValidity.validity in Hc; eauto. - destruct Hc as [s Hs]. - eapply invert_type_mkApps_ind in Hs as [spargs cu]; eauto. - rewrite oib.(ind_arity_eq) in spargs. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in spargs. - rewrite -it_mkProd_or_LetIn_app in spargs. - eapply arity_typing_spine in spargs as [[lenargs leqs] [instsubst spsubst]]; auto. - 2:{ eapply weaken_wf_local; pcuic. rewrite -[_ ++ _]subst_instance_context_app. - eapply on_minductive_wf_params_indices_inst; eauto. } - epose proof onind.(onNpars) as npars. - rewrite -(firstn_skipn (ind_npars mdecl) args) in spsubst. - len in lenargs. - eapply spine_subst_app_inv in spsubst; auto. - 2:{ len. rewrite firstn_length_le. lia. lia. } - len in spsubst. destruct spsubst as [sppars spargs]. - destruct (on_constructor_inst _ wfΣ decli onind _ onc cu) as [wf _]. - assert (wfps : wf_universe Σ ps). - { eapply validity in Hp; auto. - eapply PCUICWfUniverses.isType_wf_universes in Hp. - rewrite PCUICWfUniverses.wf_universes_it_mkProd_or_LetIn in Hp. - move/andb_and: Hp => [_ Hp]. - now apply (ssrbool.elimT PCUICWfUniverses.wf_universe_reflect) in Hp. auto. } - rewrite !subst_instance_context_app in wf. - assert (sorts_local_ctx (lift_typing typing) Σ Γ - (subst_context parsubst 0 - (subst_context - (inds (inductive_mind ind) u (PCUICEnvironment.ind_bodies mdecl)) - #|ind_params mdecl| - (map_context (subst_instance_constr u) - (cshape_args cs)))) - (List.map (subst_instance_univ u) (cshape_sorts cs))). - { pose proof (onc.(on_cargs)). - eapply sorts_local_ctx_instantiate in X; eauto. - rewrite subst_instance_context_app in X. - rewrite -(app_context_nil_l (_ ,,, _)) app_context_assoc in X. - eapply (subst_sorts_local_ctx) in X; simpl in *; eauto. - 3:{ eapply subslet_inds; eauto. } - 2:{ rewrite app_context_nil_l. - now eapply All_local_env_app_inv in wf as [? ?]. } - simpl in X. len in X. - eapply weaken_sorts_local_ctx in X. 2:eauto. 2:eapply typing_wf_local; eauto. - rewrite app_context_nil_l in X. - rewrite closed_ctx_subst in X. - eapply closed_wf_local; eauto. - eapply on_minductive_wf_params; pcuic. - eapply decli. - eapply (subst_sorts_local_ctx _ _ []) in X; simpl in *; eauto. - eapply weaken_wf_local; pcuic. - eapply on_minductive_wf_params; pcuic. eapply decli. - rewrite (context_subst_fun csub sppars). - eapply sppars. } - eexists. - set (binder := vass _ _) in *. - (* assert (wfcs : wf_universe Σ (subst_instance u (cshape_sort cs))). - { eapply type_local_ctx_wf in X; pcuic. } *) - eapply type_it_mkProd_or_LetIn_sorts. eauto. eapply X. - eapply sorts_local_ctx_wf_local in X. - eapply type_mkApps. - relativize #|cshape_args cs|. - eapply weakening; eauto. now len. - len. rewrite lift_it_mkProd_or_LetIn /=. - epose proof (on_constructor_inst_pars_indices wfΣ decli onind _ onc cu sppars) as - [wfparspargs [instps spinst]]. - pose proof (context_subst_fun csub sppars); subst parsubst. - set (parsubst := skipn #|ind_indices oib| instsubst) in *. - eapply wf_arity_spine_typing_spine; eauto. - assert(wf_local Σ - (Γ ,,, - subst_context (skipn #|ind_indices oib| instsubst) 0 - (subst_context - (inds (inductive_mind ind) u (PCUICEnvironment.ind_bodies mdecl)) - #|PCUICEnvironment.ind_params mdecl| - (PCUICEnvironment.map_context (subst_instance_constr u) - (cshape_args cs))) ,,, - lift_context #|cshape_args cs| 0 - (subst_context (skipn #|ind_indices oib| instsubst) 0 - (subst_instance_context u (ind_indices oib))) ,,, - [lift_decl #|cshape_args cs| #|ind_indices oib| binder])). - { constructor. - relativize #|cshape_args cs|. - eapply weakening_wf_local; eauto. eapply spargs. now len. - red. set (sort := subst_instance_univ u (ind_sort oib)). exists sort. - simpl. - change (tSort sort) with (lift #|cshape_args cs| #|ind_indices oib| (tSort sort)). - change (skipn #|ind_indices oib| instsubst) with parsubst. - relativize #|cshape_args cs|. - change #|ind_indices _| with #|ind_indices oib|. - relativize #|ind_indices oib|. - eapply weakening_typing; eauto. all:len => //. - eapply type_mkApps. - econstructor; eauto. eapply spargs. - rewrite oib.(ind_arity_eq) !subst_instance_constr_it_mkProd_or_LetIn -it_mkProd_or_LetIn_app. - eapply typing_spine_it_mkProd_or_LetIn_close'; eauto. - 2:{ rewrite -[_ ++ _]subst_instance_context_app -subst_instance_constr_it_mkProd_or_LetIn - it_mkProd_or_LetIn_app. - rewrite -oib.(ind_arity_eq). eapply declared_inductive_valid_type; eauto. - eapply spargs. } - eapply spine_subst_app; eauto. len. - rewrite firstn_length_le; lia. + set (brctxty := case_branch_type _ _ _ _ _ _ _ _). + destruct (on_declared_constructor H) as [[onind oib] [cs [nthc onc]]]. + simpl in *. + subst brctxty. + unfold case_branch_type, case_branch_type_gen => /=. + rewrite -/(case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl). + + assert (wfargs : wf_local (Σ.1, ind_universes mdecl) + (arities_context (ind_bodies mdecl),,, ind_params mdecl,,, cstr_args cdecl)). + { destruct onc. apply sorts_local_ctx_All_local_env in on_cargs => //. + eapply weaken_wf_local => //. eapply (wf_arities_context' _ _ _ _ onind) => //. + apply onind.(onParams). } + assert (wfparscd : wf_local Σ + (Γ,,, subst_instance (puinst p) (ind_params mdecl),,, + case_branch_context_nopars ci mdecl (puinst p) (forget_types (bcontext br)) + cdecl)). { + rewrite -app_context_assoc. + eapply weaken_wf_local; tea. + eapply wf_set_binder_name in wfargs. + 2:{ now eapply Forall2_All2 in wfbrs; tea. } + eapply (wf_local_instantiate _ (InductiveDecl mdecl) _ p.(puinst)) in wfargs; tea. + 2:eapply isdecl. + rewrite !subst_instance_app in wfargs. + rewrite - !/(app_context _ _) in wfargs. + rewrite -(app_context_nil_l (_ ,,, _)) -app_context_assoc app_context_assoc in wfargs. + eapply substitution_wf_local in wfargs; tea. + 2:eapply subslet_inds; tea. + rewrite app_context_nil_l subst_context_app in wfargs. + rewrite closed_ctx_subst in wfargs => //. + rewrite /case_branch_context_nopars. + now rewrite subst_instance_length Nat.add_0_r in wfargs. } + assert (wf_local Σ (Γ ,,, case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl)). + { rewrite /case_branch_context /case_branch_context_gen. + eapply substitution_wf_local; tea. eapply sppars. + eapply wf_local_expand_lets => //. } + split => //. + assert (wfparsargs : wf_local Σ + (Γ,,, subst_instance (puinst p) (ind_params mdecl),,, + subst_context (inds (inductive_mind ci) (puinst p) (ind_bodies mdecl)) + #|ind_params mdecl| (subst_instance (puinst p) (cstr_args cdecl)))). { rewrite -app_context_assoc. - eapply weaken_wf_local; eauto. eapply spargs. - rewrite -subst_instance_context_app; eapply on_minductive_wf_params_indices_inst; eauto. - len. split. - * eapply (spine_subst_weakening _ _ _ _ _ (subst_context _ 0 (subst_instance_context u (ind_indices oib)))) in sppars; eauto. - len in sppars. 2:{ eapply spargs. } - len. rewrite map_skipn in sppars. - rewrite closed_ctx_lift in sppars. - eapply PCUICClosed.closed_wf_local; eauto. - eapply on_minductive_wf_params; pcuic. eapply decli. - instantiate (1 := all_rels (subst_context parsubst 0 (subst_instance_context u (ind_indices oib))) 0 - #|_| ++ - map (lift0 #|ind_indices oib|) (skipn #|ind_indices oib| instsubst)). - rewrite skipn_all_app_eq; len => //. - rewrite map_skipn. eapply sppars. - * rewrite firstn_app; len. rewrite Nat.sub_diag [firstn 0 _]firstn_0 /= // app_nil_r. - rewrite -> firstn_all2 by (len; lia). - rewrite skipn_all_app_eq; len => //. - relativize (subst_context (map _ _) _ _). - rewrite /to_extended_list -(PCUICSubstitution.map_subst_instance_constr_to_extended_list_k u). - rewrite -(to_extended_list_k_subst parsubst 0). - eapply spine_subst_to_extended_list_k; eauto. - eapply spargs. - len. rewrite subst_map_lift_lift_context. - fold parsubst. move: (context_subst_length sppars); len => <-. - epose proof (on_minductive_wf_params_indices_inst _ _ _ _ _ wfΣ (proj1 decli) oib cu). - eapply PCUICClosed.closed_wf_local in X0; auto. move: X0. - now rewrite subst_instance_context_app PCUICClosed.closedn_ctx_app /=; len => /andb_and [_ ?]. - rewrite lift_context_subst_context //. } + eapply weaken_wf_local; tea. + eapply (wf_local_instantiate _ (InductiveDecl mdecl) _ p.(puinst)) in wfargs; tea. + 2:eapply isdecl. + rewrite !subst_instance_app in wfargs. + rewrite - !/(app_context _ _) in wfargs. + rewrite -(app_context_nil_l (_ ,,, _)) -app_context_assoc app_context_assoc in wfargs. + eapply substitution_wf_local in wfargs; tea. + 2:eapply subslet_inds; tea. + rewrite app_context_nil_l subst_context_app in wfargs. + rewrite closed_ctx_subst in wfargs => //. + now rewrite subst_instance_length Nat.add_0_r in wfargs. } + assert (wfbrctx : wf_local Σ (Γ ,,, pre_case_branch_context ci mdecl p.(pparams) p.(puinst) cdecl)). + { rewrite /case_branch_context /case_branch_context_gen. + eapply substitution_wf_local; tea. eapply sppars. + eapply wf_local_expand_lets => //. } + eapply type_mkApps. + relativize #|cstr_args cdecl|. + eapply weakening; tea. rewrite /ptm. + eapply type_Cumul'. + eapply type_it_mkLambda_or_LetIn. tea. + 2:{ eapply cumul_it_mkProd_or_LetIn; tea. + eapply PCUICContextRelation.All2_fold_app_inv; tea. rewrite /bc. + now rewrite (case_predicate_context_length wfp). reflexivity. } + rewrite /bc //. + rewrite -(wf_branch_length wfbrs). + rewrite case_branch_context_length //. + eapply wf_arity_spine_typing_spine; tea. split. - { eapply isType_it_mkProd_or_LetIn; eauto. - eapply isType_Sort; eauto. - subst binder. rewrite lift_context_snoc. simpl. len. exact X0. } - eapply (arity_spine_it_mkProd_or_LetIn_Sort _ _ _ _ _ ([_] ++ instps)); eauto. - rewrite lift_context_snoc /=. len. - eapply (spine_subst_app _ _ _ [_]); len; auto. - move: (context_subst_length2 spinst). now len. - simpl; split. - 2:{ - rewrite /lift_decl /map_decl; simpl. unfold subst_context at 5. - rewrite /fold_context /= /map_decl /=. - constructor; auto. constructor; auto. - red. simpl. rewrite lift_mkApps subst_mkApps /=. - rewrite skipn_S skipn_0. - depelim X0. red in l. simpl in l. - destruct l as [s' Hs]. exists s'. - eapply (substitution _ _ _ instps []) in Hs; eauto. - 2:eapply spinst. - now rewrite lift_mkApps subst_mkApps /= in Hs. - eapply (context_subst_ass [] [] []). constructor. - repeat constructor. - rewrite subst_empty skipn_S skipn_0. - rewrite lift_mkApps subst_mkApps !map_app /=. - assert (eqpars : map (subst0 instps) - (map (lift #|cshape_args cs| #|ind_indices oib|) - (map (lift0 #|ind_indices oib|) (firstn (ind_npars mdecl) args))) = - map (lift0 #|cshape_args cs|) (firstn (ind_npars mdecl) args)). - { rewrite (map_map_compose _ _ _ _ (lift _ _)). - rewrite -simpl_map_lift /=. - rewrite -(map_map_compose _ _ _ _ (lift _ _)). - rewrite map_map_compose. - change #|ind_indices _| with #|ind_indices oib|. - relativize #|ind_indices oib|. - rewrite -> map_subst_lift_id. - 2:{ rewrite -(context_subst_length spinst). now len. } - reflexivity. } - rewrite eqpars. - eapply type_mkApps. econstructor; eauto. - eapply wf_arity_spine_typing_spine; eauto. - split. - apply (declared_constructor_valid_ty _ _ _ _ _ _ _ _ wfΣ (spinst.(spine_dom_wf _ _ _ _ _)) H cu). - pose proof onc.(cstr_eq). unfold cdecl_type in H0. - unfold type_of_constructor; rewrite {}H0. - rewrite !subst_instance_constr_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn. - rewrite -it_mkProd_or_LetIn_app. len. - rewrite -(app_nil_r (map _ _ ++ _)). - eapply arity_spine_it_mkProd_or_LetIn; eauto. - eapply spine_subst_app; eauto. len. rewrite firstn_length_le; lia. - { rewrite -app_context_assoc. eapply weaken_wf_local; eauto. - rewrite closed_ctx_subst. eapply closed_wf_local; eauto. eapply on_minductive_wf_params; eauto. - apply wfparspargs. } - split. len. - rewrite (closed_ctx_subst _ _ (subst_instance_context _ _)). - eapply closed_wf_local; eauto. eapply on_minductive_wf_params; eauto. - instantiate (1 := all_rels _ _ _ ++ (map (lift0 #|cshape_args cs|) (skipn #|ind_indices oib| instsubst))). - rewrite -(closed_ctx_lift #|cshape_args cs| 0 (subst_instance_context _ _)). - eapply closed_wf_local; eauto. eapply on_minductive_wf_params; eauto. - rewrite skipn_all_app_eq. all:cycle 1. - relativize #|cshape_args cs|. - eapply spine_subst_weakening; eauto. len. reflexivity. - simpl. len. - rewrite (firstn_app_left _ 0) // ?firstn_0 //. all:cycle 1. - rewrite app_nil_r. - rewrite skipn_all_app_eq. all:cycle 1. - relativize (subst_context (map (lift0 _) _) 0 _). - eapply spine_subst_to_extended_list_k; eauto. len. - { rewrite subst_map_lift_lift_context. - rewrite -(context_subst_length sppars). len. - eapply (closedn_ctx_subst 0). len. simpl. - 2:eapply declared_minductive_closed_inds; eauto. - eapply closed_wf_local in wf; eauto. move: wf. - now rewrite !closedn_ctx_app /=; len => /andb_and [_ ?]. - now rewrite lift_context_subst_context. } - len. - rewrite (subst_cstr_concl_head ind u mdecl (cshape_args cs) _ _). - destruct decli. now eapply nth_error_Some_length in H1. - rewrite subst_mkApps /= map_app. - eapply arity_spine_conv. - { depelim X0. - destruct l as [s' Hs]. exists s'. red. - simpl in Hs. - eapply (substitution _ _ _ _ []) in Hs; eauto. - 2:{ eapply spinst. } - simpl in Hs. rewrite lift_mkApps subst_mkApps !map_app /= in Hs. - move: Hs. now rewrite eqpars. } - eapply conv_cumul. eapply mkApps_conv_args; eauto. - eapply All2_app. - * rewrite map_subst_app_to_extended_list_k. now len. - eapply spine_subst_weakening in sppars. all:auto. - 2:{ eapply X. } - len in sppars. - move: (spine_subst_subst_to_extended_list_k sppars). - rewrite to_extended_list_k_fold_context. - rewrite PCUICSubstitution.map_subst_instance_constr_to_extended_list_k => ->. - eapply All2_refl. intros; reflexivity. - * epose proof (to_extended_list_map_lift _ 0 _). rewrite Nat.add_0_r in H0. - - move: (context_subst_length spinst). len => hlen. - rewrite <- H0. - move: (spine_subst_subst_to_extended_list_k spinst). - rewrite !to_extended_list_k_fold_context PCUICSubstitution.map_subst_instance_constr_to_extended_list_k. - move=> ->. - set (argctx := cshape_args cs) in *. - change (skipn #|ind_indices oib| instsubst) with parsubst in spinst, X0 |- *. - assert (All (fun x => closedn (#|parsubst| + #|argctx|) x) (map - (subst (inds (inductive_mind ind) u (PCUICAst.ind_bodies mdecl)) - (#|cshape_args cs| + #|ind_params mdecl|) - ∘ subst_instance_constr u) (cshape_indices cs))). - { pose proof (positive_cstr_closed_indices wfΣ onc). - eapply All_map. - eapply All_map_inv in X1. - eapply (All_impl X1) => x' cl. - eapply (closedn_expand_lets 0) in cl. - rewrite subst_closedn closedn_subst_instance_constr. - now len in cl. rewrite /parsubst. - rewrite -(context_subst_length sppars). - autorewrite with len. now rewrite Nat.add_comm; len in cl. } - eapply All2_map. rewrite !map_map_compose. - apply (All_All2 X1). - intros x cl. - rewrite subst_app_simpl. len. - epose proof (all_rels_subst Σ _ _ (subst parsubst #|argctx| x) wfΣ (spine_dom_wf _ _ _ _ _ spinst)). - len in X1. - etransitivity. - 2:symmetry; eapply red_conv; eauto. - len. - assert(subst (map (lift0 #|argctx|) parsubst) #|cshape_args cs| x = - (lift #|argctx| #|argctx| (subst parsubst #|argctx| x))) as <-. - { epose proof (distr_lift_subst_rec _ _ #|argctx| #|argctx| 0) as l. - rewrite Nat.add_0_r in l. rewrite -> l. f_equal. - rewrite lift_closed. eapply closed_upwards; eauto. - rewrite /argctx. - lia. reflexivity. } - symmetry. now simpl. - * now len. - * now len. - * now len. - } - rewrite skipn_S skipn_0. - now rewrite !map_map_compose in spinst. pcuic. + { apply isType_lift => //. rewrite app_length; lia. + rewrite skipn_all_app //. } + rewrite lift_it_mkProd_or_LetIn /=. + rewrite -(app_nil_r (_ ++ [_])). + eapply arity_spine_it_mkProd_or_LetIn_smash => //. + 2:constructor. + rewrite /bc. + eapply subslet_eq_context_alpha. + { 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. + apply case_predicate_context_alpha. destruct wfp. + eapply Forall2_All2 in H1. + clear -H1. + depelim H1. rewrite H. + now constructor. } + rewrite map_map_compose. + + fold (subst_let_expand_k (List.rev (pparams p)) (subst_instance (puinst p) (ind_params mdecl)) #|cstr_args cdecl|). + set (indices := map (subst (inds _ _ _) _) _). + rewrite /case_predicate_context' lift_context_snoc. + rewrite subst_context_length subst_instance_length expand_lets_ctx_length. + rewrite (smash_context_app_expand _ _ [_]). + cbn. rewrite List.rev_app_distr; cbn. + rewrite expand_lets_ctx_tip; cbn. + rewrite /lift_decl compose_map_decl; cbn. + eapply (subslet_eq_context_alpha_dom (Γ:= (Γ ,,, pre_case_branch_context ci.(ci_ind) mdecl p.(pparams) p.(puinst) cdecl))). + { eapply All2_app. apply pre_case_branch_context_eq. apply wfbrs. + apply All2_refl. intros; reflexivity. } + pose proof (on_cindices onc). + assert (spindices : + spine_subst Σ + (Γ,,, pre_case_branch_context ci mdecl (pparams p) (puinst p) cdecl) + (map (subst (List.rev (pparams p)) #|cstr_args cdecl|) + (map + (expand_lets_k (subst_instance (puinst p) (ind_params mdecl)) + #|cstr_args cdecl|) indices)) + (map (subst (List.rev (pparams p)) #|cstr_args cdecl|) + (map + (expand_lets_k (subst_instance (puinst p) (ind_params mdecl)) + #|cstr_args cdecl|) + (map + (subst + (inds (inductive_mind ci) (puinst p) (ind_bodies mdecl)) + (#|ind_params mdecl| + #|cstr_args cdecl|)) + (map (subst_instance (puinst p)) (ctx_inst_sub X0))))) + (subst_context (List.rev (pparams p)) #|cstr_args cdecl| + (expand_lets_k_ctx (subst_instance (puinst p) (ind_params mdecl)) + #|cstr_args cdecl| + (subst_instance (puinst p) + (lift_context #|cstr_args cdecl| 0 (ind_indices idecl)))))). + { unshelve epose proof (ctx_inst_spine_subst _ X0) as sp. + { eapply weakening_wf_local => //. + rewrite -app_context_assoc. apply weaken_wf_local => //. + eapply (wf_arities_context _ _ _ _ isdecl). + apply (on_minductive_wf_params_indices isdecl). } + eapply spine_subst_inst in sp; tea. + 2:{ exact (declared_inductive_wf_global_ext _ _ _ _ isdecl). } + rewrite !subst_instance_app_ctx in sp. + rewrite -app_context_assoc in sp. + eapply spine_subst_subst_first in sp; tea. + 2:eapply subslet_inds; tea. + rewrite app_context_length !subst_instance_length in sp. + rewrite subst_context_app subst_instance_length /= Nat.add_0_r in sp. + rewrite closed_ctx_subst // in sp. + eapply spine_subst_weaken in sp. 3: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. + rewrite subst_context_length subst_instance_length in sp. + eapply spine_subst_subst in sp; tea. + 2:exact sppars. + rewrite expand_lets_ctx_length subst_context_length subst_instance_length in sp. + rewrite /subst_context_let_expand. + rewrite (closed_ctx_subst (inds _ _ _) (#|ind_params mdecl| + _)) in sp. + { rewrite closedn_subst_instance_context. + rewrite Nat.add_comm; apply closedn_ctx_lift. + pose proof (declared_inductive_closed_pars_indices _ isdecl). + rewrite closedn_ctx_app in H0. + now move/andb_and: H0 => []. } + exact sp. } + constructor. + - rewrite case_branch_context_length_args //. + rewrite /indices. + eapply spine_subst_smash in spindices; tea. + rewrite subst_instance_expand_lets_ctx. + rewrite lift_context_subst_context lift_context_expand_lets_ctx + -subst_instance_lift_context. + eapply inst_subslet in spindices. + rewrite /subst_let_expand_k. + rewrite /indices in spindices. + now rewrite map_map_compose in spindices. + - cbn [decl_type ind_binder]. + rewrite lift_mkApps expand_lets_mkApps. + rewrite subst_mkApps. simpl. + rewrite map_subst_let_expand_k. + rewrite case_branch_context_length_args //. + eapply meta_conv. + * eapply type_mkApps. + { econstructor; tea. } + eapply wf_arity_spine_typing_spine; tea. + split. { eapply validity. econstructor; eauto. } + replace (type_of_constructor mdecl cdecl (ci.(ci_ind), n) (puinst p)) + with (lift0 #|cstr_args cdecl| (type_of_constructor mdecl cdecl (ci.(ci_ind), n) (puinst p))). + 2:{ rewrite lift_closed //. eapply (declared_constructor_closed_type H). } + unfold type_of_constructor. + rewrite onc.(cstr_eq). + simpl. + rewrite subst_instance_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. + rewrite lift_it_mkProd_or_LetIn. + rewrite closed_ctx_lift. + { rewrite closed_ctx_subst //. } + eapply arity_spine_it_mkProd_or_LetIn_smash; tea. + + rewrite closed_ctx_subst. + rewrite closedn_subst_instance_context. + eapply (declared_inductive_closed_params isdecl). + rewrite -[smash_context [] _](closed_ctx_lift #|cstr_args cdecl| 0). + { now apply closedn_smash_context. } + rewrite -map_rev. + relativize #|cstr_args cdecl|. + eapply subslet_lift; tea. eapply sppars. + now apply pre_case_branch_context_length_args. + + rewrite subst_context_length Nat.add_0_r. + rewrite subst_instance_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. + rewrite -map_rev. + relativize #|subst_instance (puinst p) (ind_params mdecl)|. + erewrite subst_let_expand_closed_ctx_lift. + 2:{ now rewrite List.rev_length context_assumptions_subst_context. } + 3:now rewrite subst_context_length. + 2:{ rewrite closed_ctx_subst => //. } + rewrite subst_let_expand_it_mkProd_or_LetIn. + rewrite !subst_context_length !subst_instance_length. + rewrite closed_ctx_subst //. + set (cstr_ctx := subst_context_let_expand _ _ _). + change cstr_ctx with + (pre_case_branch_context ci mdecl (pparams p) (puinst p) cdecl). + clear cstr_ctx. + rewrite -{1}(@pre_case_branch_context_length_args ci mdecl (pparams p) (puinst p) cdecl). + rewrite /to_extended_list /to_extended_list_k. + relativize (reln [] 0 (cstr_args cdecl)). + eapply arity_spine_to_extended_list => //. + 2:{ rewrite -/(to_extended_list_k _ 0) /pre_case_branch_context. + rewrite /expand_lets_ctx /expand_lets_k_ctx /to_extended_list !to_extended_list_k_subst + !to_extended_list_k_lift_context to_extended_list_k_subst + PCUICLiftSubst.map_subst_instance_to_extended_list_k //. } + rewrite /pre_case_branch_context /subst_let_expand_k. + eexists (subst_instance p.(puinst) (ind_sort idecl)). red. + relativize #|cstr_args cdecl|. + eapply (substitution _ _ _ (List.rev (pparams p)) _ _ (tSort _)); tea. + eapply sppars. + all:rewrite expand_lets_ctx_length. + 2:rewrite subst_context_length subst_instance_length //. + eapply (typing_expand_lets_gen (T:=tSort _)). + rewrite subst_context_length subst_instance_length. + rewrite -/(to_extended_list_k _ _). + rewrite subst_cstr_concl_head. + destruct isdecl. now eapply nth_error_Some_length in H1. + eapply type_mkApps. + econstructor; tea. + rewrite -[subst_instance _ (ind_type idecl)](lift_closed (#|ind_params mdecl| + #|cstr_args cdecl|) 0). + rewrite closedn_subst_instance. + eapply (declared_inductive_closed_type _ _ _ _ _ isdecl). + rewrite (declared_inductive_type isdecl). + rewrite subst_instance_it_mkProd_or_LetIn subst_instance_app + it_mkProd_or_LetIn_app. + have wfs : wf_universe Σ (subst_instance_univ (puinst p) (ind_sort idecl)). + by eapply (on_inductive_sort_inst isdecl _ cu). + have wfparinds : wf_local Σ + (Γ,,, subst_instance (puinst p) (ind_params mdecl),,, + subst_instance (puinst p) (ind_indices idecl)). + { rewrite -app_context_assoc -subst_instance_app_ctx. + eapply weaken_wf_local; tea. + eapply (on_minductive_wf_params_indices_inst isdecl _ cu). } + relativize (#|ind_params mdecl| + #|cstr_args cdecl|). + relativize (to_extended_list_k _ #|cstr_args cdecl|). + eapply typing_spine_to_extended_list_k_app; tea. + eapply isType_it_mkProd_or_LetIn; tea. simpl. + eapply isType_Sort; tea. + 2:{ len. now rewrite PCUICLiftSubst.map_subst_instance_to_extended_list_k. } + 2:{ now len. } + rewrite subst_context_length subst_instance_length lift_it_mkProd_or_LetIn /=. + eapply typing_spine_it_mkProd_or_LetIn_close'; tea. + 3:{ reflexivity. } + 2:{ eapply isType_it_mkProd_or_LetIn; tea. + eapply isType_Sort. + eapply (on_inductive_sort_inst isdecl _ cu). + relativize #|cstr_args cdecl|. + eapply weakening_wf_local => //. now len. } + clear spindices. + unshelve epose proof (ctx_inst_spine_subst _ X0) as sp. + { eapply weakening_wf_local => //. + rewrite -app_context_assoc. apply weaken_wf_local => //. + eapply (wf_arities_context _ _ _ _ isdecl). + apply (on_minductive_wf_params_indices isdecl). } + eapply spine_subst_inst in sp; tea. + 2:{ exact (declared_inductive_wf_global_ext _ _ _ _ isdecl). } + rewrite !subst_instance_app_ctx in sp. + rewrite -app_context_assoc in sp. + eapply spine_subst_subst_first in sp; tea. + 2:eapply subslet_inds; tea. + rewrite app_context_length !subst_instance_length in sp. + rewrite subst_context_app subst_instance_length /= Nat.add_0_r in sp. + rewrite closed_ctx_subst // in sp. + eapply spine_subst_weaken in sp. 3:eapply wfΓ. all:tea. + rewrite app_context_assoc in sp. + rewrite Nat.add_comm in sp |- *; fold indices in sp |- *. + rewrite subst_instance_lift_context in sp. + rewrite (closed_ctx_subst _ _ (lift_context #|cstr_args cdecl| _ _)) in sp. + rewrite Nat.add_comm; eapply closedn_ctx_lift => //. + epose proof (declared_inductive_closed_pars_indices _ isdecl). + rewrite closedn_ctx_app in H0. move/andb_and: H0 => []. + now rewrite closedn_subst_instance_context. + exact sp. + * rewrite Nat.add_0_r. + rewrite subst_cstr_concl_head. + { destruct isdecl. now eapply nth_error_Some_length in H1. } + rewrite subst_let_expand_k_mkApps. cbn. f_equal. + rewrite !map_app. f_equal. + { rewrite -(PCUICLiftSubst.map_subst_instance_to_extended_list_k p.(puinst)). + erewrite map_subst_let_expand_k_to_extended_list_lift. + 2:{ eapply sppars. } + rewrite !map_map_compose. + apply map_ext => t. + rewrite simpl_lift; try lia. + rewrite (Nat.add_comm #|cstr_args cdecl|). + rewrite subst_let_expand_k_lift //. + len => //. len. + { clear spindices. apply ctx_inst_length in X0. + rewrite context_assumptions_rev in X0. len in X0. + } } + { pose proof (positive_cstr_closed_indices wfΣ H). + rewrite map_map_compose. + 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 + !to_extended_list_k_lift_context + !to_extended_list_k_subst + PCUICLiftSubst.map_subst_instance_to_extended_list_k + !to_extended_list_k_subst to_extended_list_k_lift_context //. } + 2:{ eapply spine_subst_smash; tea. + rewrite subst_instance_expand_lets_ctx. + rewrite lift_context_subst_context lift_context_expand_lets_ctx + -subst_instance_lift_context. + rewrite /subst_let_expand_k -map_map_compose. + now exact spindices. } + rewrite {2}/subst_let_expand_k. + rewrite map_lift0. rewrite /indices. + rewrite !map_map_compose. + rewrite Nat.add_comm. + now rewrite /subst_let_expand_k. } Qed. diff --git a/pcuic/theories/PCUICInductives.v b/pcuic/theories/PCUICInductives.v index 8cdfe1dd0..7c3a9ba8b 100644 --- a/pcuic/theories/PCUICInductives.v +++ b/pcuic/theories/PCUICInductives.v @@ -2,6 +2,7 @@ From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICWeakeningEnv PCUICWeakening + PCUICSigmaCalculus PCUICInst PCUICContextSubst PCUICSubstitution PCUICClosed PCUICCumulativity PCUICGeneration PCUICReduction PCUICEquality PCUICConfluence PCUICParallelReductionConfluence PCUICContextConversion PCUICUnivSubstitution @@ -27,46 +28,13 @@ Proof. now rewrite nth_error_map. Qed. -Lemma build_case_predicate_type_spec {cf:checker_flags} Σ ind mdecl idecl pars u ps pty : - forall (o : on_ind_body (lift_typing typing) Σ (inductive_mind ind) mdecl (inductive_ind ind) idecl), - build_case_predicate_type ind mdecl idecl pars u ps = Some pty -> - ∑ parsubst, (context_subst (subst_instance_context u (ind_params mdecl)) pars parsubst * - (pty = it_mkProd_or_LetIn (subst_context parsubst 0 (subst_instance_context u o.(ind_indices))) - (tProd {| binder_name := nNamed (ind_name idecl); binder_relevance := idecl.(ind_relevance) |} - (mkApps (tInd ind u) (map (lift0 #|o.(ind_indices)|) pars ++ to_extended_list o.(ind_indices))) - (tSort ps)))). -Proof. - intros []. unfold build_case_predicate_type. - destruct instantiate_params eqn:Heq=> //. - eapply instantiate_params_make_context_subst in Heq => /=. - destruct destArity eqn:Har => //. - move=> [=] <-. destruct Heq as [ctx' [ty'' [s' [? [? ?]]]]]. - subst t. exists s'. split. apply make_context_subst_spec in H0. - now rewrite List.rev_involutive in H0. - clear onProjections. clear onConstructors. - assert (p.1 = subst_context s' 0 (subst_instance_context u ind_indices)) as ->. - move: H. rewrite ind_arity_eq subst_instance_constr_it_mkProd_or_LetIn. - rewrite decompose_prod_n_assum_it_mkProd app_nil_r => [=]. - move=> Hctx' Hty'. - subst ty'' ctx'. - move: Har. rewrite subst_instance_constr_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. - rewrite destArity_it_mkProd_or_LetIn. simpl. move=> [=] <- /=. - now rewrite app_context_nil_l. - f_equal. rewrite subst_context_length subst_instance_context_length. - simpl. - f_equal. f_equal. f_equal. - unfold to_extended_list. - rewrite to_extended_list_k_subst PCUICSubstitution.map_subst_instance_constr_to_extended_list_k. - reflexivity. -Qed. - Hint Resolve conv_ctx_refl : pcuic. -Definition branch_type ind mdecl (idecl : one_inductive_body) params u p i (br : ident * term * nat) := +(* Definition branch_type ind mdecl (idecl : one_inductive_body) params u p i (br : constructor_body) := let inds := inds ind.(inductive_mind) u mdecl.(ind_bodies) in let '(id, t, ar) := br in - let ty := subst0 inds (subst_instance_constr u t) in - match instantiate_params (subst_instance_context u mdecl.(ind_params)) params ty with + let ty := subst0 inds (subst_instance u t) in + match instantiate_params (subst_instance u mdecl.(ind_params)) params ty with | Some ty => let '(sign, ccl) := decompose_prod_assum [] ty in let nargs := List.length sign in @@ -88,7 +56,7 @@ Proof. Qed. Lemma build_branches_type_lookup {cf:checker_flags} Σ Γ ind mdecl idecl cdecl pars u p (brs : list (nat * term)) btys : - declared_inductive Σ.1 mdecl ind idecl -> + declared_inductive Σ.1 ind mdecl idecl -> map_option_out (build_branches_type ind mdecl idecl pars u p) = Some btys -> All2 (fun br bty => (br.1 = bty.1) * (Σ ;;; Γ |- br.2 : bty.2))%type brs btys -> forall c, nth_error (ind_ctors idecl) c = Some cdecl -> @@ -120,26 +88,24 @@ Qed. Import PCUICEnvironment. -From MetaCoq.PCUIC Require Import PCUICCtxShape. - Lemma branch_type_spec {cf:checker_flags} Σ ind mdecl idecl cdecl pars u p c nargs bty : - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> forall (omib : on_inductive (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl), forall (oib : on_ind_body (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl (inductive_ind ind) idecl), - forall cshape (cs : on_constructor (lift_typing typing) (Σ, ind_universes mdecl) mdecl (inductive_ind ind) idecl (ind_indices oib) cdecl cshape), + forall cdecl (cs : on_constructor (lift_typing typing) (Σ, ind_universes mdecl) mdecl (inductive_ind ind) idecl (ind_indices idecl) cdecl cdecl), branch_type ind mdecl idecl pars u p c cdecl = Some (nargs, bty) -> - nargs = context_assumptions cshape.(cshape_args) /\ + nargs = context_assumptions cdecl.(cstr_args) /\ forall parsubst, - context_subst (subst_instance_context u (PCUICAst.ind_params mdecl)) pars parsubst -> + context_subst (subst_instance u (PCUICAst.ind_params mdecl)) pars parsubst -> let indsubst := (inds (inductive_mind ind) u (ind_bodies mdecl)) in - let nargs' := #|cshape.(cshape_args)| in + let nargs' := #|cdecl.(cstr_args)| in let npars := #|ind_params mdecl| in let substargs := (subst_context parsubst 0 - (subst_context indsubst npars (map_context (subst_instance_constr u) cshape.(cshape_args)))) in + (subst_context indsubst npars (map_context (subst_instance u) cdecl.(cstr_args)))) in bty = it_mkProd_or_LetIn substargs (mkApps (lift0 nargs' p) - (map (subst parsubst nargs' ∘ subst indsubst (nargs' + npars) ∘ subst_instance_constr u) cshape.(cshape_indices) ++ + (map (subst parsubst nargs' ∘ subst indsubst (nargs' + npars) ∘ subst_instance u) cdecl.(cstr_indices) ++ [mkApps (tConstruct ind c u) (map (lift0 nargs') pars ++ to_extended_list substargs)])). @@ -160,24 +126,24 @@ Proof. eapply instantiate_params_make_context_subst in Heq. destruct Heq as [ctx' [ty'' [s' [? [? ?]]]]]. subst t. move: H. - rewrite {1}cstr_eq subst_instance_constr_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. + rewrite {1}cstr_eq subst_instance_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. rewrite -(subst_context_length (PCUICTyping.inds (inductive_mind ind) u (ind_bodies mdecl)) 0). rewrite decompose_prod_n_assum_it_mkProd. move=> H;noconf H. move: brty. - rewrite !subst_context_length !subst_instance_context_length - subst_instance_constr_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn. - rewrite subst_context_length subst_instance_context_length Nat.add_0_r. - rewrite subst_instance_constr_mkApps !subst_mkApps. + rewrite !subst_context_length !subst_instance_length + subst_instance_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn. + rewrite subst_context_length subst_instance_length Nat.add_0_r. + rewrite subst_instance_mkApps !subst_mkApps. rewrite Nat.add_0_r. assert((subst s' #|args| (subst (PCUICTyping.inds (inductive_mind ind) u (PCUICAst.ind_bodies mdecl)) (#|args| + #|PCUICAst.ind_params mdecl|) - (subst_instance_constr u cstr_concl_head))) = tInd ind u). - rewrite /head. simpl subst_instance_constr. + (subst_instance u cstr_concl_head))) = tInd ind u). + rewrite /head. simpl subst_instance. erewrite (subst_rel_eq _ _ (#|ind_bodies mdecl| - S (inductive_ind ind))); try lia. 2:{ rewrite inds_spec nth_error_rev. rewrite List.rev_length mapi_length; try lia. @@ -204,14 +170,14 @@ Proof. rewrite rev_involutive in csubst. pose proof (context_subst_fun csubst Hpars). subst s'. clear csubst. f_equal. - rewrite !subst_context_length subst_instance_context_length. + rewrite !subst_context_length subst_instance_length. f_equal. f_equal. f_equal. f_equal. f_equal. rewrite -(map_map_compose _ _ _ _ (subst _ _ ∘ subst _ _)). rewrite subst_instance_to_extended_list_k. rewrite -map_map_compose. - rewrite -to_extended_list_k_map_subst. rewrite subst_instance_context_length; lia. + rewrite -to_extended_list_k_map_subst. rewrite subst_instance_length; lia. now rewrite (subst_to_extended_list_k _ _ pars). -Qed. +Qed. *) Lemma instantiate_inds {cf:checker_flags} Σ u mind mdecl : wf Σ.1 -> @@ -223,8 +189,8 @@ Lemma instantiate_inds {cf:checker_flags} Σ u mind mdecl : inds mind u (ind_bodies mdecl). Proof. intros wfΣ declm cu. - rewrite subst_instance_inds. - f_equal. eapply subst_instance_instance_id; eauto. + rewrite subst_instance_inds. + f_equal. eapply subst_instance_id_mdecl; eauto. Qed. Lemma subst_inds_concl_head ind u mdecl (arity : context) : @@ -232,11 +198,11 @@ Lemma subst_inds_concl_head ind u mdecl (arity : context) : let s := (inds (inductive_mind ind) u (ind_bodies mdecl)) in inductive_ind ind < #|ind_bodies mdecl| -> subst s (#|arity| + #|ind_params mdecl|) - (subst_instance_constr u head) + (subst_instance u head) = tInd ind u. Proof. intros. - subst head. simpl subst_instance_constr. + subst head. simpl subst_instance. rewrite (subst_rel_eq _ _ (#|ind_bodies mdecl| - S (inductive_ind ind)) (tInd ind u)) //; try lia. subst s. rewrite inds_spec rev_mapi nth_error_mapi /=. elim nth_error_spec. @@ -246,36 +212,38 @@ Proof. Qed. -Lemma on_minductive_wf_params_indices {cf : checker_flags} (Σ : global_env) mdecl ind idecl : - wf Σ -> - declared_minductive Σ (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) - mdecl (inductive_ind ind) idecl), - wf_local (Σ, ind_universes mdecl) (ind_params mdecl ,,, ind_indices oib). +Lemma declared_inductive_lookup_inductive {Σ ind mdecl idecl} : + declared_inductive Σ ind mdecl idecl -> + lookup_inductive Σ ind = Some (mdecl, idecl). Proof. - intros. - eapply on_declared_minductive in H; auto. - pose proof (oib.(onArity)). - rewrite oib.(ind_arity_eq) in X0. - destruct X0 as [s Hs]. - rewrite -it_mkProd_or_LetIn_app in Hs. - eapply it_mkProd_or_LetIn_wf_local in Hs. - now rewrite app_context_nil_l in Hs. now simpl. + rewrite /declared_inductive /lookup_inductive. + intros []. red in H. now rewrite /lookup_minductive H H0. Qed. -Lemma on_minductive_wf_params_indices_inst {cf : checker_flags} (Σ : global_env × universes_decl) - mdecl (u : Instance.t) ind idecl : - wf Σ.1 -> - declared_minductive Σ.1 (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) - mdecl (inductive_ind ind) idecl), - consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_local Σ (subst_instance_context u (ind_params mdecl ,,, ind_indices oib)). -Proof. - intros. - eapply (wf_local_instantiate _ (InductiveDecl mdecl)); eauto. - now apply on_minductive_wf_params_indices. -Qed. +Section OnInductives. + Context {cf : checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl ind idecl} + (decli : declared_inductive Σ ind mdecl idecl). + + Lemma on_minductive_wf_params_indices : wf_local (Σ, ind_universes mdecl) (ind_params mdecl ,,, ind_indices idecl). + Proof. + eapply on_declared_inductive in decli as [onmind oib]. + pose proof (oib.(onArity)). + rewrite oib.(ind_arity_eq) in X. + destruct X as [s Hs]. + rewrite -it_mkProd_or_LetIn_app in Hs. + eapply it_mkProd_or_LetIn_wf_local in Hs. + now rewrite app_context_nil_l in Hs. now simpl. + Qed. + + Lemma declared_inductive_type : + ind_type idecl = it_mkProd_or_LetIn (ind_params mdecl ,,, ind_indices idecl) (tSort (ind_sort idecl)). + Proof. + eapply on_declared_inductive in decli as [onmind oib]. + rewrite oib.(ind_arity_eq). + now rewrite -it_mkProd_or_LetIn_app. + Qed. + +End OnInductives. Lemma isType_intro {cf:checker_flags} {Σ Γ T s} : Σ ;;; Γ |- T : tSort s -> isType Σ Γ T. Proof. @@ -283,85 +251,113 @@ Proof. Qed. Hint Resolve isType_intro : pcuic. -Lemma on_inductive_inst {cf:checker_flags} Σ Γ ind u mdecl idecl : - wf Σ.1 -> - wf_local Σ Γ -> - declared_minductive Σ.1 (inductive_mind ind) mdecl -> - on_inductive (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl), - consistent_instance_ext Σ (ind_universes mdecl) u -> - isType Σ Γ (it_mkProd_or_LetIn (subst_instance_context u (ind_params mdecl ,,, oib.(ind_indices))) - (tSort (subst_instance_univ u oib.(ind_sort)))). -Proof. - move=> wfΣ wfΓ declm oi oib cext. - pose proof (oib.(onArity)) as ar. - rewrite oib.(ind_arity_eq) in ar. - destruct ar as [s ar]. - eapply isType_weaken => //. - rewrite -(subst_instance_constr_it_mkProd_or_LetIn u _ (tSort _)). - rewrite -it_mkProd_or_LetIn_app in ar. - eapply (typing_subst_instance_decl Σ [] _ _ _ (InductiveDecl mdecl) u) in ar. - all:pcuic. -Qed. - -Lemma on_inductive_sort {cf:checker_flags} {Σ Γ ind mdecl idecl} : - wf Σ.1 -> - wf_local Σ Γ -> - declared_minductive Σ.1 (inductive_mind ind) mdecl -> - on_inductive (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl), - wf_universe (Σ.1, ind_universes mdecl) (ind_sort oib). -Proof. - move=> wfΣ wfΓ declm oi oib. - pose proof (oib.(onArity)) as ar. - rewrite oib.(ind_arity_eq) in ar. - destruct ar as [s ar]. - eapply typing_wf_universes in ar; auto. - move/andP: ar => []. - rewrite wf_universes_it_mkProd_or_LetIn => /andP [] _. - now rewrite wf_universes_it_mkProd_or_LetIn => /andP [] _ /= /wf_universe_reflect. -Qed. - -Lemma on_inductive_sort_inst {cf:checker_flags} {Σ Γ ind mdecl idecl u} : - wf Σ.1 -> - wf_local Σ Γ -> - declared_minductive Σ.1 (inductive_mind ind) mdecl -> - on_inductive (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl - (inductive_ind ind) idecl), - consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_universe Σ (subst_instance u (ind_sort oib)). -Proof. - move=> wfΣ wfΓ declm oi oib cu. - generalize (on_inductive_sort wfΣ wfΓ declm oi oib) => wf. - destruct Σ. - eapply wf_universe_instantiate; eauto. - now eapply consistent_instance_ext_wf. - eapply sub_context_set_trans. - eapply (weaken_lookup_on_global_env'' _ _ (InductiveDecl mdecl)); eauto. - eapply global_context_set_sub_ext. -Qed. - -Lemma nth_errror_arities_context {cf:checker_flags} (Σ : global_env_ext) mdecl ind idecl decl : - wf Σ.1 -> - declared_inductive Σ mdecl ind idecl -> - on_inductive (lift_typing typing) (Σ.1, ind_universes mdecl) - (inductive_mind ind) mdecl -> - on_ind_body (lift_typing typing) (Σ.1, ind_universes mdecl) - (inductive_mind ind) mdecl (inductive_ind ind) idecl -> - nth_error (arities_context (ind_bodies mdecl)) (#|ind_bodies mdecl| - S (inductive_ind ind)) = Some decl -> - decl.(decl_type) = idecl.(ind_type). -Proof. - move=> wfΣ decli oni onib. - unfold arities_context. - rewrite nth_error_rev_map. - destruct decli as [declm decli]. now apply nth_error_Some_length in decli. - destruct nth_error eqn:Heq; try discriminate. - destruct decli. rewrite H0 in Heq. noconf Heq. - simpl. move=> [] <-. now simpl. -Qed. +Section OnInductives. + Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {mdecl ind idecl} + (decli : declared_inductive Σ ind mdecl idecl). + + Lemma on_minductive_wf_params_indices_inst (u : Instance.t) : + consistent_instance_ext Σ (ind_universes mdecl) u -> + wf_local Σ (subst_instance u (ind_params mdecl ,,, ind_indices idecl)). + Proof. + intros. + eapply (wf_local_instantiate _ (InductiveDecl mdecl)); eauto. eapply decli. + now eapply on_minductive_wf_params_indices. + Qed. + + Lemma on_inductive_inst Γ u : + wf_local Σ Γ -> + consistent_instance_ext Σ (ind_universes mdecl) u -> + isType Σ Γ (it_mkProd_or_LetIn (subst_instance u (ind_params mdecl ,,, idecl.(ind_indices))) + (tSort (subst_instance_univ u idecl.(ind_sort)))). + Proof. + move=> wfΓ cext. + destruct (on_declared_inductive decli) as [onmind oib]. + pose proof (oib.(onArity)) as ar. + rewrite oib.(ind_arity_eq) in ar. + destruct ar as [s ar]. + eapply isType_weaken => //. + rewrite -(subst_instance_it_mkProd_or_LetIn u _ (tSort _)). + rewrite -it_mkProd_or_LetIn_app in ar. + eapply (typing_subst_instance_decl Σ [] _ _ _ (InductiveDecl mdecl) u) in ar. + all:pcuic. eapply decli. + Qed. + + Lemma declared_inductive_valid_type Γ u : + wf_local Σ Γ -> + consistent_instance_ext Σ (ind_universes mdecl) u -> + isType Σ Γ (subst_instance u idecl.(ind_type)). + Proof. + move=> wfΓ cext. + destruct (on_declared_inductive decli) as [onmind oib]. + pose proof (oib.(onArity)) as ar. + destruct ar as [s ar]. + eapply isType_weaken => //. + eapply (typing_subst_instance_decl Σ [] _ _ _ (InductiveDecl mdecl) u) in ar. + all:pcuic. eapply decli. + Qed. + + Local Definition oi := (on_declared_inductive decli).1. + Local Definition oib := (on_declared_inductive decli).2. + + Lemma on_inductive_sort : wf_universe (Σ.1, ind_universes mdecl) (ind_sort idecl). + Proof. + pose proof (oib.(onArity)) as ar. + rewrite oib.(ind_arity_eq) in ar. + destruct ar as [s ar]. + eapply typing_wf_universes in ar; auto. + move/andP: ar => []. + rewrite wf_universes_it_mkProd_or_LetIn => /andP [] _. + now rewrite wf_universes_it_mkProd_or_LetIn => /andP [] _ /= /wf_universe_reflect. + Qed. + + Lemma on_inductive_sort_inst u : + consistent_instance_ext Σ (ind_universes mdecl) u -> + wf_universe Σ (subst_instance u (ind_sort idecl)). + Proof. + generalize on_inductive_sort => wf. + destruct Σ. intros cu. + eapply wf_universe_instantiate; eauto. + now eapply consistent_instance_ext_wf. + eapply sub_context_set_trans. + eapply (weaken_lookup_on_global_env'' _ _ (InductiveDecl mdecl)); eauto. + eapply decli. + eapply global_context_set_sub_ext. + Qed. + + Lemma nth_errror_arities_context decl : + nth_error (arities_context (ind_bodies mdecl)) (#|ind_bodies mdecl| - S (inductive_ind ind)) = Some decl -> + decl.(decl_type) = idecl.(ind_type). + Proof. + unfold arities_context. + rewrite nth_error_rev_map. + destruct decli as [declm decli']. + now apply nth_error_Some_length in decli'. + destruct nth_error eqn:Heq; try discriminate. + destruct decli. rewrite H0 in Heq. noconf Heq. + simpl. move=> [] <-. now simpl. + Qed. + + Lemma isType_mkApps_Ind {Γ puinst args inst} : + consistent_instance_ext Σ (ind_universes mdecl) puinst -> + spine_subst Σ Γ args inst (subst_instance puinst (ind_params mdecl ,,, ind_indices idecl)) -> + Σ ;;; Γ |- mkApps (tInd ind puinst) args : tSort (subst_instance puinst (ind_sort idecl)). + Proof. + intros cu sp. + eapply PCUICGeneration.type_mkApps; tea. + econstructor; eauto. apply sp. + rewrite (declared_inductive_type decli). + rewrite subst_instance_it_mkProd_or_LetIn. + eapply wf_arity_spine_typing_spine; tea. + split. + rewrite -subst_instance_it_mkProd_or_LetIn. + rewrite -(declared_inductive_type decli). + eapply declared_inductive_valid_type; tea. + apply sp. + eapply arity_spine_it_mkProd_or_LetIn_Sort. + 2:reflexivity. 2:exact sp. + now eapply on_inductive_sort_inst. + Qed. +End OnInductives. (** * Projections *) @@ -371,8 +367,8 @@ Fixpoint projs_inst ind npars k x : list term := | S k' => tProj (ind, npars, k') x :: projs_inst ind npars k' x end. -Lemma subst_instance_constr_projs u i p n : - map (subst_instance_constr u) (projs i p n) = projs i p n. +Lemma subst_instance_projs u i p n : + map (subst_instance u) (projs i p n) = projs i p n. Proof. induction n; simpl; auto. f_equal; auto. Qed. @@ -396,31 +392,30 @@ Qed. Lemma subslet_projs {cf:checker_flags} (Σ : global_env_ext) i mdecl idecl : forall (wfΣ : wf Σ.1) - (Hdecl : declared_inductive Σ.1 mdecl i idecl), - let oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ Hdecl in - match ind_cshapes oib return Type with + (Hdecl : 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 oib) cs -> + idecl (ind_indices idecl) cs -> forall Γ t u, let indsubst := inds (inductive_mind i) u (ind_bodies mdecl) in untyped_subslet Γ - (projs_inst i (ind_npars mdecl) (context_assumptions (cshape_args cs)) t) + (projs_inst i (ind_npars mdecl) (context_assumptions (cstr_args cs)) t) (smash_context [] (subst_context (inds (inductive_mind i) u (ind_bodies mdecl)) - #|ind_params mdecl| (subst_instance_context u (cshape_args cs)))) + #|ind_params mdecl| (subst_instance u (cstr_args cs)))) | _ => True end. Proof. - intros wfΣ Hdecl oib. - destruct ind_cshapes as [|cs []] eqn:Heq; trivial. + intros wfΣ Hdecl. + destruct ind_ctors as [|cs []] eqn:Heq; trivial. intros onp. simpl. intros Γ t u. rewrite (smash_context_subst []). destruct onp. assert (#|PCUICEnvironment.ind_projs idecl| >= - PCUICEnvironment.context_assumptions (cshape_args cs)). lia. + PCUICEnvironment.context_assumptions (cstr_args cs)). lia. clear on_projs_all. - induction (cshape_args cs) as [|[? [] ?] ?]. + induction (cstr_args cs) as [|[? [] ?] ?]. - simpl. constructor. - simpl. apply IHc. now simpl in H. - simpl. rewrite smash_context_acc /=. @@ -445,7 +440,7 @@ Proof. Qed. Lemma projs_inst_length ind npars k x : #|projs_inst ind npars k x| = k. -Proof. induction k; simpl; auto. Qed. +Proof. induction k; simpl; auto. lia. Qed. Hint Rewrite projs_inst_length : len. @@ -457,8 +452,8 @@ Proof. f_equal; auto. Qed. -Lemma projs_subst_instance_constr u ind npars k : - map (subst_instance_constr u) (projs ind npars k) = projs ind npars k. +Lemma projs_subst_instance u ind npars k : + map (subst_instance u) (projs ind npars k) = projs ind npars k. Proof. induction k; simpl; auto. f_equal; auto. Qed. @@ -500,41 +495,68 @@ Definition projection_type' mdecl ind k ty := (subst (extended_subst (ind_params mdecl) 0) (S k) (lift 1 k (subst indsubst (k + #|ind_params mdecl|) ty)))). -Definition projection_decl_type mdecl ind k ty := +Definition projection_decls_type mdecl ind k ty := let u := PCUICLookup.abstract_instance (PCUICEnvironment.ind_universes mdecl) in let indsubst := inds (inductive_mind ind) u (ind_bodies mdecl) in let projsubst := projs ind (ind_npars mdecl) k in subst indsubst (S (ind_npars mdecl)) (subst0 projsubst (lift 1 k ty)). -Lemma on_projections_decl {cf:checker_flags} {Σ mdecl ind idecl cs} : - forall (Hdecl : declared_inductive Σ mdecl ind idecl) (wfΣ : wf Σ), - let oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ Hdecl in +Lemma on_projections_decl {cf:checker_flags} {mdecl ind idecl cs} : let u := PCUICLookup.abstract_instance (ind_universes mdecl) in - on_projections mdecl (inductive_mind ind) (inductive_ind ind) idecl (oib.(ind_indices)) cs -> + on_projections mdecl (inductive_mind ind) (inductive_ind ind) idecl (idecl.(ind_indices)) cs -> Alli (fun i decl => ∑ pdecl, - (nth_error (ind_projs idecl) (context_assumptions (cshape_args cs) - S i) = Some pdecl)) - 0 (smash_context [] cs.(cshape_args)). + (nth_error (ind_projs idecl) (context_assumptions (cstr_args cs) - S i) = Some pdecl)) + 0 (smash_context [] cs.(cstr_args)). Proof. intros. destruct X as [_ _ _ on_projs_all on_projs]. eapply forall_nth_error_Alli. intros. - pose proof (snd (nth_error_Some' (ind_projs idecl) (context_assumptions (cshape_args cs) - S i))). + pose proof (snd (nth_error_Some' (ind_projs idecl) (context_assumptions (cstr_args cs) - S i))). apply X. eapply nth_error_Some_length in H. autorewrite with len in H. simpl in H; lia. Qed. +Lemma subst_id s Γ t : + closedn #|s| t -> + assumption_context Γ -> + s = List.rev (to_extended_list Γ) -> + subst s 0 t = t. +Proof. + intros cl ass eq. + autorewrite with sigma. + rewrite -{2}(subst_ids t). + eapply inst_ext_closed; eauto. + intros. + unfold ids, subst_consn. simpl. + destruct (snd (nth_error_Some' s x) H). rewrite e. + subst s. + rewrite /to_extended_list /to_extended_list_k in e. + rewrite List.rev_length in cl, H. autorewrite with len in *. + rewrite reln_alt_eq in e. + rewrite app_nil_r List.rev_involutive in e. + clear -ass e. revert e. + rewrite -{2}(Nat.add_0_r x). + generalize 0. + induction Γ in x, ass, x0 |- * => n. + - simpl in *. rewrite nth_error_nil => //. + - depelim ass; simpl. + destruct x; simpl in *; try congruence. + move=> e; specialize (IHΓ ass); simpl in e. + specialize (IHΓ _ _ _ e). subst x0. f_equal. lia. +Qed. + + (* Well, it's a smash_context mess! *) Lemma declared_projections {cf:checker_flags} {Σ : global_env_ext} {mdecl ind idecl} : - forall (wfΣ : wf Σ.1) (Hdecl : declared_inductive Σ mdecl ind idecl), - let oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ Hdecl in + forall (wfΣ : wf Σ.1) (Hdecl : declared_inductive Σ ind mdecl idecl), let u := PCUICLookup.abstract_instance (ind_universes mdecl) in - match ind_cshapes oib return Type with + match ind_ctors idecl return Type with | [cs] => on_projections mdecl (inductive_mind ind) (inductive_ind ind) - idecl (ind_indices oib) cs -> + idecl (ind_indices idecl) cs -> Alli (fun i pdecl => isType (Σ.1, ind_universes mdecl) ((vass {| binder_name := nAnon; binder_relevance := idecl.(ind_relevance) |} @@ -542,11 +564,11 @@ Lemma declared_projections {cf:checker_flags} {Σ : global_env_ext} {mdecl ind i (to_extended_list (smash_context [] (ind_params mdecl))))):: smash_context [] (ind_params mdecl)) pdecl.2 * ∑ decl, - (nth_error (smash_context [] (cshape_args cs)) - (context_assumptions (cshape_args cs) - S i) = Some decl) * + (nth_error (smash_context [] (cstr_args cs)) + (context_assumptions (cstr_args cs) - S i) = Some decl) * wf_local (Σ.1, ind_universes mdecl) (arities_context (ind_bodies mdecl) ,,, - ind_params mdecl ,,, smash_context [] (cshape_args cs)) * + ind_params mdecl ,,, smash_context [] (cstr_args cs)) * (projection_type mdecl ind i decl.(decl_type) = pdecl.2) * (projection_type mdecl ind i decl.(decl_type) = projection_type' mdecl ind i decl.(decl_type)))%type @@ -554,9 +576,10 @@ Lemma declared_projections {cf:checker_flags} {Σ : global_env_ext} {mdecl ind i | _ => True end. Proof. - intros wfΣ decli oib u. - set(indb := {| binder_name := _ |}) in *. - destruct (ind_cshapes oib) as [|? []] eqn:Heq; try contradiction; auto. + intros wfΣ decli u. + set oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ decli. + set indb := {| binder_name := _ |}. + destruct (ind_ctors idecl) as [|? []] eqn:Heq; try contradiction; auto. intros onps. eapply forall_nth_error_Alli. set (eos := CoreTactics.the_end_of_the_section). @@ -565,22 +588,22 @@ Proof. set (p := ((ind, ind_npars mdecl), i)). intros pdecl Hp. simpl. set(isdecl := (conj decli (conj Hp eq_refl)) : - declared_projection Σ.1 mdecl idecl p pdecl). - destruct (on_declared_projection wfΣ isdecl) as [oni onp]. + declared_projection Σ.1 p mdecl idecl pdecl). + destruct (on_declared_projection isdecl) as [oni onp]. set (declared_inductive_inv _ _ _ _) as oib' in onp. + rewrite Heq in onp. change oib' with oib in *. clear oib'. - simpl in oib. + simpl in onp. have onpars := onParams (declared_minductive_inv weaken_env_prop_typing wfΣ wfΣ decli.p1). have parslen := onNpars (declared_minductive_inv weaken_env_prop_typing wfΣ wfΣ decli.p1). - simpl in onp. rewrite Heq in onp. + simpl in onp. destruct onp as [[[wfargs onProjs] Hp2] onp]. red in onp. destruct (nth_error (smash_context [] _) _) eqn:Heq'; try contradiction. destruct onp as [onna onp]. rewrite {}onp. apply on_projections_decl in onps. - clearbody oib. - assert(projslen : #|ind_projs idecl| = (context_assumptions (cshape_args c))). + assert(projslen : #|ind_projs idecl| = (context_assumptions (cstr_args c))). { now destruct onProjs. } assert (some_proj :#|ind_projs idecl| > 0). { destruct isdecl as [ [] []]. now apply nth_error_Some_length in H1. } @@ -588,6 +611,7 @@ Proof. assert (wfarities : wf_local (Σ.1, ind_universes mdecl) (arities_context (ind_bodies mdecl))). { eapply wf_arities_context; eauto. } + destruct (ind_cunivs oib) as [|? []] eqn:hequ => //. eapply PCUICClosed.sorts_local_ctx_All_local_env in wfargs. 2:{ eapply All_local_env_app. split; auto. red in onpars. eapply (All_local_env_impl _ _ _ onpars). @@ -604,11 +628,11 @@ Proof. rewrite subst_context_app. rewrite (closed_ctx_subst _ _ (ind_params mdecl)). red in onpars. eapply closed_wf_local; [|eauto]. auto. - assert (parsu : subst_instance_context u (ind_params mdecl) = ind_params mdecl). - { red in onpars. eapply (subst_instance_context_id (Σ.1, ind_universes mdecl)). eauto. + assert (parsu : subst_instance u (ind_params mdecl) = ind_params mdecl). + { red in onpars. eapply (subst_instance_id (Σ.1, ind_universes mdecl)). eauto. eapply declared_inductive_wf_ext_wk; eauto with pcuic. auto. } - assert (sortu : subst_instance_univ u (ind_sort oib) = ind_sort oib). - { apply subst_instance_ind_sort_id; eauto. } + assert (sortu : subst_instance u (ind_sort idecl) = ind_sort idecl). + { apply (subst_instance_ind_sort_id Σ mdecl ind idecl); eauto. } pose proof (spine_subst_to_extended_list_k (Σ.1, ind_universes mdecl) (ind_params mdecl) []). forward X; auto. @@ -618,30 +642,30 @@ Proof. red in onpars. eapply closed_wf_local; [|eauto]. auto. assert(wf_local (Σ.1, ind_universes mdecl) (ind_params mdecl ,, vass {| binder_name := nAnon; binder_relevance := idecl.(ind_relevance) |} (mkApps (tInd ind u) (to_extended_list (ind_params mdecl))))). - { constructor. auto. red. exists (ind_sort oib). + { constructor. auto. red. exists (ind_sort idecl). eapply type_mkApps. econstructor; eauto. destruct isdecl as []; eauto. subst u. eapply consistent_instance_ext_abstract_instance; eauto with pcuic. eapply declared_inductive_wf_global_ext; eauto with pcuic. rewrite (ind_arity_eq oib). - rewrite subst_instance_constr_it_mkProd_or_LetIn. + rewrite subst_instance_it_mkProd_or_LetIn. rewrite -(app_nil_r (to_extended_list _)). eapply typing_spine_it_mkProd_or_LetIn'; auto. rewrite parsu. eapply X. constructor. pose proof (onArity oib). eapply isType_Sort. 2:pcuic. - eapply (on_inductive_sort wfΣ); eauto. + eapply on_inductive_sort; eauto. simpl in oib. pose proof (onProjs.(on_projs_noidx _ _ _ _ _ _)). - destruct (ind_indices oib); simpl in H; try discriminate. - simpl. rewrite sortu. reflexivity. - rewrite -subst_instance_constr_it_mkProd_or_LetIn. + destruct (ind_indices idecl); simpl in H; try discriminate. + simpl. rewrite [subst_instance_univ _ _]sortu. reflexivity. + rewrite -subst_instance_it_mkProd_or_LetIn. pose proof (onArity oib). rewrite -(oib.(ind_arity_eq)). destruct X0 as [s Hs]. exists s. eapply (weaken_ctx (Γ:=[])); auto. rewrite (subst_instance_ind_type_id Σ.1 _ ind); auto. } intros wf. - generalize (weakening_wf_local _ _ _ [_] _ wf X0). + generalize (weakening_wf_local (Γ'':=[_]) wf X0). simpl; clear X0 wf. move/wf_local_smash_context => /=. rewrite smash_context_app /= smash_context_acc. @@ -654,9 +678,11 @@ Proof. (PCUICEnvironment.ind_npars mdecl) i)) in *. rewrite lift_context_app. simpl. rewrite [subst_context _ _ (_ ++ _)]subst_context_app. + rewrite lift_context_length /=. simpl. unfold app_context. simpl. - unfold map_decl. simpl. rewrite lift_mkApps. simpl. - rewrite {3}/subst_context /fold_context /= /map_decl /= subst_mkApps /=. + rewrite lift_context_snoc /= /lift_decl /map_decl /=. + simpl. rewrite lift_mkApps. simpl. + rewrite {3}/subst_context /fold_context_k /= /map_decl /= subst_mkApps /=. rewrite /to_extended_list lift_to_extended_list_k. rewrite extended_subst_to_extended_list_k. fold (to_extended_list (smash_context [] (ind_params mdecl))). @@ -673,25 +699,22 @@ Proof. eapply (closedn_ctx_subst 0 #|ind_params mdecl|). now unfold indsubst; rewrite inds_length. unfold indsubst. - eapply declared_minductive_closed_inds. - 2:destruct isdecl as [ [] ?]; eauto. eauto. } + eapply declared_minductive_closed_inds. eauto. } rewrite -app_assoc in wfl. apply All_local_env_app_inv in wfl as [wfctx wfsargs]. rewrite smash_context_app in Heq'. rewrite smash_context_acc in Heq'. rewrite nth_error_app_lt in Heq'. autorewrite with len. lia. - set (idx := context_assumptions (cshape_args c) - S i) in *. + set (idx := context_assumptions (cstr_args c) - S i) in *. unshelve epose proof (nth_error_All_local_env (n:=idx) _ wfsargs). - autorewrite with len. rewrite /lift_context /subst_context !context_assumptions_fold. - subst idx; lia. - destruct (nth_error (subst_context _ 1 _) idx) as [c1|] eqn:hidx. - simpl in X0. unfold on_local_decl in X0. - assert(decl_body c1 = None). + autorewrite with len. simpl. lia. + destruct (nth_error (subst_context _ 1 _) idx) as [c2|] eqn:hidx. + simpl in X0. red in X0. cbn in X0. + assert(decl_body c2 = None). { apply nth_error_assumption_context in hidx; auto. rewrite /subst_context /lift_context. apply assumption_context_fold, smash_context_assumption_context. constructor. } - red in X0. rewrite H in X0. 2:{ simpl in X0; contradiction. } destruct X0 as [s Hs]. eapply (substitution (Σ.1, ind_universes mdecl) (_ :: _) (skipn _ _) projsubst []) @@ -716,7 +739,7 @@ Proof. assert(clarg : closedn (i + #|ind_params mdecl| + #|ind_bodies mdecl|) (decl_type arg)). { assert(wf_local (Σ.1, ind_universes mdecl) (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, - smash_context [] (cshape_args c))). + smash_context [] (cstr_args c))). apply All_local_env_app; split; auto. now apply All_local_env_app_inv in wfargs as [wfindpars wfargs]. apply wf_local_rel_smash_context; auto. @@ -732,9 +755,7 @@ Proof. destruct ind as [mind ind]; simpl in *. autorewrite with len. simpl. revert Hs. - assert(context_assumptions (cshape_args c) - S idx = i) as -> by lia. - rewrite !context_assumptions_fold. - assert(context_assumptions (cshape_args c) - S idx + 1 = S i) as -> by lia. + assert(context_assumptions (cstr_args c) - S idx = i) as -> by lia. intros Hs. assert (projection_type mdecl {| inductive_mind := mind; inductive_ind := ind |} i (decl_type arg) = @@ -749,8 +770,8 @@ Proof. { clear. subst projsubst. induction i; simpl; auto. f_equal. auto. } rewrite /projsubst projs_length. - replace (context_assumptions (cshape_args c) - S idx + 1) with - (context_assumptions (cshape_args c) - idx) by lia. + replace (context_assumptions (cstr_args c) - S idx + 1) with + (context_assumptions (cstr_args c) - idx) by lia. simpl in idx. epose proof (commut_lift_subst_rec _ _ 1 (i + ind_npars mdecl) i). rewrite -Nat.add_1_r Nat.add_assoc. erewrite <-H0. 2:lia. @@ -769,14 +790,15 @@ Proof. rewrite lift_closed; auto. apply (closedn_subst _ 0). unfold indsubst. - eapply (declared_minductive_closed_inds _ {| inductive_mind := mind; - inductive_ind := ind |}). - 2:destruct isdecl as [[] ?]; eauto. auto. + eapply (declared_minductive_closed_inds decli). simpl. eapply subject_closed in Hs. now rewrite /indsubst inds_length. auto. } split. unfold projection_type in H0. - rewrite H0. exists s; auto. + rewrite H0. exists s; auto. red. + rewrite -/indb in Hs. + rewrite /projection_type' -/indb -/indsubst -/projsubst. + now rewrite Nat.add_1_r in Hs. exists arg. intuition auto. apply wf_local_smash_end; auto. @@ -785,7 +807,7 @@ Proof. clear -wfΣ parslen onps projslen some_proj IH Hp2 decli. rewrite (smash_context_lift []). rewrite (smash_context_subst []). - rewrite -(firstn_skipn (S idx) (smash_context [] (cshape_args c))). + rewrite -(firstn_skipn (S idx) (smash_context [] (cstr_args c))). rewrite subst_context_app lift_context_app subst_context_app. autorewrite with len. rewrite skipn_all_app_eq. @@ -793,8 +815,8 @@ Proof. rewrite firstn_length_le; auto. rewrite smash_context_length. simpl. lia. induction i. subst idx. - - assert (S (context_assumptions (cshape_args c) - 1) = - (context_assumptions (cshape_args c))) as -> by lia. + - assert (S (context_assumptions (cstr_args c) - 1) = + (context_assumptions (cstr_args c))) as -> by lia. rewrite skipn_all2. autorewrite with len; simpl; auto. constructor. @@ -802,8 +824,8 @@ Proof. intros. eapply (IH i0). lia. auto. forward IHi by lia. simpl in IHi. subst idx. - destruct (skipn (S (context_assumptions (cshape_args c) - S (S i))) - (smash_context [] (cshape_args c))) eqn:eqargs. + destruct (skipn (S (context_assumptions (cstr_args c) - S (S i))) + (smash_context [] (cstr_args c))) eqn:eqargs. apply (f_equal (@length _)) in eqargs. autorewrite with len in eqargs. rewrite skipn_length in eqargs. autorewrite with len. simpl; lia. @@ -812,14 +834,14 @@ Proof. simpl. destruct c0 as [? [] ?]. * simpl in eqargs. - pose proof (@smash_context_assumption_context [] (cshape_args c)). + pose proof (@smash_context_assumption_context [] (cstr_args c)). forward H by constructor. eapply assumption_context_skipn in H. rewrite -> eqargs in H. elimtype False; inv H. * apply skipn_eq_cons in eqargs as [Hnth eqargs]. constructor. - + replace (S (S (context_assumptions (cshape_args c) - S (S i)))) - with (S (context_assumptions (cshape_args c) - S i)) in eqargs by lia. + + replace (S (S (context_assumptions (cstr_args c) - S (S i)))) + with (S (context_assumptions (cstr_args c) - S i)) in eqargs by lia. rewrite eqargs in IHi. apply IHi. + rewrite /lift_decl /=. autorewrite with len. @@ -831,8 +853,8 @@ Proof. autorewrite with len in eqargs. simpl in eqargs. eapply nth_error_alli in onps; eauto. simpl in onps. destruct onps as [pdecl Hnth']. - replace ((context_assumptions (cshape_args c) - - S (S (context_assumptions (cshape_args c) - S (S i))))) + replace ((context_assumptions (cstr_args c) - + S (S (context_assumptions (cstr_args c) - S (S i))))) with i in eqargs, Hnth' by lia. rewrite -eqargs. rewrite /lift_decl /subst_decl. simpl. autorewrite with len. @@ -850,13 +872,13 @@ Proof. reflexivity. autorewrite with len. simpl. rewrite context_assumptions_smash_context /= //. - assert(subst_instance_constr u pdecl.2 = pdecl.2) as ->. + assert(subst_instance u pdecl.2 = pdecl.2) as ->. { eapply (isType_subst_instance_id (Σ.1, ind_universes mdecl)); eauto with pcuic. eapply declared_inductive_wf_ext_wk; eauto with pcuic. } destruct IH as [isTy [decl [[[nthdecl _] eqpdecl] ptyeq]]]. move ptyeq at bottom. - replace (S (context_assumptions (cshape_args c) - S (S i))) with - (context_assumptions (cshape_args c) - S i) in Hnth by lia. + replace (S (context_assumptions (cstr_args c) - S (S i))) with + (context_assumptions (cstr_args c) - S i) in Hnth by lia. rewrite nthdecl in Hnth. noconf Hnth. simpl in ptyeq. rewrite -eqpdecl. simpl. rewrite ptyeq. unfold projection_type'. @@ -870,7 +892,7 @@ Proof. epose proof (commut_lift_subst_rec _ _ 1 (i + #|ind_params mdecl|) i). erewrite H in isTy by lia. rewrite H; try lia. - rewrite (PCUICSigmaCalculus.subst_id _ (({| + rewrite (subst_id _ (({| decl_name := indb; decl_body := None; decl_type := mkApps @@ -891,7 +913,7 @@ Qed. Lemma declared_projection_type {cf:checker_flags} {Σ : global_env_ext} {mdecl idecl p pdecl} : wf Σ.1 -> - declared_projection Σ mdecl idecl p pdecl -> + declared_projection Σ p mdecl idecl pdecl -> let u := PCUICLookup.abstract_instance (ind_universes mdecl) in isType (Σ.1, ind_universes mdecl) ((vass {| binder_name := nAnon; binder_relevance := idecl.(ind_relevance) |} (mkApps (tInd p.1.1 u) @@ -899,13 +921,15 @@ Lemma declared_projection_type {cf:checker_flags} {Σ : global_env_ext} {mdecl i smash_context [] (ind_params mdecl)) pdecl.2. Proof. intros wfΣ declp. - destruct (on_declared_projection wfΣ declp) as [oni onp]. + destruct (on_declared_projection declp) as [oni onp]. specialize (declared_projections wfΣ (let (x, _) := declp in x)). set(oib := declared_inductive_inv _ _ _ _) in *. intros onprojs u. clearbody oib. simpl in *. - destruct (ind_cshapes oib) as [|? []]; try contradiction. + destruct (ind_ctors idecl) as [|? []] => //. + destruct onp as [[[? ?] ?] ?]. + destruct (ind_cunivs oib) as [|? []] => //. forward onprojs. intuition auto. destruct declp as [decli [Hnth Hpars]]. eapply nth_error_alli in onprojs; eauto. @@ -913,10 +937,10 @@ Proof. Qed. Lemma declared_projection_type_and_eq {cf:checker_flags} {Σ : global_env_ext} {mdecl idecl p pdecl} : - forall (wfΣ : wf Σ.1) (Hdecl : declared_projection Σ mdecl idecl p pdecl), + forall (wfΣ : wf Σ.1) (Hdecl : declared_projection Σ p mdecl idecl pdecl), let u := PCUICLookup.abstract_instance (ind_universes mdecl) in let oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ (let (x, _) := Hdecl in x) in - match ind_cshapes oib return Type with + match ind_ctors idecl return Type with | [cs] => isType (Σ.1, ind_universes mdecl) ((vass {| binder_name := nAnon; binder_relevance := idecl.(ind_relevance) |} @@ -924,11 +948,11 @@ Lemma declared_projection_type_and_eq {cf:checker_flags} {Σ : global_env_ext} { (to_extended_list (smash_context [] (ind_params mdecl))))):: smash_context [] (ind_params mdecl)) pdecl.2 * ∑ decl, - (nth_error (smash_context [] (cshape_args cs)) - (context_assumptions (cshape_args cs) - S p.2) = Some decl) * + (nth_error (smash_context [] (cstr_args cs)) + (context_assumptions (cstr_args cs) - S p.2) = Some decl) * (wf_local (Σ.1, ind_universes mdecl) (arities_context (ind_bodies mdecl) ,,, - ind_params mdecl ,,, smash_context [] (cshape_args cs))) * + ind_params mdecl ,,, smash_context [] (cstr_args cs))) * (projection_type mdecl p.1.1 p.2 decl.(decl_type) = pdecl.2) * (projection_type mdecl p.1.1 p.2 decl.(decl_type) = projection_type' mdecl p.1.1 p.2 decl.(decl_type))%type @@ -936,13 +960,15 @@ Lemma declared_projection_type_and_eq {cf:checker_flags} {Σ : global_env_ext} { end. Proof. intros wfΣ declp. - destruct (on_declared_projection wfΣ declp) as [oni onp]. + destruct (on_declared_projection declp) as [oni onp]. specialize (declared_projections wfΣ (let (x, _) := declp in x)). set(oib := declared_inductive_inv _ _ _ _) in *. intros onprojs u. clearbody oib. - simpl in *. - destruct (ind_cshapes oib) as [|? []]; try contradiction. + destruct (ind_ctors idecl) as [|? []] => //. + destruct onp as [[[? ?] ?] ?]. + set (cu := ind_cunivs _) in y. + destruct cu as [|? []] in y => //. simpl in *. forward onprojs. intuition auto. destruct declp as [decli [Hnth Hpars]]. eapply nth_error_alli in onprojs; eauto. @@ -950,10 +976,10 @@ Proof. Qed. Definition projection_context mdecl idecl ind u := - smash_context [] (subst_instance_context u (ind_params mdecl)),, + smash_context [] (subst_instance u (ind_params mdecl)),, vass ({| binder_name := nNamed (ind_name idecl); binder_relevance := idecl.(ind_relevance) |}) (mkApps (tInd ind u) (to_extended_list (smash_context [] - (subst_instance_context u (ind_params mdecl))))). + (subst_instance u (ind_params mdecl))))). Lemma type_local_ctx_cum {cf:checker_flags} {Σ Γ Δ s s'} : wf Σ.1 -> wf_universe Σ s' -> @@ -1002,24 +1028,12 @@ Proof. exists u. unfold PCUICTypingDef.typing in *. now eapply inversion_it_mkProd_or_LetIn in Hu. Qed. - -Lemma subst_lift1 x s : (subst0 (x :: s) ∘ lift0 1) =1 subst0 s. -Proof. - intros t. erewrite <- subst_skipn'. - rewrite lift0_id. simpl. now rewrite skipn_S skipn_0. - lia. simpl. lia. -Qed. - -Lemma map_subst_lift1 x s l : map (subst0 (x :: s) ∘ lift0 1) l = map (subst0 s) l. -Proof. - apply map_ext. apply subst_lift1. -Qed. Lemma context_subst_to_extended_list_k {cf:checker_flags} Σ Δ : wf Σ.1 -> wf_local Σ Δ -> context_subst Δ - (map (subst0 (extended_subst Δ 0)) (PCUICAst.to_extended_list_k Δ 0)) + (map (subst0 (extended_subst Δ 0)) (to_extended_list_k Δ 0)) (extended_subst Δ 0). Proof. move=> wfΣ wfΔ. @@ -1076,7 +1090,7 @@ Proof. now apply subject_closed in Hs. Qed. -Lemma spine_subst_smash_inv {cf : checker_flags} {Σ : global_env_ext} (Δ : PCUICAst.context) : +Lemma spine_subst_smash_inv {cf : checker_flags} {Σ : global_env_ext} (Δ : context) : wf Σ.1 -> wf_local Σ Δ -> spine_subst Σ (smash_context [] Δ) @@ -1092,7 +1106,7 @@ Proof. eapply context_subst_to_extended_list_k; eauto. - now apply subslet_extended_subst. Qed. - +From MetaCoq.PCUIC Require Import PCUICInduction. Lemma isType_it_mkProd_or_LetIn_smash {cf:checker_flags} Σ Γ Δ s : wf Σ.1 -> @@ -1127,20 +1141,20 @@ Qed. Lemma typing_spine_to_extended_list {cf:checker_flags} Σ Δ u s : wf Σ.1 -> - isType Σ [] (subst_instance_constr u (it_mkProd_or_LetIn Δ (tSort s))) -> - typing_spine Σ (smash_context [] (subst_instance_context u Δ)) - (subst_instance_constr u (it_mkProd_or_LetIn Δ (tSort s))) - (to_extended_list (smash_context [] (subst_instance_context u Δ))) + isType Σ [] (subst_instance u (it_mkProd_or_LetIn Δ (tSort s))) -> + typing_spine Σ (smash_context [] (subst_instance u Δ)) + (subst_instance u (it_mkProd_or_LetIn Δ (tSort s))) + (to_extended_list (smash_context [] (subst_instance u Δ))) (tSort (subst_instance_univ u s)). Proof. move=> wfΣ wfΔ. apply wf_arity_spine_typing_spine; auto. - rewrite subst_instance_constr_it_mkProd_or_LetIn in wfΔ |- *. + rewrite subst_instance_it_mkProd_or_LetIn in wfΔ |- *. split. eapply isType_weaken; auto. eapply wf_local_smash_context; pcuic. now eapply isType_it_mkProd_or_LetIn_wf_local in wfΔ; auto; rewrite app_context_nil_l in wfΔ. - rewrite -(app_nil_r (to_extended_list (smash_context [] (subst_instance_context u Δ)))). + rewrite -(app_nil_r (to_extended_list (smash_context [] (subst_instance u Δ)))). eapply arity_spine_it_mkProd_or_LetIn; auto. 2:{ simpl; constructor; [|reflexivity]. eapply isType_it_mkProd_or_LetIn_smash in wfΔ; auto. @@ -1154,38 +1168,38 @@ Qed. Lemma wf_projection_context {cf:checker_flags} (Σ : global_env_ext) {mdecl idecl p pdecl u} : wf Σ.1 -> - declared_projection Σ mdecl idecl p pdecl -> - consistent_instance_ext Σ (PCUICAst.ind_universes mdecl) u -> + declared_projection Σ p mdecl idecl pdecl -> + consistent_instance_ext Σ (ind_universes mdecl) u -> wf_local Σ (projection_context mdecl idecl p.1.1 u). Proof. move=> wfΣ decli. - pose proof (on_declared_projection wfΣ decli) as [onmind onind]. + pose proof (on_declared_projection decli) as [onmind onind]. set (oib := declared_inductive_inv _ _ _ _) in *. clearbody oib. - simpl in onind; destruct ind_cshapes as [|? []]; try contradiction. + simpl in onind; destruct ind_ctors as [|? []] => //. destruct onind as [[[_ onps] Hpe] onp]. move=> cu. - assert(wfparams : wf_local Σ (subst_instance_context u (ind_params mdecl))). + assert(wfparams : wf_local Σ (subst_instance u (ind_params mdecl))). { eapply on_minductive_wf_params; eauto. eapply decli. } - assert(wfsmash : wf_local Σ (smash_context [] (subst_instance_context u (ind_params mdecl)))). + assert(wfsmash : wf_local Σ (smash_context [] (subst_instance u (ind_params mdecl)))). { eapply wf_local_smash_context; auto. } constructor; auto. red. - exists (subst_instance_univ u (ind_sort oib)). + exists (subst_instance_univ u (ind_sort idecl)). eapply type_mkApps. econstructor; eauto. eapply decli.p1. rewrite (ind_arity_eq oib). pose proof (on_projs_noidx _ _ _ _ _ _ onps). - destruct (ind_indices oib) eqn:eqind; try discriminate. + destruct (ind_indices idecl) eqn:eqind; try discriminate. simpl. eapply typing_spine_to_extended_list; eauto. - pose proof (on_inductive_inst _ _ _ _ _ _ wfΣ localenv_nil (proj1 (proj1 decli)) onmind oib cu). + pose proof (on_inductive_inst decli _ u localenv_nil). rewrite eqind in X. simpl in X. - now rewrite subst_instance_constr_it_mkProd_or_LetIn. + now rewrite subst_instance_it_mkProd_or_LetIn. Qed. Lemma invert_type_mkApps_ind {cf:checker_flags} Σ Γ ind u args T mdecl idecl : wf Σ.1 -> - declared_inductive Σ.1 mdecl ind idecl -> + declared_inductive Σ.1 ind mdecl idecl -> Σ ;;; Γ |- mkApps (tInd ind u) args : T -> - (typing_spine Σ Γ (subst_instance_constr u (ind_type idecl)) args T) + (typing_spine Σ Γ (subst_instance u (ind_type idecl)) args T) * consistent_instance_ext Σ (ind_universes mdecl) u. Proof. intros wfΣ decli. @@ -1195,12 +1209,12 @@ Proof. noconf H2. clear IHtyping1 IHtyping3. specialize (IHtyping2 _ _ _ _ _ _ _ wfΣ decli eq_refl) as [IH cu]; split; auto. - destruct (on_declared_inductive wfΣ decli) as [onmind oib]. + destruct (on_declared_inductive decli) as [onmind oib]. eapply typing_spine_app; eauto. - invs H0. destruct (declared_inductive_inj d decli) as [-> ->]. clear decli. split; auto. constructor; [|reflexivity]. - destruct (on_declared_inductive wfΣ d) as [onmind oib]. + destruct (on_declared_inductive d) as [onmind oib]. pose proof (oib.(onArity)) as ar. eapply isType_weaken; eauto. eapply (isType_subst_instance_decl _ []); eauto. @@ -1210,14 +1224,13 @@ Proof. eapply typing_spine_weaken_concl; pcuic. Qed. -Lemma isType_mkApps_Ind {cf:checker_flags} {Σ Γ ind u args} (wfΣ : wf Σ.1) - {mdecl idecl} (declm : declared_inductive Σ.1 mdecl ind idecl) : +Lemma isType_mkApps_Ind_inv {cf:checker_flags} {Σ Γ ind u args} (wfΣ : wf Σ.1) + {mdecl idecl} (declm : declared_inductive Σ.1 ind mdecl idecl) : wf_local Σ Γ -> isType Σ Γ (mkApps (tInd ind u) args) -> ∑ parsubst argsubst, - let oib := (on_declared_inductive wfΣ declm).2 in - let parctx := (subst_instance_context u (ind_params mdecl)) in - let argctx := (subst_context parsubst 0 (subst_instance_context u (oib.(ind_indices)))) in + let parctx := (subst_instance u (ind_params mdecl)) 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 Σ Γ (skipn (ind_npars mdecl) args) argsubst argctx * consistent_instance_ext Σ (ind_universes mdecl) u. @@ -1225,59 +1238,57 @@ Proof. move=> wfΓ isType. destruct isType as [s Hs]. eapply invert_type_mkApps_ind in Hs as [tyargs cu]; eauto. - set (decli' := on_declared_inductive _ _). clearbody decli'. + set (decli' := on_declared_inductive declm). rename declm into decli. destruct decli' as [declm decli']. pose proof (decli'.(onArity)) as ar. rewrite decli'.(ind_arity_eq) in tyargs, ar. hnf in ar. destruct ar as [s' ar]. - rewrite !subst_instance_constr_it_mkProd_or_LetIn in tyargs. + rewrite !subst_instance_it_mkProd_or_LetIn in tyargs. simpl in tyargs. rewrite -it_mkProd_or_LetIn_app in tyargs. eapply arity_typing_spine in tyargs as [[argslen leqs] [instsubst [wfdom wfcodom cs subs]]] => //. apply context_subst_app in cs as [parsubst argsubst]. - eexists _, _. move=> lk parctx argctx. subst lk. - rewrite subst_instance_context_assumptions in argsubst, parsubst. + eexists _, _. move=> parctx argctx. + rewrite subst_instance_assumptions in argsubst, parsubst. rewrite declm.(onNpars) in argsubst, parsubst. eapply subslet_app_inv in subs as [subp suba]. - rewrite subst_instance_context_length in subp, suba. + rewrite subst_instance_length in subp, suba. subst parctx argctx. - repeat split; eauto; rewrite ?subst_instance_context_length => //. + repeat split; eauto; rewrite ?subst_instance_length => //. rewrite app_context_assoc in wfcodom. now apply All_local_env_app_inv in wfcodom as [? ?]. simpl. eapply substitution_wf_local; eauto. now rewrite app_context_assoc in wfcodom. - unshelve eapply on_inductive_inst in declm; pcuic. - rewrite subst_instance_context_app in declm. - now eapply isType_it_mkProd_or_LetIn_wf_local in declm. - apply decli. + eapply (on_inductive_inst decli) in cu; eauto. + rewrite subst_instance_app in cu. + now eapply isType_it_mkProd_or_LetIn_wf_local in cu. Qed. Lemma projection_subslet {cf:checker_flags} Σ Γ mdecl idecl u c p pdecl args : - declared_projection Σ.1 mdecl idecl p pdecl -> + declared_projection Σ.1 p mdecl idecl pdecl -> wf Σ.1 -> Σ ;;; Γ |- c : mkApps (tInd p.1.1 u) args -> isType Σ Γ (mkApps (tInd p.1.1 u) args) -> subslet Σ Γ (c :: List.rev args) (projection_context mdecl idecl p.1.1 u). Proof. intros declp wfΣ Hc Ha. - destruct (on_declared_projection wfΣ declp). - destruct (isType_mkApps_Ind wfΣ (let (x, _) := declp in x) (typing_wf_local Hc) Ha) as + destruct (on_declared_projection declp). + destruct (isType_mkApps_Ind_inv wfΣ (let (x, _) := declp in x) (typing_wf_local Hc) Ha) as [parsubst [argsubst [[sppars spargs] cu]]]. - unfold on_declared_inductive in spargs. simpl in spargs. unfold projection_context. set (oib := declared_inductive_inv _ _ _ _) in *. clearbody oib. - simpl in y. destruct (ind_cshapes oib) as [|cs []]; try contradiction. + simpl in y. + destruct (ind_ctors idecl) as [|ctors []]; try contradiction. destruct y as [[[_ onps] ?] ?]. pose proof (on_projs_noidx _ _ _ _ _ _ onps). pose proof (onNpars o). pose proof (context_subst_length2 spargs). rewrite context_assumptions_fold in H1. autorewrite with len in H1. - destruct (ind_indices oib); try discriminate. + destruct (ind_indices idecl); try discriminate. simpl in H1. rewrite List.skipn_length in H1. assert(#|args| = ind_npars mdecl). { pose proof (context_subst_length2 sppars). autorewrite with len in H2. - rewrite subst_instance_context_assumptions in H2. rewrite H0 in H2. apply firstn_length_le_inv in H2. lia. } rewrite -H2 in sppars. @@ -1289,7 +1300,6 @@ Proof. now rewrite (spine_subst_subst_to_extended_list_k sppars). Qed. - Lemma invert_red1_letin {cf:checker_flags} (Σ : global_env_ext) Γ C na d ty b : red1 Σ.1 Γ (tLetIn na d ty b) C -> (∑ d', (C = tLetIn na d' ty b) * @@ -1324,41 +1334,6 @@ Proof. now rewrite app_context_assoc. Qed. -Definition head x := (decompose_app x).1. -Definition arguments x := (decompose_app x).2. - -Lemma head_arguments x : mkApps (head x) (arguments x) = x. -Proof. - unfold head, arguments, decompose_app. - remember (decompose_app_rec x []). - destruct p as [f l]. - symmetry in Heqp. - eapply decompose_app_rec_inv in Heqp. - now simpl in *. -Qed. - -Lemma fst_decompose_app_rec t l : fst (decompose_app_rec t l) = fst (decompose_app t). -Proof. - induction t in l |- *; simpl; auto. rewrite IHt1. - unfold decompose_app. simpl. now rewrite (IHt1 [t2]). -Qed. - -Lemma decompose_app_rec_head t l f : fst (decompose_app_rec t l) = f -> - negb (isApp f). -Proof. - induction t; unfold isApp; simpl; try intros [= <-]; auto. - intros. apply IHt1. now rewrite !fst_decompose_app_rec. -Qed. - -Lemma head_nApp x : negb (isApp (head x)). -Proof. - unfold head. - eapply decompose_app_rec_head. reflexivity. -Qed. - -Lemma head_tapp t1 t2 : head (tApp t1 t2) = head t1. -Proof. rewrite /head /decompose_app /= fst_decompose_app_rec //. Qed. - Lemma destInd_head_subst s k t f : destInd (head (subst s k t)) = Some f -> (destInd (head t) = Some f) + (∑ n u, (head t = tRel n) /\ k <= n /\ (nth_error s (n - k) = Some u /\ destInd (head (lift0 k u)) = Some f)). @@ -1400,7 +1375,7 @@ Proof. now rewrite !head_tapp. Qed. -Hint Rewrite context_assumptions_app context_assumptions_subst : len. +Hint Rewrite context_assumptions_app @context_assumptions_subst : len. Lemma red1_destInd (Σ : global_env_ext) Γ t t' ind u : red1 Σ.1 Γ t t' -> destInd (head t) = Some (ind, u) -> @@ -1487,10 +1462,10 @@ Proof. rewrite Nat.add_0_r. autorewrite with len in hnth'. rewrite hnth'. simpl. eexists; split; eauto. simpl. autorewrite with len in Hnth. simpl in Hnth. move: Hnth. - assert (PCUICAst.context_assumptions ctx' - - S (PCUICAst.context_assumptions ctx' - S n) = n) as -> by lia. + assert (context_assumptions ctx' - + S (context_assumptions ctx' - S n) = n) as -> by lia. assert (context_assumptions Γ - - S (PCUICAst.context_assumptions Γ - S n) = n) as -> by lia. + S (context_assumptions Γ - S n) = n) as -> by lia. move=> [= <-]. simpl. transitivity (subst [b] n (decl_type decl)). rewrite subst_empty lift0_id lift0_context. @@ -1606,3 +1581,139 @@ Proof. exists (ctx' ++ [vass na A']), args'. rewrite it_mkProd_or_LetIn_app /= //. Qed. + + +(* We show that the derived predicate of a case is always well-typed, for *any* + instance of the parameters (not just the ones from a well-formed predicate). *) +Lemma isType_case_predicate {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {ci : case_info} + {mdecl idecl} u params ps : + wf_local Σ Γ -> + declared_inductive Σ ci mdecl idecl -> + consistent_instance_ext Σ (ind_universes mdecl) u -> + wf_universe Σ ps -> + spine_subst Σ Γ params (List.rev params) + (smash_context [] (subst_instance u (ind_params mdecl))) -> + isType Σ Γ + (it_mkProd_or_LetIn + (pre_case_predicate_context_gen ci mdecl idecl params u) + (tSort ps)). +Proof. + move=> wfΓ isdecl cu wfps sp. + rewrite /pre_case_predicate_context_gen. + set (iass := {| decl_name := _ |}). + rewrite subst_instance_expand_lets_ctx. + unshelve epose proof (on_inductive_inst isdecl _ _ _ cu); tea. + rewrite -/(subst_context_let_expand _ _ _). + rewrite subst_instance_app_ctx in X. + destruct X as [s Hs]. red in Hs. + eapply isType_it_mkProd_or_LetIn_app in Hs. 2:eapply sp. + rewrite subst_let_expand_it_mkProd_or_LetIn in Hs. + eapply type_it_mkProd_or_LetIn_inv in Hs as (idxs & inds & sortsidx & sortind & leq). + eexists (sort_of_products (subst_instance u (ind_sort idecl) :: idxs) + (Universe.super ps)); red. + set (idxctx := subst_context_let_expand _ _ _) in *. + have tyass : Σ ;;; Γ ,,, idxctx |- decl_type iass : + tSort (subst_instance u (ind_sort idecl)). + { pose proof (on_inductive_sort_inst isdecl _ cu). + rewrite /iass /=. + have wfidxctx : wf_local Σ (Γ ,,, idxctx) by pcuic. + eapply pre_type_mkApps_arity. econstructor; tea. pcuic. + eapply declared_inductive_valid_type; tea. pcuic. + pose proof (on_declared_inductive isdecl) as [onmind oib]. + rewrite oib.(ind_arity_eq) subst_instance_it_mkProd_or_LetIn. + eapply arity_spine_it_mkProd_or_LetIn_smash; tea. + rewrite -[smash_context [] _](closed_ctx_lift #|idecl.(ind_indices)| 0). + { eapply closedn_smash_context. + rewrite closedn_subst_instance_context. + eapply (declared_inductive_closed_params isdecl). } + relativize #|ind_indices idecl|. + rewrite -map_rev. eapply subslet_lift; tea. + eapply sp. now rewrite /idxctx; len. + rewrite subst_instance_it_mkProd_or_LetIn subst_let_expand_it_mkProd_or_LetIn /=. + eapply arity_spine_it_mkProd_or_LetIn_Sort => //. reflexivity. + relativize (subst_context_let_expand (List.rev (map _ _)) _ _). + relativize (to_extended_list _). + eapply spine_subst_to_extended_list_k; tea. + rewrite [reln [] _ _]to_extended_list_subst_context_let_expand. + apply PCUICLiftSubst.map_subst_instance_to_extended_list_k. + rewrite subst_context_let_expand_length subst_instance_length. + rewrite /subst_context_let_expand. + rewrite distr_lift_subst_context map_rev. f_equal. + rewrite List.rev_length Nat.add_0_r. + rewrite PCUICClosed.closed_ctx_lift //. + pose proof (PCUICContextSubst.context_subst_length2 sp). + rewrite context_assumptions_smash_context /= in H0. len in H0. + rewrite H0. + relativize (context_assumptions _). + eapply PCUICClosed.closedn_ctx_expand_lets; len. + rewrite -subst_instance_app_ctx closedn_subst_instance_context. + eapply (declared_inductive_closed_pars_indices _ isdecl). now len. } + eapply type_it_mkProd_or_LetIn_sorts; tea. + constructor => //. + constructor => //. simpl. + constructor => //. + now eapply sorts_local_ctx_wf_local; tea. red. + eexists; tea. +Qed. + +Lemma arity_spine_case_predicate {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {ci : case_info} + {mdecl idecl} {u params indices ps} {c} : + wf_local Σ Γ -> + declared_inductive Σ ci mdecl idecl -> + consistent_instance_ext Σ (ind_universes mdecl) u -> + wf_universe Σ ps -> + spine_subst Σ Γ params (List.rev params) + (smash_context [] (subst_instance u (ind_params mdecl))) -> + 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) -> + arity_spine Σ Γ + (it_mkProd_or_LetIn + (pre_case_predicate_context_gen ci mdecl idecl params u) + (tSort ps)) + (indices ++ [c]) (tSort ps). +Proof. + move=> wfΓ isdecl cu wfps sppars spidx Hc. + rewrite /pre_case_predicate_context_gen. + simpl. + rewrite subst_instance_expand_lets_ctx. + eapply arity_spine_it_mkProd_or_LetIn_smash; tea. + rewrite (smash_context_subst []). + rewrite /subst_context_let_expand (expand_lets_smash_context _ []) + expand_lets_k_ctx_nil /= in spidx. + apply spidx. rewrite subst_let_expand_tProd. + constructor. + 2:econstructor. + set (ictx := subst_instance u _). + eapply meta_conv; tea. + rewrite subst_let_expand_mkApps subst_let_expand_tInd map_app. + f_equal. f_equal. + rewrite -{1}[params](map_id params). + rewrite map_map_compose; eapply map_ext => x. + setoid_rewrite subst_let_expand_lift_id; auto. + now rewrite /ictx; len. + rewrite /ictx /expand_lets_ctx /expand_lets_k_ctx; len. + pose proof (PCUICContextSubst.context_subst_length2 spidx). + rewrite /subst_context_let_expand in H. now len in H. + (* Should be a lemma *) + rewrite -subst_context_map_subst_expand_lets. + rewrite /ictx; len. + pose proof (PCUICContextSubst.context_subst_length2 sppars). + now rewrite context_assumptions_smash_context /= in H; len in H. + rewrite /subst_let_expand /expand_lets /expand_lets_k. + rewrite -map_map_compose. + rewrite -{1}(spine_subst_subst_to_extended_list_k spidx). + f_equal. + rewrite to_extended_list_k_subst /expand_lets_ctx /expand_lets_k_ctx. + rewrite !to_extended_list_k_subst to_extended_list_k_lift_context. + rewrite -map_map_compose. simpl. len. + rewrite lift_to_extended_list_k. + set (ctx := subst_context _ _ _). + assert (to_extended_list_k (ind_indices idecl) 0 = to_extended_list_k ctx 0) as ->. + { rewrite /ctx to_extended_list_k_subst. + now rewrite PCUICLiftSubst.map_subst_instance_to_extended_list_k. } + rewrite extended_subst_to_extended_list_k /ctx. + now rewrite (smash_context_subst []) to_extended_list_k_subst. +Qed. diff --git a/pcuic/theories/PCUICInst.v b/pcuic/theories/PCUICInst.v new file mode 100644 index 000000000..0a2d0cee8 --- /dev/null +++ b/pcuic/theories/PCUICInst.v @@ -0,0 +1,2042 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Morphisms. +From MetaCoq.Template Require Import config utils. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction + PCUICLiftSubst PCUICUnivSubst PCUICContextRelation + PCUICTyping PCUICClosed PCUICEquality PCUICWeakeningEnv + PCUICSigmaCalculus PCUICRename PCUICWeakening. + +Require Import ssreflect ssrbool. +From Equations Require Import Equations. +Require Import Equations.Prop.DepElim. +Set Equations With UIP. +Set Keyed Unification. +Set Default Goal Selector "!". + +Implicit Types cf : checker_flags. + +(** * Type preservation for σ-calculus instantiation *) + +Open Scope sigma_scope. + +Definition inst_context σ (Γ : context) : context := + fold_context_k (fun i => inst (⇑^i σ)) Γ. + +Instance inst_context_ext : Proper (`=1` ==> Logic.eq ==> Logic.eq) inst_context. +Proof. + intros f g Hfg x y ->. + apply fold_context_k_ext => i t. + now rewrite Hfg. +Qed. + +Definition inst_decl σ d := map_decl (inst σ) d. + +Definition inst_context_snoc0 s Γ d : + inst_context s (d :: Γ) = + inst_context s Γ ,, map_decl (inst (⇑^#|Γ| s)) d. +Proof. unfold inst_context. now rewrite fold_context_k_snoc0. Qed. +Hint Rewrite inst_context_snoc0 : sigma. + +Lemma inst_context_snoc s Γ d : inst_context s (Γ ,, d) = inst_context s Γ ,, map_decl (inst (⇑^#|Γ| s)) d. +Proof. + unfold snoc. apply inst_context_snoc0. +Qed. +Hint Rewrite inst_context_snoc : sigma. + +Lemma inst_context_alt s Γ : + inst_context s Γ = + mapi (fun k' d => map_decl (inst (⇑^(Nat.pred #|Γ| - k') s)) d) Γ. +Proof. + unfold inst_context. apply fold_context_k_alt. +Qed. + +Lemma inst_context_length s Γ : #|inst_context s Γ| = #|Γ|. +Proof. apply fold_context_k_length. Qed. +Hint Rewrite inst_context_length : sigma wf. + +Lemma inst_mkApps f l σ : (mkApps f l).[σ] = mkApps f.[σ] (map (inst σ) l). +Proof. + induction l in f |- *; simpl; auto. rewrite IHl. + now autorewrite with sigma. +Qed. +Hint Rewrite inst_mkApps : sigma. + +Lemma lift0_inst n t : lift0 n t = t.[↑^n]. +Proof. by rewrite lift_rename rename_inst lift_renaming_0 -ren_shiftk. Qed. +Hint Rewrite lift0_inst : sigma. + +Lemma rename_decl_inst_decl : forall f d, rename_decl f d = inst_decl (ren f) d. +Proof. + intros f d. + unfold rename_decl, inst_decl. + destruct d. unfold map_decl. + autorewrite with sigma. + f_equal. +Qed. + +Hint Rewrite rename_decl_inst_decl : sigma. + +Lemma rename_context_inst_context : + forall f Γ, + rename_context f Γ = inst_context (ren f) Γ. +Proof. + intros f Γ. + induction Γ. + - reflexivity. + - autorewrite with sigma. rewrite IHΓ. f_equal. + destruct a. unfold inst_decl. unfold map_decl. simpl. + f_equal. + + destruct decl_body. 2: reflexivity. + simpl. f_equal. autorewrite with sigma. + now rewrite -up_Upn ren_shiftn. + + autorewrite with sigma. + now rewrite -up_Upn ren_shiftn. +Qed. +Hint Rewrite rename_context_inst_context : sigma. + +Lemma inst_subst0 a b τ : (subst0 a b).[τ] = (subst0 (map (inst τ) a) b.[⇑^#|a| τ]). +Proof. + simpl. rewrite !subst_inst !Upn_0. sigma. + apply inst_ext. + rewrite Upn_comp //; now len. +Qed. +Hint Rewrite inst_subst0 : sigma. + +Lemma subst10_inst a b τ : b {0 := a}.[τ] = (b.[⇑ τ] {0 := a.[τ]}). +Proof. + unfold subst10. sigma. simpl. rewrite subst_consn_tip /= //. +Qed. +Hint Rewrite subst10_inst : sigma. + +Lemma inst_closed0 σ t : closedn 0 t -> t.[σ] = t. +Proof. intros. rewrite -{2}[t](inst_closed σ 0) //. now sigma. Qed. + +Definition iffT_l {P Q} : P <~> Q -> P -> Q. +Proof. + apply: fst. +Qed. +Coercion iffT_l : CRelationClasses.iffT >-> Funclass. + +Lemma mapi_context_eqP_onctx_k_spec {P : nat -> term -> Type} {k} {ctx} {f g : nat -> term -> term} : + onctx_k P k ctx -> + (forall i x, P (i + k) x -> f i x = g i x) -> + mapi_context f ctx = mapi_context g ctx. +Proof. + move=> Ha Hfg. + rewrite !mapi_context_fold. + rewrite !fold_context_k_alt. + eapply Alli_mapi_spec; tea. + move=> /= n x ond. + eapply map_decl_eq_spec; tea. + intros t Ht. + now eapply Hfg. +Qed. + +Lemma inst_ext_closed s s' k t : + (forall x, x < k -> s x = s' x) -> + closedn k t -> + inst s t = inst s' t. +Proof. + clear. + intros Hs clt. revert k t clt s s' Hs. + apply: term_closedn_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. + - f_equal; eauto. + eapply H0; eauto. intros. eapply up_ext_closed; eauto. + - f_equal; eauto. now eapply H0, (up_ext_closed _ 1). + - f_equal; eauto. + now eapply H1, (up_ext_closed _ 1). + - destruct X as [ppars pret]. + f_equal; eauto. + * unfold test_predicate in *. simpl in *. solve_all. + eapply map_predicate_shift_eq_spec; solve_all. + + eapply mapi_context_eqP_onctx_k_spec; tea. simpl. + intros i x Hf. apply Hf. + now eapply up_ext_closed. + + now eapply b, up_ext_closed. + * red in X0. + eapply All_map_eq. solve_all. + eapply map_branch_shift_eq_spec; solve_all. + + eapply mapi_context_eqP_onctx_k_spec; tea. simpl. + now intros i x' Hf; apply Hf, up_ext_closed. + + now eapply b0, up_ext_closed. + - f_equal; eauto. red in X. solve_all. + eapply b; eauto. len. now apply up_ext_closed. + - f_equal; eauto. red in X. solve_all. + eapply b; eauto. len; now apply up_ext_closed. +Qed. + +Lemma subst_id s Γ t : + closedn #|s| t -> + assumption_context Γ -> + s = List.rev (to_extended_list Γ) -> + subst s 0 t = t. +Proof. + intros cl ass eq. + autorewrite with sigma. + rewrite -{2}(subst_ids t). + eapply inst_ext_closed; eauto. + intros. + unfold ids, subst_consn. simpl. + destruct (snd (nth_error_Some' s x) H). rewrite e. + subst s. + rewrite /to_extended_list /to_extended_list_k in e. + rewrite List.rev_length in cl, H. autorewrite with len in *. + rewrite reln_alt_eq in e. + rewrite app_nil_r List.rev_involutive in e. + clear -ass e. revert e. + rewrite -{2}(Nat.add_0_r x). + generalize 0. + induction Γ in x, ass, x0 |- * => n. + - simpl in *. rewrite nth_error_nil => //. + - depelim ass; simpl. + destruct x; simpl in *; try congruence. + move=> e; specialize (IHΓ ass); simpl in e. + specialize (IHΓ _ _ _ e). subst x0. f_equal. lia. +Qed. + +Lemma map_inst_idsn l l' n : + #|l| = n -> + map (inst (l ⋅n l')) (idsn n) = l. +Proof. + induction n in l, l' |- *. + - destruct l => //. + - destruct l as [|l a] using rev_case => // /=. + rewrite app_length /= Nat.add_1_r => [=]. + intros; subst n. + simpl. rewrite map_app. + f_equal; auto. + + rewrite subst_consn_app. + now apply IHn. + + simpl. + rewrite subst_consn_lt /= ?List.app_length /= //; try lia. + now rewrite /subst_fn nth_error_app_ge /= // Nat.sub_diag /=. +Qed. + +Lemma inst_decl_closed : + forall σ k d, + closed_decl k d -> + inst_decl (⇑^k σ) d = d. +Proof. + intros σ k d. + move/(ondeclP reflectT_pred) => ond. + eapply map_decl_id_spec; tea => /=. + apply inst_closed. +Qed. + +Lemma closed_tele_inst : + forall σ ctx, + closed_ctx ctx -> + mapi (fun i decl => inst_decl (⇑^i σ) decl) (List.rev ctx) = + List.rev ctx. +Proof. + intros σ ctx. + rewrite test_context_k_eq. + rewrite /mapi. simpl. generalize 0. + induction ctx using rev_ind; try easy. + move => n. + rewrite /closedn_ctx !rev_app_distr /id /=. + move /andb_and => [closedx Hctx]. + rewrite inst_decl_closed //. + f_equal. now rewrite IHctx. +Qed. + +Lemma inst_closedn_ctx f n Γ : + closedn_ctx n Γ -> + inst_context (⇑^n f) Γ = Γ. +Proof. + rewrite test_context_k_eq. + apply alli_fold_context_k. + intros. rewrite -Upn_Upn Nat.add_comm. + now rewrite [map_decl _ _]inst_decl_closed. +Qed. + +Lemma typed_inst {cf} : + forall Σ Γ t T k σ, + wf Σ.1 -> + k >= #|Γ| -> + Σ ;;; Γ |- t : T -> + T.[⇑^k σ] = T /\ t.[⇑^k σ] = t. +Proof. + intros Σ Γ t T k σ hΣ hk h. + apply typing_wf_local in h as hΓ. + apply typecheck_closed in h. all: eauto. + destruct h as [_ [hclΓ hcl]]. + rewrite -> andb_and in hcl. destruct hcl as [clt clT]. + pose proof (closed_upwards k clt) as ht. + pose proof (closed_upwards k clT) as hT. + forward ht by lia. + forward hT by lia. + rewrite !inst_closed. all: auto. +Qed. + +Lemma inst_wf_local {cf} : + forall Σ Γ σ, + wf Σ.1 -> + wf_local Σ Γ -> + inst_context σ Γ = Γ. +Proof. + intros Σ Γ σ hΣ h. + induction h. + - reflexivity. + - unfold inst_context, snoc. rewrite fold_context_k_snoc0. + unfold snoc. f_equal. all: auto. + unfold map_decl. simpl. unfold vass. f_equal. + destruct t0 as [s ht]. eapply typed_inst. all: eauto. + - unfold inst_context, snoc. rewrite fold_context_k_snoc0. + unfold snoc. f_equal. all: auto. + unfold map_decl. simpl. unfold vdef. f_equal. + + f_equal. eapply typed_inst. all: eauto. + + eapply typed_inst in t1 as [? _]. all: eauto. +Qed. + +Definition inst_mutual_inductive_body σ m := + map_mutual_inductive_body (fun i => inst (⇑^i σ)) m. + +Lemma inst_destArity : + forall ctx t σ args s, + destArity ctx t = Some (args, s) -> + destArity (inst_context σ ctx) t.[⇑^#|ctx| σ] = + Some (inst_context σ args, s). +Proof. + intros ctx t σ args s h. + induction t in ctx, σ, args, s, h |- * using term_forall_list_ind. + all: simpl in *. all: try discriminate. + - inversion h. reflexivity. + - erewrite <- IHt2 ; try eassumption. + simpl. autorewrite with sigma. reflexivity. + - erewrite <- IHt3. all: try eassumption. + simpl. autorewrite with sigma. reflexivity. +Qed. + +Lemma Up_subst_instance u σ : + ⇑ (subst_instance u ∘ σ) =1 subst_instance u ∘ ⇑ σ. +Proof. + intros i => /=. + rewrite - !up_Up /up. + nat_compare_specs => //. + now rewrite rename_subst_instance. +Qed. + +Lemma upn_subst_instance u n σ : + up n (subst_instance u ∘ σ) =1 subst_instance u ∘ up n σ. +Proof. + intros i => /=. + rewrite /up. + nat_compare_specs => //. + now rewrite rename_subst_instance. +Qed. + +Lemma Upn_subst_instance u n σ : + ⇑^n (subst_instance u ∘ σ) =1 subst_instance u ∘ ⇑^n σ. +Proof. + rewrite - !up_Upn. rewrite upn_subst_instance. + intros i. now rewrite up_Upn. +Qed. + +Lemma inst_subst_instance : + forall u t σ, + (subst_instance u t).[subst_instance u ∘ σ] = + subst_instance u t.[σ]. +Proof. + intros u t σ. + rewrite /subst_instance /=. + induction t in σ |- * using term_forall_list_ind. + all: try solve [ + simpl ; + rewrite ?IHt ?IHt1 ?IHt2 ; + easy + ]. + all: simpl. all: auto. + all: autorewrite with map. + all: try solve [ f_equal ; eauto ; solve_all ; eauto ]. + all: try now rewrite IHt1; sigma; rewrite-IHt2 -?IHt3 ?Up_subst_instance. + - simpl. rewrite IHt. f_equal. + * unfold map_predicate, inst_predicate; destruct p; simpl; f_equal; solve_all; + now rewrite upn_subst_instance. + * red in X0; solve_all. + unfold inst_branch, map_branch. simpl in *. + f_equal; solve_all; now rewrite upn_subst_instance. + - f_equal. solve_all. + now rewrite upn_subst_instance. + - f_equal; solve_all. + now rewrite upn_subst_instance. +Qed. + +Lemma map_vass_map_def_inst g l s : + (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) + (map (map_def (inst s) g) l)) = + (mapi (fun i d => map_decl (inst (⇑^i s)) d) + (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) l)). +Proof. + rewrite mapi_mapi mapi_map. apply mapi_ext. + intros. unfold map_decl, vass; simpl; f_equal. + rewrite !lift0_inst. + now sigma. +Qed. + +Lemma inst_fix_context: + forall (mfix : list (def term)) s, + fix_context (map (map_def (inst s) (inst (⇑^#|mfix| s))) mfix) = + inst_context s (fix_context mfix). +Proof. + intros mfix s. unfold fix_context. + rewrite map_vass_map_def_inst rev_mapi. + fold (fix_context mfix). + rewrite (inst_context_alt s (fix_context mfix)). + now rewrite mapi_length fix_context_length. +Qed. + +Lemma inst_fix_context_up : + forall (mfix : list (def term)) s, + fix_context (map (map_def (inst s) (inst (up #|mfix| s))) mfix) = + inst_context s (fix_context mfix). +Proof. + intros mfix s. unfold fix_context. + rewrite map_vass_map_def_inst rev_mapi. + fold (fix_context mfix). + rewrite (inst_context_alt s (fix_context mfix)). + now rewrite mapi_length fix_context_length. +Qed. + +(* Well-typedness of a substitution *) + +Definition well_subst {cf} Σ (Γ : context) σ (Δ : context) := + forall x decl, + nth_error Γ x = Some decl -> + Σ ;;; Δ |- σ x : ((lift0 (S x)) (decl_type decl)).[ σ ] × + (forall b, + decl.(decl_body) = Some b -> + (∑ x' decl', σ x = tRel x' × + nth_error Δ x' = Some decl' × + (* Γ_x', x := b : ty -> Δ_x', x' := b.[↑^S x ∘s σ]. + Δ |- ↑^(S x) ∘s σ : Γ_x + *) + option_map (rename (rshiftk (S x'))) decl'.(decl_body) = Some (b.[↑^(S x) ∘s σ])) + + (σ x = b.[↑^(S x) ∘s σ])). + +Notation "Σ ;;; Δ ⊢ σ : Γ" := + (well_subst Σ Γ σ Δ) (at level 50, Δ, σ, Γ at next level). + + +(* Untyped substitution for untyped reduction / cumulativity *) +Definition usubst (Γ : context) σ (Δ : context) := + forall x decl, + nth_error Γ x = Some decl -> + (forall b, + decl.(decl_body) = Some b -> + (∑ x' decl', σ x = tRel x' × + nth_error Δ x' = Some decl' × + (** This is let-preservation *) + option_map (rename (rshiftk (S x'))) decl'.(decl_body) = Some (b.[↑^(S x) ∘s σ])) + + (* This allows to expand a let-binding everywhere *) + (σ x = b.[↑^(S x) ∘s σ])). + +Definition well_subst_usubst {cf} Σ Γ σ Δ : + Σ ;;; Δ ⊢ σ : Γ -> + usubst Γ σ Δ. +Proof. + intros hσ x decl hnth b hb. + specialize (hσ x decl hnth) as [_ h]. + now apply h. +Qed. + +Coercion well_subst_usubst : well_subst >-> usubst. + +Section Sigma. + +Context `{cf: checker_flags}. + +(* +Lemma shift_Up_comm σ : ↑ ∘s ⇑ σ =1 ⇑ (⇑ σ). +Proof. + intros i. unfold subst_compose. simpl. + unfold subst_compose, Up. simpl. + destruct i. + sigma. *) +Lemma well_subst_Up {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ na A} : + wf_local Σ (Δ ,, vass na A.[σ]) -> + Σ ;;; Δ ⊢ σ : Γ -> + Σ ;;; Δ ,, vass na A.[σ] ⊢ ⇑ σ : Γ ,, vass na A. +Proof. + intros hΔ h [|n] decl e. + - simpl in *. inversion e. subst. clear e. simpl. + split. + + eapply meta_conv. + * econstructor ; auto. + reflexivity. + * simpl. + now autorewrite with sigma. + + intros b e. discriminate. + - cbn -[rshiftk] in *. + specialize (h _ _ e) as [h1 h2]. + split. + + sigma. sigma in h1. + eapply meta_conv. + * epose proof (weakening_rename_typing (Γ' := []) (Γ'' := [_]) hΔ h1). + simpl in X. + sigma in X. eapply X. + * eapply inst_ext. rewrite ren_lift_renaming. + now sigma. + + intros b hb. + specialize (h2 _ hb) as [[x' [decl' [hrel [hnth hdecl]]]]|]. + * left. exists (S x'), decl'. + split. + ** unfold subst_compose at 1. now rewrite hrel. + ** cbn -[rshiftk]. split; auto. + destruct (decl_body decl') => //. cbn -[rshiftk] in hdecl |- *. + noconf hdecl. f_equal. + replace (S (S n)) with (S n + 1) by lia. + rewrite -shiftk_compose subst_compose_assoc. + rewrite -Upn_1_Up (shiftn_Upn 1) -subst_compose_assoc -inst_assoc -H. + sigma. now rewrite ren_shift compose_ren. + * right. + unfold subst_compose at 1. rewrite e0. + now rewrite inst_assoc. +Qed. + +Lemma well_subst_Up' {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ na t A} : + wf_local Σ (Δ ,, vdef na t.[σ] A.[σ]) -> + Σ ;;; Δ ⊢ σ : Γ -> + Σ ;;; Δ ,, vdef na t.[σ] A.[σ] ⊢ ⇑ σ : Γ ,, vdef na t A. +Proof. + intros wf h [|n] decl e. + - simpl in *. inversion e. subst. clear e. simpl. + rewrite lift_rename. rewrite rename_inst. + autorewrite with sigma. + split. + + eapply meta_conv. + * econstructor; auto; reflexivity. + * rewrite lift0_inst /=. + now autorewrite with sigma. + + intros b [= ->]. + left. exists 0. eexists _; intuition eauto. + simpl. sigma. reflexivity. + - cbn -[rshiftk] in *. + specialize (h _ _ e) as [h1 h2]. + split. + + sigma. sigma in h1. + eapply meta_conv. + * epose proof (weakening_rename_typing (Γ' := []) (Γ'' := [_]) wf h1). + simpl in X. + sigma in X. eapply X. + * eapply inst_ext. rewrite ren_lift_renaming. + now sigma. + + intros b hb. + specialize (h2 _ hb) as [[x' [decl' [hrel [hnth hdecl]]]]|]. + * left. exists (S x'), decl'. + split. + ** unfold subst_compose at 1. now rewrite hrel. + ** cbn -[rshiftk]. split; auto. + destruct (decl_body decl') => //. cbn -[rshiftk] in hdecl |- *. + noconf hdecl. f_equal. + replace (S (S n)) with (S n + 1) by lia. + rewrite -shiftk_compose subst_compose_assoc. + rewrite -Upn_1_Up (shiftn_Upn 1) -subst_compose_assoc -inst_assoc -H. + sigma. now rewrite ren_shift compose_ren. + * right. + unfold subst_compose at 1. rewrite e0. + now rewrite inst_assoc. +Qed. + +Lemma well_subst_ext Σ Δ σ σ' Γ : + Σ ;;; Δ ⊢ σ : Γ -> + σ =1 σ' -> + Σ ;;; Δ ⊢ σ' : Γ. +Proof. + intros Hσ eq n decl hnth. + specialize (Hσ n decl hnth) as [hσ hb]. + split. + - rewrite -(eq n). + eapply meta_conv. 2:now rewrite -eq. assumption. + - intros b hd. specialize (hb b hd). + destruct hb as [[x' [decl' [eqn [hnth' hsome]]]]|h]. + * left; exists x', decl'. rewrite -(eq n). repeat split; auto. + now rewrite -eq. + * right. now rewrite -(eq n) -eq. +Qed. + +Lemma well_subst_app {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ Δ'} : + wf_local Σ (Δ ,,, inst_context σ Δ') -> + Σ ;;; Δ ⊢ σ : Γ -> + Σ ;;; Δ ,,, inst_context σ Δ' ⊢ ⇑^#|Δ'| σ : Γ ,,, Δ'. +Proof. + induction Δ' as [|[na [b|] ty] Δ']; simpl => hwf hsub. + - eapply well_subst_ext; eauto. + now rewrite Upn_0. + - rewrite inst_context_snoc. + eapply well_subst_ext. + 2:now rewrite Upn_S. simpl. + apply well_subst_Up'. + * rewrite inst_context_snoc in hwf. + apply hwf. + * rewrite inst_context_snoc in hwf. + depelim hwf. apply IHΔ' => //. + - rewrite inst_context_snoc. + eapply well_subst_ext. + 2:now rewrite Upn_S. simpl. + apply well_subst_Up. + * rewrite inst_context_snoc in hwf. + apply hwf. + * rewrite inst_context_snoc in hwf. + depelim hwf. apply IHΔ' => //. +Qed. + +Lemma well_subst_app_up {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ Δ'} : + wf_local Σ (Δ ,,, inst_context σ Δ') -> + Σ ;;; Δ ⊢ σ : Γ -> + Σ ;;; Δ ,,, inst_context σ Δ' ⊢ up #|Δ'| σ : Γ ,,, Δ'. +Proof. + intros wf Hσ. + eapply well_subst_ext. + 2:now rewrite up_Upn. + now apply well_subst_app. +Qed. + +Lemma mapi_context_inst σ ctx : + mapi_context (fun k : nat => inst (up k σ)) ctx = + inst_context σ ctx. +Proof. + now rewrite mapi_context_fold; setoid_rewrite up_Upn. +Qed. + +Lemma inst_predicate_pcontext f (p : predicate term) : + inst_context f (pcontext p) = pcontext (inst_predicate f p). +Proof. now rewrite /inst_predicate /= mapi_context_inst. Qed. + +Lemma inst_predicate_preturn f p : + inst (⇑^#|p.(pcontext)| f) (preturn p) = + preturn (inst_predicate f p). +Proof. rewrite -up_Upn. reflexivity. Qed. + +Lemma inst_mkLambda_or_LetIn f d t : + inst f (mkLambda_or_LetIn d t) = + mkLambda_or_LetIn (inst_decl f d) (inst (⇑ f) t). +Proof. + destruct d as [na [] ty]; rewrite /= /mkLambda_or_LetIn /=; f_equal; now rewrite up_Up. +Qed. + +Lemma inst_it_mkLambda_or_LetIn f ctx t : + inst f (it_mkLambda_or_LetIn ctx t) = + it_mkLambda_or_LetIn (inst_context f ctx) (inst (⇑^#|ctx| f) t). +Proof. + move: t. + induction ctx; simpl => t. + - now rewrite Upn_0. + - rewrite /= IHctx inst_context_snoc /snoc /=. f_equal. + now rewrite inst_mkLambda_or_LetIn /=; sigma. +Qed. + +Lemma inst_reln f ctx n acc : + forallb (closedn (n + #|ctx|)) acc -> + map (inst (⇑^(n + #|ctx|) f)) (reln acc n ctx) = + reln acc n ctx. +Proof. + induction ctx in n, acc |- *; simpl; auto. + - intros clacc. solve_all. + now rewrite inst_closed. + - intros clacc. + destruct a as [? [] ?]. + * rewrite Nat.add_succ_r. + change (S (n + #|ctx|)) with (S n + #|ctx|). + rewrite Nat.add_1_r IHctx // /= -Nat.add_succ_r //. + * rewrite Nat.add_succ_r Nat.add_1_r. rewrite (IHctx (S n)) /= // -Nat.add_succ_r //. + simpl. rewrite clacc andb_true_r. + eapply Nat.ltb_lt. lia. +Qed. + +Lemma inst_to_extended_list f ctx : + map (inst (⇑^#|ctx| f)) (to_extended_list ctx) = to_extended_list ctx. +Proof. + unfold to_extended_list, to_extended_list_k. + now apply (inst_reln _ _ 0). +Qed. + +Lemma inst_subst : + forall f s n t, + inst (⇑^n f) (subst s n t) = + subst (map (inst f) s) n (inst (⇑^n (⇑^#|s| f)) t). +Proof. + intros f s n t. + autorewrite with sigma. + eapply inst_ext. intro i. unfold Upn. + unfold subst_consn, shiftk, subst_compose. simpl. + destruct (Nat.ltb_spec i n). + - rewrite idsn_lt //. simpl. + rewrite idsn_lt //. + - rewrite nth_error_idsn_None //. len. + rewrite !inst_assoc. unfold subst_compose. simpl. + destruct (Nat.ltb_spec (i - n) #|s|). + * rewrite idsn_lt //. simpl. + rewrite nth_error_idsn_None //; try lia. + rewrite nth_error_map. + replace (n + (i - n) - n) with (i - n) by lia. + destruct nth_error eqn:hnth => /=. + ** sigma. apply inst_ext. + intros k. cbn. + elim: (Nat.ltb_spec (n + k) n); try lia. + intros. eapply nth_error_Some_length in hnth. + rewrite nth_error_idsn_None //. unfold subst_compose. + lia_f_equal. + ** eapply nth_error_None in hnth. lia. + * len. + rewrite nth_error_idsn_None; try lia. + rewrite inst_assoc. simpl. + destruct nth_error eqn:hnth. + ** eapply nth_error_Some_length in hnth. lia. + ** simpl. + eapply nth_error_None in hnth. + rewrite nth_error_idsn_None; try lia. + unfold subst_compose. simpl. + assert (n + (i - n - #|s|) - n = (i - n - #|s|)) as -> by lia. + apply inst_ext => k. + rewrite nth_error_idsn_None //; try lia. + destruct nth_error eqn:hnth'. + + eapply nth_error_Some_length in hnth'. len in hnth'. lia. + + simpl. lia_f_equal. +Qed. + +Lemma inst_context_subst_k f s k Γ : + inst_context (up k f) (subst_context s k Γ) = + subst_context (map (inst f) s) k (inst_context (⇑^(k + #|s|) f) Γ). +Proof. + rewrite !inst_context_alt !subst_context_alt. + rewrite !mapi_mapi. apply mapi_ext => i x. + rewrite /subst_decl !compose_map_decl. + apply map_decl_ext => t. + len. + generalize (Nat.pred #|Γ| - i). + intros. rewrite up_Upn -Upn_Upn inst_subst. + now sigma. +Qed. + +Lemma inst_context_subst f s Γ : + inst_context f (subst_context s 0 Γ) = + subst_context (map (inst f) s) 0 (inst_context (⇑^#|s| f) Γ). +Proof. + now rewrite -inst_context_subst_k up_Upn Upn_0. +Qed. + +Lemma inst_case_predicate_context {Σ} {wfΣ : wf Σ} {ind mdecl idecl f p} : + declared_inductive Σ ind mdecl idecl -> + wf_predicate mdecl idecl p -> + inst_context f (case_predicate_context ind mdecl idecl p) = + case_predicate_context ind mdecl idecl (inst_predicate f p). +Proof. + intros decli wfp. + unfold case_predicate_context. simpl. + unfold id. unfold case_predicate_context_gen. + rewrite /inst_context. + rewrite -map2_set_binder_name_fold //. + - len. len. + now rewrite -(wf_predicate_length_pcontext wfp). + - rewrite forget_types_mapi_context. f_equal. + rewrite /pre_case_predicate_context_gen fold_context_k_snoc0 /= /snoc. + f_equal. + * rewrite /map_decl /=. f_equal. + len. rewrite inst_mkApps /=. f_equal. + rewrite !map_app !map_map_compose. f_equal. + + solve_all. + eapply All_refl => x. + now sigma. + + now rewrite inst_to_extended_list. + * rewrite -/(inst_context f _). + rewrite inst_context_subst map_rev. + f_equal. + rewrite List.rev_length inst_closedn_ctx //. + pose proof (closedn_ctx_expand_lets (ind_params mdecl) (ind_indices idecl) + (declared_inductive_closed_pars_indices _ decli)). + rewrite (wf_predicate_length_pars wfp). + rewrite (declared_minductive_ind_npars decli). + now rewrite closedn_subst_instance_context. +Qed. + +Lemma inst_wf_predicate mdecl idecl f p : + wf_predicate mdecl idecl p -> + wf_predicate mdecl idecl (inst_predicate f p). +Proof. + intros []. split. + - now len. + - now rewrite forget_types_mapi_context. +Qed. + +Lemma inst_wf_branch cdecl f br : + wf_branch cdecl br -> + wf_branch cdecl (map_branch_shift inst up f br). +Proof. + unfold wf_branch, wf_branch_gen. + now rewrite forget_types_mapi_context. +Qed. + +Lemma inst_wf_branches cdecl f brs : + wf_branches cdecl brs -> + wf_branches cdecl (map (fun br => map_branch_shift inst up f br) brs). +Proof. + unfold wf_branches, wf_branches_gen. + intros h. solve_all. eapply Forall2_map_right. + eapply Forall2_impl; eauto using inst_wf_branch. +Qed. + +Lemma wf_local_app_inst (Σ : global_env_ext) {wfΣ : wf Σ} Γ Δ : + All_local_env (lift_typing (fun (Σ : global_env_ext) (Γ' : context) (t T : term) => + forall Δ σ, + wf_local Σ Δ -> + Σ ;;; Δ ⊢ σ : (Γ ,,, Γ') -> + Σ ;;; Δ |- t.[σ] : T.[σ]) Σ) Δ -> + forall Δ' σ, + Σ ;;; Δ' ⊢ σ : Γ -> + wf_local Σ Δ' -> + wf_local Σ (Δ' ,,, inst_context σ Δ). +Proof. + intros. + induction X. + - now simpl. + - simpl. destruct t0 as [s Hs]. + rewrite inst_context_snoc /=. constructor; auto. + red. simpl. exists s. + eapply (Hs (Δ' ,,, inst_context σ Γ0) (⇑^#|Γ0| σ)) => //. + eapply well_subst_app; auto. + - simpl. destruct t0 as [s Hs]. simpl in t1. + rewrite inst_context_snoc /=. constructor; auto. + * simpl. exists s. + eapply (Hs (Δ' ,,, inst_context σ Γ0) (⇑^#|Γ0| σ)) => //. + eapply well_subst_app; auto. + * simpl. apply t1 => //. + eapply well_subst_app; eauto. +Qed. + +Definition inst_constructor_body mdecl f c := + map_constructor_body #|mdecl.(ind_params)| #|mdecl.(ind_bodies)| + (fun k => inst (up k f)) c. + +Lemma inst_closed_decl k f d : closed_decl k d -> map_decl (inst (up k f)) d = d. +Proof. + rewrite /map_decl. + destruct d as [? [] ?] => /=. + - move/andP=> [] clt clty. + rewrite up_Upn !inst_closed //. + - move=> clt. rewrite !up_Upn !inst_closed //. +Qed. + +Lemma inst_closed_constructor_body mdecl cdecl f : + closed_constructor_body mdecl cdecl -> + inst_constructor_body mdecl f cdecl = cdecl. +Proof. + rewrite /closed_constructor_body /inst_constructor_body /map_constructor_body. + move/andP=> [] /andP [] clctx clind clty. + destruct cdecl; cbn -[fold_context_k] in *; f_equal. + + move: clctx. rewrite test_context_k_eq. + apply alli_fold_context_k => i d cldecl. + rewrite inst_closed_decl //. + red; rewrite -cldecl; lia_f_equal. + + solve_all. rewrite up_Upn inst_closed //. + red. rewrite -H. lia_f_equal. + + now rewrite up_Upn inst_closed. +Qed. + +Lemma inst_cstr_args mdecl f cdecl : + cstr_args (inst_constructor_body mdecl f cdecl) = + inst_context (up (#|mdecl.(ind_params)| + #|ind_bodies mdecl|) f) (cstr_args cdecl). +Proof. + simpl. unfold inst_context. + apply fold_context_k_ext => i t. + now rewrite !up_Upn !Upn_Upn. +Qed. + +Lemma inst_closedn_terms f n ts : + forallb (closedn n) ts -> map (inst (up n f)) ts = ts. +Proof. + solve_all. + now rewrite up_Upn inst_closed. +Qed. + +Lemma inst_closed_extended_subst f Γ : + closed_ctx Γ -> + map (inst (up (context_assumptions Γ) f)) (extended_subst Γ 0) = extended_subst Γ 0. +Proof. + intros cl. apply inst_closedn_terms. + now apply (closedn_extended_subst_gen Γ 0 0). +Qed. + +Lemma inst_lift : + forall f n k t, + inst (⇑^(n + k) f) (lift n k t) = lift n k (inst (⇑^k f) t). +Proof. + intros f n k t. sigma. + eapply inst_ext. + rewrite -Upn_Upn Nat.add_comm Upn_Upn. + now rewrite !Upn_compose shiftn_Upn. +Qed. + +Lemma inst_context_lift f n k Γ : + inst_context (up (n + k) f) (lift_context n k Γ) = + lift_context n k (inst_context (up k f) Γ). +Proof. + rewrite !inst_context_alt !lift_context_alt. + rewrite !mapi_mapi. apply mapi_ext => i x. + rewrite /lift_decl !compose_map_decl. + apply map_decl_ext => t; len. + generalize (Nat.pred #|Γ| - i). + intros. + rewrite !up_Upn -Upn_Upn. + rewrite (Nat.add_comm n k) Nat.add_assoc Nat.add_comm. + now rewrite inst_lift Upn_Upn. +Qed. + +Lemma inst_inds f ind pu bodies : map (inst f) (inds ind pu bodies) = inds ind pu bodies. +Proof. + unfold inds. + induction #|bodies|; simpl; auto. f_equal. + apply IHn. +Qed. + +Lemma closed_ctx_args n bctx ctx : + #|bctx| = #|ctx| -> + closedn_ctx n ctx -> + closedn_ctx n (map2 set_binder_name bctx ctx). +Proof. + induction ctx in bctx |- *; destruct bctx; simpl; auto. + move=> [=] hlen. + move/andP=> [cla clctx]. + rewrite IHctx // /=. + rewrite map2_length //. + now rewrite hlen. +Qed. + +Lemma inst_case_branch_context_gen ind mdecl f p bctx cdecl : + closedn_ctx (#|ind_params mdecl| + #|ind_bodies mdecl|) + (cstr_args cdecl) -> + closed_ctx (ind_params mdecl) -> + #|bctx| = #|cstr_args cdecl| -> + #|pparams p| = context_assumptions (ind_params mdecl) -> + inst_context f (case_branch_context ind mdecl p bctx cdecl) = + case_branch_context ind mdecl (inst_predicate f p) bctx + (inst_constructor_body mdecl f cdecl). +Proof. + intros clargs clpars. unfold case_branch_context, case_branch_context_gen. + rewrite inst_cstr_args. + cbn -[fold_context_k]. + intros hlen hlen'. + rewrite map2_set_binder_name_fold //. + change (fold_context_k + (fun i : nat => inst (up i (up (ind_npars mdecl + #|ind_bodies mdecl|) f)))) with + (inst_context (up (ind_npars mdecl + #|ind_bodies mdecl|) f)). + rewrite inst_context_subst map_rev List.rev_length. f_equal. + unfold id. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + simpl. len. + rewrite inst_context_subst; len. + rewrite hlen'. + rewrite -{1}(context_assumptions_subst_instance (puinst p)). + rewrite -up_Upn. + rewrite inst_closed_extended_subst. + { now rewrite closedn_subst_instance_context. } + f_equal. + rewrite -Upn_Upn -up_Upn Nat.add_comm. + rewrite inst_context_lift. f_equal. + rewrite inst_context_subst_k inst_inds. len. + f_equal. + rewrite inst_closedn_ctx //. + * rewrite closedn_subst_instance_context. + now rewrite closed_ctx_args. + * rewrite -/(inst_context (up (#|ind_params mdecl| + #|ind_bodies mdecl|) f) + (map2 set_binder_name bctx (cstr_args cdecl))). + rewrite up_Upn inst_closedn_ctx //. + now rewrite closed_ctx_args. +Qed. + +Lemma forallb_map_spec {A B : Type} {p : A -> bool} + {l : list A} {f g : A -> B} : + (forall x : A, p x -> f x = g x) -> + forallb p l -> + map f l = map g l. +Proof. + induction l; simpl; trivial. + rewrite andb_and. intros Hx [px pl]. + f_equal. - now apply Hx. - now apply IHl. +Qed. + +Lemma inst_case_branch_type {Σ} {wfΣ : wf Σ} f (ci : case_info) i mdecl idecl p br cdecl : + declared_constructor Σ (ci.(ci_ind), i) mdecl idecl cdecl -> + wf_predicate mdecl idecl p -> + wf_branch cdecl br -> + let ptm := it_mkLambda_or_LetIn (pcontext p) (preturn p) in + let p' := inst_predicate f p in + let ptm' := it_mkLambda_or_LetIn (pcontext p') (preturn p') in + case_branch_type ci mdecl idecl + (inst_predicate f p) + (inst_branch f br) + ptm' i (inst_constructor_body mdecl f cdecl) = + map_pair (inst_context f) (inst (up #|bcontext br| f)) + (case_branch_type ci mdecl idecl p br ptm i cdecl). +Proof. + intros decli wfp wfb ptm p' ptm'. + rewrite /case_branch_type /case_branch_type_gen /map_pair /=. + rewrite inst_case_branch_context_gen //. + { epose proof (declared_constructor_closed_args decli). now rewrite Nat.add_comm. } + { eapply (declared_inductive_closed_params decli). } + { len. apply (wf_branch_length wfb). } + { rewrite -(declared_minductive_ind_npars decli). + apply (wf_predicate_length_pars wfp). } + f_equal. + { now rewrite forget_types_mapi_context. } + rewrite inst_mkApps map_app map_map_compose. + rewrite (wf_branch_length wfb). + f_equal. + * rewrite /ptm' /ptm !lift_it_mkLambda_or_LetIn !inst_it_mkLambda_or_LetIn. + rewrite !lift_rename. f_equal. + ++ rewrite /p'. len. rewrite mapi_context_inst. + epose proof (inst_context_lift f #|cstr_args cdecl| 0). + rewrite Nat.add_0_r in H. + rewrite H. now rewrite up_Upn Upn_0. + ++ rewrite /p'. rewrite Nat.add_0_r. simpl. + len. rewrite !up_Upn -Upn_Upn. rewrite - !lift_rename. + now rewrite Nat.add_comm inst_lift. + * rewrite /= inst_mkApps /=. f_equal. + ++ rewrite !map_map_compose /id. + generalize (declared_constructor_closed_indices decli). + apply forallb_map_spec => t clt. + rewrite !up_Upn. + rewrite /expand_lets /expand_lets_k. + rewrite -inst_subst_instance. len. + rewrite inst_subst map_rev List.rev_length. f_equal. + rewrite inst_subst. rewrite (wf_predicate_length_pars wfp). + rewrite (declared_minductive_ind_npars decli). + rewrite -{2}(context_assumptions_subst_instance (puinst p) (ind_params mdecl)). + setoid_rewrite <- up_Upn at 1. + rewrite inst_closed_extended_subst. + { rewrite closedn_subst_instance_context. + apply (declared_inductive_closed_params decli). } + f_equal. len. rewrite - !Upn_Upn. + rewrite (Nat.add_comm _ (context_assumptions _)) inst_lift. + f_equal. rewrite Nat.add_comm inst_subst. + rewrite inst_inds. f_equal. + rewrite - Upn_Upn. len. + rewrite inst_closed ?closedn_subst_instance //. + { eapply closed_upwards; tea; lia. } + etransitivity. + { eapply inst_ext. intros x. + rewrite -(Upn_subst_instance _ _ _ _). reflexivity. } + rewrite inst_closed ?closedn_subst_instance //. + { eapply closed_upwards; tea; lia. } + ++ unfold id. f_equal. f_equal. + rewrite map_app map_map_compose. + rewrite map_map_compose. + setoid_rewrite up_Upn. len. + f_equal. + { apply map_ext. intros. now sigma. } + rewrite inst_to_extended_list. + now rewrite /to_extended_list /to_extended_list_k reln_fold. +Qed. + +Axiom fix_guard_inst : forall Σ Γ Δ mfix σ, + Σ ;;; Γ ⊢ σ : Δ -> + let mfix' := map (map_def (inst σ) (inst (up (List.length mfix) σ))) mfix in + fix_guard Σ Δ mfix -> + fix_guard Σ Γ mfix'. + +Axiom cofix_guard_inst : forall Σ Γ Δ mfix σ, + Σ ;;; Γ ⊢ σ : Δ -> + let mfix' := map (map_def (inst σ) (inst (up (List.length mfix) σ))) mfix in + cofix_guard Σ Δ mfix -> + cofix_guard Σ Γ mfix'. + +Instance map_def_ext {A B} : Proper (`=1` ==> `=1` ==> `=1`) (@map_def A B). +Proof. + intros f g Hfg f' g' Hfg' x. + unfold map_def; destruct x; simpl. + now rewrite Hfg Hfg'. +Qed. + +Lemma inst_decompose_prod_assum f Γ t : + decompose_prod_assum (inst_context f Γ) (inst (up #|Γ| f) t) + = let '(Γ, t) := decompose_prod_assum Γ t in + let '(Γ', t') := decompose_prod_assum [] (inst (up #|Γ| f) t) in + (Γ' ++ inst_context f Γ, t'). +Proof. + induction t in Γ |- *. all: simpl; try (rewrite ?app_nil_r; reflexivity). + - simpl. + now rewrite decompose_prod_assum_ctx. + - specialize (IHt2 (Γ ,, vass na t1)). + rewrite inst_context_snoc /= in IHt2. + rewrite <-up_Upn in IHt2. + simpl. now rewrite up_up IHt2. + - specialize (IHt3 (Γ ,, vdef na t1 t2)). + rewrite inst_context_snoc /= in IHt3. + simpl. rewrite <- up_Upn in IHt3. + simpl. now rewrite up_up IHt3. +Qed. + +Lemma decompose_prod_assum_mkApps ctx ind u args : + decompose_prod_assum ctx (mkApps (tInd ind u) args) = (ctx, mkApps (tInd ind u) args). +Proof. + apply (decompose_prod_assum_it_mkProd ctx []). + now rewrite is_ind_app_head_mkApps. +Qed. + +Lemma inst_app_context f Γ Δ : + inst_context f (Γ ,,, Δ) = + inst_context f Γ ,,, inst_context (up #|Γ| f) Δ. +Proof. + rewrite /inst_context fold_context_k_app /app_context. f_equal. + apply fold_context_k_ext. intros i x. now rewrite up_Upn Nat.add_comm Upn_Upn. +Qed. + +Lemma inst_smash_context f Γ Δ : + inst_context f (smash_context Γ Δ) = + smash_context (inst_context (up #|Δ| f) Γ) (inst_context f Δ). +Proof. + rewrite up_Upn. + induction Δ as [|[na [b|] ty] Δ] in Γ |- *; simpl; auto; + rewrite ?Upn_0 // ?inst_context_snoc IHΔ /=; len. + - f_equal. now rewrite inst_context_subst /= -Upn_Upn. + - f_equal. rewrite inst_app_context /map_decl /= /app_context. + f_equal. + * now rewrite up_Upn -Upn_Upn. + * rewrite /inst_context fold_context_k_tip /map_decl /=. do 2 f_equal. + now rewrite Upn_0. +Qed. + +Lemma nth_error_inst_context f Γ n : + nth_error (inst_context f Γ) n = + option_map (map_decl (inst (up (#|Γ| - S n) f))) (nth_error Γ n). +Proof. + induction Γ in n |- *; intros. + - simpl. unfold inst_context, fold_context_k; simpl; rewrite nth_error_nil. easy. + - simpl. destruct n; rewrite inst_context_snoc. + + simpl. rewrite up_Upn. lia_f_equal. + + simpl. rewrite Nat.sub_succ -IHΓ; simpl in *; (lia || congruence). +Qed. + +Lemma up_0 f : up 0 f =1 f. +Proof. + rewrite /up /=; setoid_rewrite Nat.sub_0_r. + intros i. now rewrite rename_ren_id. +Qed. + +Lemma inst_check_one_fix f (mfix : mfixpoint term) d x : + check_one_fix d = Some x -> + check_one_fix (map_def (inst f) (inst (up #|mfix| f)) d) = Some x. +Proof. + destruct d; simpl. + move: (inst_decompose_prod_assum f [] dtype). + rewrite up_0. intros ->. + destruct decompose_prod_assum. + destruct decompose_prod_assum as [Γ' t']. + rewrite smash_context_app (smash_context_acc (inst_context _ _)). + rewrite -(inst_smash_context f []). + destruct nth_error eqn:hnth => //. + have hlen := nth_error_Some_length hnth. len in hlen. + simpl in hlen. + destruct (nth_error (List.rev (_ ++ inst_context _ _)) _) eqn:hnth'. + 2:{ eapply nth_error_None in hnth'. len in hnth'. simpl in hnth'. lia. } + rewrite nth_error_rev_inv in hnth; len; auto. + len in hnth. simpl in hnth. + rewrite nth_error_rev_inv in hnth'; len; auto; try lia. + len in hnth'. simpl in hnth'. + rewrite nth_error_app_ge in hnth'; len; try lia. len in hnth'. + simpl in hnth'. + replace (context_assumptions Γ' + context_assumptions c - S rarg - context_assumptions Γ') with + (context_assumptions c - S rarg) in hnth' by lia. + rewrite /= nth_error_inst_context /= hnth /= in hnth'. noconf hnth'. + simpl. + destruct decompose_app eqn:da. len. + destruct t0 => /= //. + eapply decompose_app_inv in da. rewrite da. + rewrite inst_mkApps. simpl. rewrite decompose_app_mkApps //. +Qed. + +Lemma inst_check_one_cofix f (mfix : mfixpoint term) d x : + check_one_cofix d = Some x -> + check_one_cofix (map_def (inst f) (inst (up #|mfix| f)) d) = Some x. +Proof. + destruct d; simpl. + move: (inst_decompose_prod_assum f [] dtype). + rewrite up_0. intros ->. + destruct decompose_prod_assum. + destruct decompose_prod_assum eqn:dp. + destruct decompose_app eqn:da. + destruct (decompose_app t0) eqn:da'. + destruct t1 => /= //. + eapply decompose_app_inv in da. subst t. + simp sigma in dp. rewrite decompose_prod_assum_mkApps /= in dp. + noconf dp. rewrite decompose_app_mkApps // in da'. noconf da' => //. +Qed. + +Lemma inst_wf_fixpoint Σ f mfix : + wf_fixpoint Σ mfix -> + wf_fixpoint Σ (map (map_def (inst f) (inst (up #|mfix| f))) mfix). +Proof. + unfold wf_fixpoint. + rewrite map_map_compose. + destruct (map_option_out (map check_one_fix mfix)) as [[]|] eqn:hmap => //. + eapply map_option_out_impl in hmap. + 2:{ intros x y. apply (inst_check_one_fix f mfix). } + now rewrite hmap. +Qed. + +Lemma inst_wf_cofixpoint Σ f mfix : + wf_cofixpoint Σ mfix -> + wf_cofixpoint Σ (map (map_def (inst f) (inst (up #|mfix| f))) mfix). +Proof. + rewrite /wf_cofixpoint map_map_compose. + destruct (map_option_out (map check_one_cofix mfix)) as [[]|] eqn:hmap => //. + eapply map_option_out_impl in hmap. + 2:{ intros x y. apply (inst_check_one_cofix f mfix). } + now rewrite hmap. +Qed. + +Lemma inst_extended_subst f Γ : + map (inst (up (context_assumptions Γ) f)) (extended_subst Γ 0) = + extended_subst (inst_context f Γ) 0. +Proof. + induction Γ as [|[na [b|] ty] Γ]; auto; rewrite inst_context_snoc /=; len. + - rewrite !inst_subst0. + rewrite IHΓ. len. f_equal. f_equal. + rewrite up_Upn -Upn_Upn Nat.add_comm. + now rewrite inst_lift. + - f_equal; auto. + rewrite !(lift_extended_subst _ 1). + rewrite map_map_compose. + setoid_rewrite up_Upn; setoid_rewrite lift0_inst; setoid_rewrite inst_assoc. + setoid_rewrite (Upn_Upn 1); setoid_rewrite shiftn_Upn; + setoid_rewrite <- up_Upn; setoid_rewrite <-inst_assoc. + setoid_rewrite <- lift0_inst. + rewrite -map_map_compose. now f_equal. +Qed. + +Lemma inst_iota_red : + forall f pars args br, + #|skipn pars args| = context_assumptions br.(bcontext) -> + inst f (iota_red pars args br) = + iota_red pars (map (inst f) args) (inst_branch f br). +Proof. + intros f pars args br hlen. + unfold iota_red. + rewrite inst_subst0 map_rev map_skipn. f_equal. + rewrite List.rev_length /expand_lets /expand_lets_k. + rewrite !inst_subst0. len. + rewrite -up_Upn. rewrite hlen inst_extended_subst. + rewrite mapi_context_fold. setoid_rewrite up_Upn. + f_equal. len. + now rewrite -Upn_Upn Nat.add_comm inst_lift. +Qed. + +Lemma inst_unfold_fix : + forall mfix idx narg fn f, + unfold_fix mfix idx = Some (narg, fn) -> + unfold_fix (map (map_def (inst f) (inst (up #|mfix| f))) mfix) idx + = Some (narg, inst f fn). +Proof. + intros mfix idx narg fn f h. + unfold unfold_fix in *. rewrite nth_error_map. + case_eq (nth_error mfix idx). + 2: intro neq ; rewrite neq in h ; discriminate. + intros d e. rewrite e in h. + inversion h. clear h. + simpl. + f_equal. f_equal. + rewrite inst_subst0. rewrite fix_subst_length. + f_equal. + * unfold fix_subst. rewrite map_length. + generalize #|mfix| at 2 3. intro n. + induction n. + - reflexivity. + - simpl. f_equal. rewrite IHn. reflexivity. + * now rewrite up_Upn. +Qed. + +Lemma inst_unfold_cofix : + forall mfix idx narg fn f, + unfold_cofix mfix idx = Some (narg, fn) -> + unfold_cofix (map (map_def (inst f) (inst (up #|mfix| f))) mfix) idx + = Some (narg, inst f fn). +Proof. + intros mfix idx narg fn f h. + unfold unfold_cofix in *. rewrite nth_error_map. + case_eq (nth_error mfix idx). + 2: intro neq ; rewrite neq in h ; discriminate. + intros d e. rewrite e in h. + inversion h. + simpl. f_equal. f_equal. + rewrite inst_subst0. rewrite cofix_subst_length. + rewrite up_Upn. + f_equal. + unfold cofix_subst. rewrite map_length. + generalize #|mfix| at 2 3. intro n. + induction n. + - reflexivity. + - simpl. rewrite up_Upn. + f_equal. rewrite IHn. reflexivity. +Qed. + +Definition rigid_head t := + match t with + | tVar _ + | tSort _ + | tConst _ _ + | tInd _ _ + | tConstruct _ _ _ => true + | _ => false + end. + +Lemma decompose_app_inst : + forall f t u l, + decompose_app t = (u, l) -> + rigid_head u -> + decompose_app (inst f t) = (inst f u, map (inst f) l). +Proof. + assert (aux : forall f t u l acc, + decompose_app_rec t acc = (u, l) -> + rigid_head u -> + decompose_app_rec (inst f t) (map (inst f) acc) = + (inst f u, map (inst f) l) + ). + { intros f t u l acc h. + induction t in acc, h |- *. + all: simpl in *; try solve [ inversion h ; reflexivity ]. + * noconf h => /= //. + * simpl. intros ru. simpl in h. specialize IHt1 with (1 := h). + now apply IHt1. + } + intros f t u l. + unfold decompose_app. + eapply aux. +Qed. + +Lemma isConstruct_app_inst : + forall t f, + isConstruct_app t -> + isConstruct_app (inst f t). +Proof. + intros t f h. + unfold isConstruct_app in *. + case_eq (decompose_app t). intros u l e. + apply decompose_app_inst with (f := f) in e as e'. + * destruct (decompose_app t); simpl in *. destruct t0 => /= //. noconf e. + now rewrite e'. + * rewrite e in h. simpl in h. + destruct u => //. +Qed. + +Lemma is_constructor_inst : + forall n l f, + is_constructor n l -> + is_constructor n (map (inst f) l). +Proof. + intros n l f h. + unfold is_constructor in *. + rewrite nth_error_map. + destruct nth_error. + - simpl. apply isConstruct_app_inst. assumption. + - simpl. discriminate. +Qed. + +Lemma inst_predicate_set_pparams f p params : + inst_predicate f (set_pparams p params) = + set_pparams (inst_predicate f p) (map (inst f) params). +Proof. reflexivity. Qed. + +Lemma inst_predicate_set_pcontext f p pcontext' : + #|pcontext'| = #|p.(pcontext)| -> + inst_predicate f (set_pcontext p pcontext') = + set_pcontext (inst_predicate f p) + (mapi_context (fun k => inst (up k f)) pcontext'). +Proof. rewrite /inst_predicate /= /set_pcontext. simpl. intros ->. reflexivity. Qed. + +Lemma inst_predicate_set_preturn f p pret : + inst_predicate f (set_preturn p pret) = + set_preturn (inst_predicate f p) (inst (up #|pcontext p| f) pret). +Proof. reflexivity. Qed. + +Lemma usubst_Up {Γ Δ σ na A} : + usubst Γ σ Δ -> + usubst (Γ ,, vass na A) (⇑ σ) (Δ ,, vass na A.[σ]). +Proof. + intros h [|n] decl e. + - simpl in *. inversion e. subst. clear e. simpl => //. + - cbn -[rshiftk] in *. + specialize (h _ _ e) as h1. + intros b hb. + specialize (h1 _ hb) as [[x' [decl' [hrel [hnth hdecl]]]]|]. + * left. exists (S x'), decl'. + split. + ** unfold subst_compose at 1. now rewrite hrel. + ** cbn -[rshiftk]. split; auto. + destruct (decl_body decl') => //. cbn -[rshiftk] in hdecl |- *. + noconf hdecl. f_equal. + replace (S (S n)) with (S n + 1) by lia. + rewrite -shiftk_compose subst_compose_assoc. + rewrite -Upn_1_Up (shiftn_Upn 1) -subst_compose_assoc -inst_assoc -H. + sigma. now rewrite ren_shift compose_ren. + * right. + unfold subst_compose at 1. rewrite e0. + now rewrite inst_assoc. +Qed. + +Lemma usubst_Up' {Γ Δ σ na t A} : + usubst Γ σ Δ -> + usubst (Γ ,, vdef na t A) (⇑ σ) (Δ ,, vdef na t.[σ] A.[σ]). +Proof. + 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. + intros b hb. + specialize (h2 _ hb) as [[x' [decl' [hrel [hnth hdecl]]]]|]. + * left. exists (S x'), decl'. + split. + ** unfold subst_compose at 1. now rewrite hrel. + ** cbn -[rshiftk]. split; auto. + destruct (decl_body decl') => //. cbn -[rshiftk] in hdecl |- *. + noconf hdecl. f_equal. + replace (S (S n)) with (S n + 1) by lia. + rewrite -shiftk_compose subst_compose_assoc. + rewrite -Upn_1_Up (shiftn_Upn 1) -subst_compose_assoc -inst_assoc -H. + sigma. now rewrite ren_shift compose_ren. + * right. + unfold subst_compose at 1. rewrite e0. + now rewrite inst_assoc. +Qed. + +Lemma usubst_ext {Δ σ σ' Γ} : + usubst Γ σ Δ -> + σ =1 σ' -> + usubst Γ σ' Δ. +Proof. + 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]. + * left; exists x', decl'. rewrite -(eq n). repeat split; auto. + now rewrite -eq. + * right. now rewrite -(eq n) -eq. +Qed. + +Lemma usubst_up_vass {Γ Δ σ na A} : + usubst Γ σ Δ -> + usubst (Γ ,, vass na A) (up 1 σ) (Δ ,, vass na A.[σ]). +Proof. + intros H. + eapply usubst_ext; [eapply usubst_Up; tea|]. + now rewrite up_Upn; sigma. +Qed. + +Lemma usubst_up_vdef {Γ Δ σ na t A} : + usubst Γ σ Δ -> + usubst (Γ ,, vdef na t A) (up 1 σ) (Δ ,, vdef na t.[σ] A.[σ]). +Proof. + intros H. + eapply usubst_ext; [eapply usubst_Up'; tea|]. + now rewrite up_Upn; sigma. +Qed. + +Lemma usubst_app {Γ Δ σ Δ'} : + usubst Γ σ Δ -> + usubst (Γ ,,, Δ') (⇑^#|Δ'| σ) (Δ ,,, inst_context σ Δ'). +Proof. + intros hs. + induction Δ' as [|[na [b|] ty] Δ']; simpl. + - eapply usubst_ext; eauto. + now rewrite Upn_0. + - rewrite inst_context_snoc. + eapply usubst_ext. + 2:now rewrite Upn_S. simpl. + now apply usubst_Up'. + - rewrite inst_context_snoc. + eapply usubst_ext. + 2:now rewrite Upn_S. simpl. + now apply usubst_Up. +Qed. + +Lemma usubst_app_up {Γ Δ σ Δ'} : + usubst Γ σ Δ -> + usubst (Γ ,,, Δ') (up #|Δ'| σ) (Δ ,,, inst_context σ Δ'). +Proof. + intros hs. + eapply usubst_ext; [eapply usubst_app; eauto|]. + now sigma. +Qed. + +Lemma All3_map_all {A B C} {A' B' C'} P (l : list A') (l' : list B') (l'' : list C') + (f : A' -> A) (g : B' -> B) (h : C' -> C) : + All3 (fun x y z => P (f x) (g y) (h z)) l l' l'' -> + All3 P (map f l) (map g l') (map h l''). +Proof. + induction 1; simpl; constructor; auto. +Qed. + +Lemma OnOne2All_All3 {A B} P Q (l : list A) (l' : list B) (l'' : list B) : + (forall x y z, P x y z -> Q x y z) -> + (forall x y, Q x y y) -> + OnOne2All P l l' l'' -> + All3 Q l l' l''. +Proof. + intros H1 H2. + induction 1; simpl; constructor; auto. + induction tl in bs, e |- *; destruct bs => //; try constructor; auto. +Qed. + +Lemma red1_inst {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ u v σ} : + usubst Γ σ Δ -> + red1 Σ Γ u v -> + red Σ Δ u.[σ] v.[σ]. +Proof. + intros hσ h. + induction h using red1_ind_all in σ, Δ, hσ |- *. + all: try solve [ + try (cbn in hav; rtoProp); + simpl ; constructor ; eapply IHh ; + eassumption + ]. + - 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. + specialize IH with (1:=H) as [[x' [decl' [hi [hnth' eqbod]]]]|eqr]. + * rewrite /= hi. sigma. + destruct (decl_body decl') eqn:hdecl => //. noconf eqbod. + rewrite -H0. sigma. + relativize (t.[_]); [do 2 econstructor|]. + { now rewrite hnth' /= hdecl. } + rewrite lift0_inst. now sigma. + * rewrite /= eqr. sigma. reflexivity. + - rename H0 into wfp. simpl. + rewrite inst_iota_red //. + change (bcontext br) with (bcontext (inst_branch σ br)). + rewrite inst_mkApps. + do 2 econstructor; eauto. + { now rewrite nth_error_map H /=. } + simpl. + now rewrite mapi_context_fold; len. + - rewrite 2!inst_mkApps. simpl. + do 2 econstructor. + + eapply inst_unfold_fix. eassumption. + + eapply is_constructor_inst. assumption. + - simpl. rewrite !inst_mkApps. simpl. + constructor. eapply red_cofix_case. + eapply inst_unfold_cofix. eassumption. + - simpl. rewrite 2!inst_mkApps. simpl. + constructor; eapply red_cofix_proj. + eapply inst_unfold_cofix. eassumption. + - simpl. + rewrite inst_closed0. + * rewrite closedn_subst_instance. + eapply declared_constant_closed_body. all: eauto. + * do 2 econstructor; eauto. + - simpl. rewrite inst_mkApps. simpl. + do 2 econstructor. rewrite nth_error_map. rewrite H. reflexivity. + - simpl. eapply red_abs; eauto. + - simpl; eapply red_abs; eauto. + eapply IHh. now eapply usubst_up_vass. + - simpl; eapply red_letin; eauto. + - simpl; eapply red_letin; eauto. + - simpl; pcuicfo. eapply red_letin; eauto. + now eapply IHh, usubst_up_vdef. + - simpl. rewrite inst_predicate_set_pparams. + eapply red_case_pars. + simpl. eapply All2_map. + eapply OnOne2_All2; eauto; solve_all. + - simpl. rewrite inst_predicate_set_pcontext. + { now rewrite -(length_of X). } + eapply red_case_pcontext. + eapply OnOne2_local_env_mapi_context. + eapply OnOne2_local_env_impl; tea. + clear -hσ; unfold on_Trel; intros Δ' d d' h. + eapply on_one_decl_mapi_context. + eapply on_one_decl_impl; tea => /=. + intros ? ? ? ?. red. eapply X; tea. + rewrite !mapi_context_inst. + now apply usubst_app_up. + - simpl. rewrite inst_predicate_set_preturn. + eapply red_case_p; eauto. + simpl. + eapply IHh; eauto. + rewrite mapi_context_inst. + now eapply usubst_app_up. + - simpl. eapply red_case_c; eauto. + - simpl. eapply red_case_brs; eauto. + red. + eapply All2_map. + eapply OnOne2_All2 in X; eauto; clear X. + * unfold on_Trel; intros x y [[[? ?] ?]|[? ?]]. + + simpl; rewrite -e. intuition auto. + ++ eapply r0. rewrite mapi_context_inst. + now eapply usubst_app_up. + ++ reflexivity. + + simpl. rewrite -e. intuition auto. + ++ rewrite (length_of o). reflexivity. + ++ eapply red_one_decl_red_ctx_rel. + eapply OnOne2_local_env_mapi_context. + eapply OnOne2_local_env_impl; tea. + clear -hσ; unfold on_Trel; intros Δ' d d' h. + eapply on_one_decl_mapi_context. + eapply on_one_decl_impl; tea => /=. + intros ? ? ? ?. red. eapply X; tea. + rewrite !mapi_context_inst. + now apply usubst_app_up. + * intros x. unfold on_Trel; split; auto. + reflexivity. + - simpl. now eapply red_proj_c. + - simpl. now eapply red_app. + - simpl. now eapply red_app_r. + - simpl. now eapply red_prod. + - simpl. now eapply red_prod_r, IHh, usubst_up_vass. + - simpl. eapply red_evar. + eapply All2_map. eapply OnOne2_All2; eauto; solve_all. + - simpl. + eapply red_fix_one_ty. + rewrite (OnOne2_length X). + eapply OnOne2_map; solve_all. red. simpl. + noconf b. rewrite H H0 H1. split; auto. + - simpl. + eapply red_fix_one_body. + rewrite -(OnOne2_length X). + eapply OnOne2_map; solve_all. red. simpl. + noconf b. rewrite H H0 H1. split; auto. + eapply b0. + eapply usubst_ext. + * rewrite inst_fix_context_up. now eapply usubst_app_up. + * now len. + - simpl. + eapply red_cofix_one_ty. + rewrite (OnOne2_length X). + eapply OnOne2_map; solve_all. red. simpl. + noconf b. rewrite H H0 H1. split; auto. + - simpl. + eapply red_cofix_one_body. + rewrite -(OnOne2_length X). + eapply OnOne2_map; solve_all. red. simpl. + noconf b. rewrite H H0 H1. split; auto. + eapply b0. + eapply usubst_ext. + * rewrite inst_fix_context_up. now eapply usubst_app_up. + * now len. +Qed. + +Lemma eq_term_upto_univ_inst Σ : + forall Re Rle napp u v σ, + Reflexive Re -> Reflexive Rle -> + eq_term_upto_univ_napp Σ Re Rle napp u v -> + eq_term_upto_univ_napp Σ Re Rle napp u.[σ] v.[σ]. +Proof. + intros Re Rle napp u v σ hRe hRle h. + induction u in v, napp, Re, Rle, hRe, hRle, σ, h |- * using term_forall_list_ind. + all: dependent destruction h. + all: try solve [ + simpl ; constructor ; eauto + ]. + - simpl. reflexivity. + - simpl. constructor. + induction X in a, args' |- *. + + inversion a. constructor. + + inversion a. subst. simpl. constructor. + all: eauto. + - simpl. constructor. all: eauto. + * rewrite /inst_predicate. + destruct X; destruct e as [? [? [ectx ?]]]. + rewrite (All2_fold_length ectx). red. + intuition auto; simpl; solve_all. + eapply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea. + solve_all. eapply compare_decl_map. + eapply compare_decl_impl_ondecl; tea; solve_all. + * induction X0 in a, brs' |- *. + + inversion a. constructor. + + inversion a. subst. simpl. + destruct X1 as [a0 e0], p0. + constructor; eauto. + split; eauto. + ** solve_all. + eapply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea. + solve_all. eapply compare_decl_map. + eapply compare_decl_impl_ondecl; tea; solve_all. + ** simpl. + rewrite (All2_fold_length a0). + now eapply e1. + - simpl. constructor. + apply All2_length in a as e. rewrite <- e. + generalize #|m|. intro k. + eapply All2_map. simpl. solve_all. + - simpl. constructor. + apply All2_length in a as e. rewrite <- e. + generalize #|m|. intro k. + eapply All2_map. simpl. solve_all. +Qed. + +Lemma inst_conv {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ σ A B : + usubst Γ σ Δ -> + Σ ;;; Γ |- A = B -> + Σ ;;; Δ |- A.[σ] = B.[σ]. +Proof. + intros hσ h. + induction h. + - eapply conv_refl. + eapply eq_term_upto_univ_inst. all:try typeclasses eauto. assumption. + - eapply red_conv_conv. + + eapply red1_inst; tea. + + apply IHh. + - eapply red_conv_conv_inv. + + eapply red1_inst; tea. + + eapply IHh; eauto. +Qed. + +Lemma inst_cumul {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ σ A B : + usubst Γ σ Δ -> + Σ ;;; Γ |- A <= B -> + Σ ;;; Δ |- A.[σ] <= B.[σ]. +Proof. + intros hσ h. + induction h. + - eapply cumul_refl. + eapply eq_term_upto_univ_inst. all:try typeclasses eauto. assumption. + - eapply red_cumul_cumul. + + eapply red1_inst; tea. + + apply IHh. + - eapply red_cumul_cumul_inv. + + eapply red1_inst; tea. + + eapply IHh; eauto. +Qed. + +Lemma inst_conv_decls {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Δ Δ' σ} d d' : + usubst Γ σ Δ -> + usubst Γ' σ Δ' -> + conv_decls Σ Γ Γ' d d' -> + conv_decls Σ Δ Δ' (inst_decl σ d) (inst_decl σ d'). +Proof. + intros usubst usubst' Hd; depelim Hd; constructor; tas; + eapply inst_conv; tea. +Qed. + +Lemma inst_cumul_decls {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Δ Δ' σ} d d' : + usubst Γ σ Δ -> + usubst Γ' σ Δ' -> + cumul_decls Σ Γ Γ' d d' -> + cumul_decls Σ Δ Δ' (inst_decl σ d) (inst_decl σ d'). +Proof. + intros usubst usubst' Hd; depelim Hd; constructor; tas; + (eapply inst_conv || eapply inst_cumul); tea. +Qed. + +Lemma inst_conv_ctx {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Δ Δ' σ} : + usubst Γ σ Δ -> + conv_context Σ (Γ ,,, Γ') (Γ ,,, Δ') -> + conv_context Σ (Δ ,,, inst_context σ Γ') (Δ ,,, inst_context σ Δ'). +Proof. + intros usubst H. + rewrite /inst_context - !mapi_context_fold. + pose proof (All2_fold_length H) as hlen. + len in hlen. assert (#|Γ'| = #|Δ'|) by lia. + eapply All2_fold_app_inv in H as [_ H] => //. + eapply All2_fold_app; len => //; pcuic. + { eapply conv_ctx_refl'. } + eapply All2_fold_mapi. + eapply All2_fold_impl_ind; tea => + /= Γ0 Δ0 d d' IH IH' cd. + eapply inst_conv_decls in cd; tea; rewrite mapi_context_fold. + * now eapply usubst_app. + * rewrite (All2_fold_length IH). + now eapply usubst_app. +Qed. + +Lemma inst_cumul_ctx {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Δ Δ' σ} : + usubst Γ σ Δ -> + cumul_context Σ (Γ ,,, Γ') (Γ ,,, Δ') -> + cumul_context Σ (Δ ,,, inst_context σ Γ') (Δ ,,, inst_context σ Δ'). +Proof. + intros usubst H. + rewrite /inst_context - !mapi_context_fold. + pose proof (All2_fold_length H) as hlen. + len in hlen. assert (#|Γ'| = #|Δ'|) by lia. + eapply All2_fold_app_inv in H as [_ H] => //. + eapply All2_fold_app; len => //; pcuic. + { eapply cumul_ctx_refl'. } + eapply All2_fold_mapi. + eapply All2_fold_impl_ind; tea => + /= Γ0 Δ0 d d' IH IH' cd. + eapply inst_cumul_decls in cd; tea; rewrite mapi_context_fold. + * now eapply usubst_app. + * rewrite (All2_fold_length IH). + now eapply usubst_app. +Qed. + +Definition inst_telescope r Γ := + mapi (fun i => map_decl (inst (up i r))) Γ. + +Lemma inst_subst_telescope f s Γ : + inst_telescope f (subst_telescope s 0 Γ) = + subst_telescope (map (inst f) s) 0 + (inst_telescope (⇑^#|s| f) Γ). +Proof. + rewrite /inst_telescope /subst_telescope. + rewrite !mapi_compose. apply mapi_ext => k' d. + rewrite !compose_map_decl; apply map_decl_ext => t'. + rewrite Nat.add_0_r. rewrite !up_Upn. + now rewrite inst_subst. +Qed. + +Instance inst_telescope_ext : Proper (`=1` ==> `=1`) inst_telescope. +Proof. + intros f g Hfg Γ. + rewrite /inst_telescope. apply mapi_ext => n x. + now rewrite Hfg. +Qed. + +Lemma inst_telescope_upn0 f Γ : inst_telescope (⇑^0 f) Γ = inst_telescope f Γ. +Proof. now sigma. Qed. + +Lemma inst_telescope_cons f d Γ : + inst_telescope f (d :: Γ) = inst_decl f d :: inst_telescope (⇑^1 f) Γ. +Proof. + rewrite /inst_telescope mapi_cons /inst_decl. + f_equal; sigma => //. + apply mapi_ext => i x. now rewrite -up_Upn up_up Nat.add_1_r. +Qed. + +Lemma inst_context_telescope r Γ : List.rev (inst_context r Γ) = inst_telescope r (List.rev Γ). +Proof. + rewrite !inst_context_alt /inst_telescope. + rewrite mapi_rev. + f_equal. apply mapi_ext => k' d. + apply map_decl_ext => t. sigma. lia_f_equal. +Qed. + +Lemma type_inst : env_prop + (fun Σ Γ t A => + forall Δ σ, + wf_local Σ Δ -> + Σ ;;; Δ ⊢ σ : Γ -> + Σ ;;; Δ |- t.[σ] : A.[σ]) + (fun Σ Γ => + All_local_env + (lift_typing (fun (Σ : global_env_ext) (Γ : context) (t T : term) + => + forall Δ σ, + wf_local Σ Δ -> + Σ ;;; Δ ⊢ σ : Γ -> + Σ ;;; Δ |- t.[σ] : T.[σ]) Σ) Γ). +Proof. + apply typing_ind_env. + - intros Σ wfΣ Γ wfΓ. auto. + induction 1; constructor; firstorder auto. + - intros Σ wfΣ Γ wfΓ n decl e X Δ σ hΔ hσ. simpl. + eapply hσ. assumption. + - intros Σ wfΣ Γ wfΓ l X H0 Δ σ hΔ hσ. simpl. + econstructor. all: assumption. + - intros Σ wfΣ Γ wfΓ na A B s1 s2 X hA ihA hB ihB Δ σ hΔ hσ. + autorewrite with sigma. simpl. + econstructor. + + eapply ihA ; auto. + + eapply ihB. + * econstructor ; auto. + eexists. eapply ihA ; auto. + * eapply well_subst_Up. 2: assumption. + econstructor ; auto. + eexists. eapply ihA. all: auto. + - intros Σ wfΣ Γ wfΓ na A t s1 bty X hA ihA ht iht Δ σ hΔ hσ. + autorewrite with sigma. + econstructor. + + eapply ihA ; auto. + + eapply iht. + * econstructor ; auto. + eexists. eapply ihA ; auto. + * eapply well_subst_Up. 2: assumption. + constructor. 1: assumption. + eexists. eapply ihA. all: auto. + - intros Σ wfΣ Γ wfΓ na b B t s1 A X hB ihB hb ihb ht iht Δ σ hΔ hσ. + autorewrite with sigma. + econstructor. + + eapply ihB. all: auto. + + eapply ihb. all: auto. + + eapply iht. + * econstructor. all: auto. + -- eexists. eapply ihB. all: auto. + -- simpl. eapply ihb. all: auto. + * eapply well_subst_Up'; try assumption. + constructor; auto. + ** exists s1. apply ihB; auto. + ** apply ihb; auto. + - intros Σ wfΣ Γ wfΓ t na A B s u X hty ihty ht iht hu ihu Δ σ hΔ hσ. + autorewrite with sigma. + econstructor. + * specialize (ihty _ _ hΔ hσ). + simpl in ihty. eapply meta_conv_term; [eapply ihty|]. + now rewrite up_Up. + * specialize (iht _ _ hΔ hσ). + simpl in iht. eapply meta_conv; [eapply iht|]. + now rewrite up_Up. + * eapply ihu; auto. + - intros Σ wfΣ Γ wfΓ cst u decl X X0 isdecl hconst Δ σ hΔ hσ. + autorewrite with sigma. simpl. + eapply meta_conv; [econstructor; eauto|]. + eapply declared_constant_closed_type in isdecl; eauto. + rewrite inst_closed0; auto. + now rewrite closedn_subst_instance. + - intros Σ wfΣ Γ wfΓ ind u mdecl idecl isdecl X X0 hconst Δ σ hΔ hσ. + eapply meta_conv; [econstructor; eauto|]. + eapply declared_inductive_closed_type in isdecl; eauto. + rewrite inst_closed0; auto. + now rewrite closedn_subst_instance. + - intros Σ wfΣ Γ wfΓ ind i u mdecl idecl cdecl isdecl X X0 hconst Δ σ hΔ hσ. + eapply meta_conv; [econstructor; eauto|]. + eapply declared_constructor_closed_type in isdecl; eauto. + rewrite inst_closed0; eauto. + - intros Σ wfΣ Γ wfΓ ci p c brs indices ps mdecl idecl isdecl HΣ. + intros IHΔ ci_npar predctx wfp cup Hpctx convctx Hpret + IHpret IHpredctx isallowed. + intros Hctxi IHctxi Hc IHc iscof ptm wfbrs Hbrs Δ f HΔ Hf. + autorewrite with sigma. simpl. + rewrite map_app. simpl. + rewrite /ptm. rewrite inst_it_mkLambda_or_LetIn. + relativize #|predctx|. + * erewrite inst_predicate_preturn. + rewrite /predctx. + rewrite inst_predicate_pcontext. + eapply type_Case; eauto. + + now eapply inst_wf_predicate. + + simpl. rewrite mapi_context_inst. + apply All_local_env_app_inv in Hpctx as []. + eapply wf_local_app_inst; eauto. apply a0. + + rewrite -inst_case_predicate_context //. + simpl; rewrite mapi_context_inst. + eapply inst_conv_ctx; tea. exact Hf. + + apply All_local_env_app_inv in Hpctx as []. + eapply IHpret. + ++ simpl; rewrite mapi_context_inst //. + eapply wf_local_app_inst; eauto. apply a0. + ++ rewrite /= mapi_context_inst. + eapply well_subst_app_up => //. + eapply wf_local_app_inst; eauto. apply a0. + + apply All_local_env_app_inv in IHpredctx as []. + rewrite -inst_case_predicate_context //. + eapply wf_local_app_inst; eauto. apply a0. + + revert IHctxi. + rewrite /= /id -map_app. + rewrite -{2}[subst_instance _ _](inst_closedn_ctx f 0). + { pose proof (declared_inductive_closed_pars_indices _ isdecl). + now rewrite closedn_subst_instance_context. } + rewrite inst_context_telescope. + rewrite inst_telescope_upn0. + clear -Δ f HΔ Hf. + induction 1. + { constructor; auto. } + { simpl. rewrite inst_telescope_cons. + constructor; cbn; eauto. + now rewrite inst_subst_telescope /= in IHIHctxi. } + { simpl. rewrite inst_telescope_cons. + constructor; cbn; eauto. + now rewrite inst_subst_telescope /= in IHIHctxi. } + + simpl. unfold id. + specialize (IHc _ _ HΔ Hf). + now rewrite inst_mkApps map_app in IHc. + + now eapply inst_wf_branches. + + eapply Forall2_All2 in wfbrs. + eapply All2i_All2_mix_left in Hbrs; eauto. + eapply All2i_nth_hyp in Hbrs. + eapply All2i_map_right, (All2i_impl Hbrs) => i cdecl br. + set (brctxty := case_branch_type _ _ _ _ _ _ _ _). + move=> [Hnth [wfbr [[Hbr Hconv] [[IHbr Hbrctxty] [IHbod [Hbty IHbty]]]]]]. + rewrite -(inst_closed_constructor_body mdecl cdecl f). + { eapply (declared_constructor_closed (c:=(ci.(ci_ind),i))); eauto. + split; eauto. } + rewrite inst_case_branch_type //. + rewrite -/brctxty. intros brctx'. + assert (wf_local Σ (Δ,,, brctx'.1)). + { rewrite /brctx'. cbn. + apply All_local_env_app_inv in Hbrctxty as []. + eapply wf_local_app_inst; tea. apply a0. } + assert (wf_local Σ (Δ,,, bcontext (inst_branch f br))). + { apply All_local_env_app_inv in Hbr as []. + cbn. rewrite mapi_context_inst. + eapply wf_local_app_inst; tea. apply a0. } + repeat split => //. + ++ cbn. rewrite mapi_context_inst. + eapply inst_conv_ctx; tea. exact Hf. + ++ eapply IHbod => //. + rewrite /brctx' /brctxty; cbn. + rewrite mapi_context_inst. + eapply well_subst_app_up => //. + rewrite /= mapi_context_inst in X0. + apply X0. + ++ eapply IHbty=> //. + rewrite /brctx'; cbn. + rewrite mapi_context_inst. + rewrite /= mapi_context_inst in X0. + eapply well_subst_app_up => //. + * rewrite /predctx case_predicate_context_length //. + - intros Σ wfΣ Γ wfΓ p c u mdecl idecl pdecl isdecl args X X0 hc ihc e ty + Δ σ hΔ hσ. + simpl. + eapply meta_conv; [econstructor|]. + * eauto. + * specialize (ihc _ _ hΔ hσ). + rewrite inst_mkApps in ihc. eapply ihc. + * now rewrite map_length. + * autorewrite with sigma. + eapply declared_projection_closed in isdecl; auto. + move: isdecl. + rewrite -(closedn_subst_instance _ _ u). + rewrite /ty. + eapply inst_ext_closed. + intros x Hx. + rewrite subst_consn_lt /=; len; try lia. + rewrite Upn_comp. 2:now repeat len. + rewrite subst_consn_lt /=; len; try lia. + now rewrite map_rev. + - intros Σ wfΣ Γ wfΓ mfix n decl types hguard hnth htypes hmfix ihmfix wffix Δ σ hΔ hσ. + simpl. eapply meta_conv; [econstructor;eauto|]. + * now eapply fix_guard_inst. + * now rewrite nth_error_map hnth. + * solve_all. + destruct a as [s [Hs IH]]. + exists s; eapply IH; eauto. + * solve_all. + len. rewrite /types in b0. len in b0. + pose proof (inst_fix_context mfix σ). + setoid_rewrite <-up_Upn at 1 in H. rewrite H. + eapply All_local_env_app_inv in htypes as []. + eapply meta_conv; [eapply b0; eauto|]. + + eapply wf_local_app_inst; eauto. eapply a2. + + rewrite -(fix_context_length mfix). + eapply well_subst_app_up => //. + eapply wf_local_app_inst; eauto. apply a2. + + rewrite lift0_inst. now sigma. + * now apply inst_wf_fixpoint. + * reflexivity. + + - intros Σ wfΣ Γ wfΓ mfix n decl types hguard hnth htypes hmfix ihmfix wffix Δ σ hΔ hσ. + simpl. eapply meta_conv; [econstructor;eauto|]. + * now eapply cofix_guard_inst. + * now rewrite nth_error_map hnth. + * solve_all. + destruct a as [s [Hs IH]]. + exists s; eapply IH; eauto. + * solve_all. + len. rewrite /types in b0. len in b0. + pose proof (inst_fix_context mfix σ). + setoid_rewrite <-up_Upn at 1 in H. rewrite H. + eapply All_local_env_app_inv in htypes as []. + eapply meta_conv; [eapply b0; eauto|]. + + eapply wf_local_app_inst; eauto. eapply a2. + + rewrite -(fix_context_length mfix). + eapply well_subst_app_up => //. + eapply wf_local_app_inst; eauto. apply a2. + + rewrite lift0_inst. now sigma. + * now apply inst_wf_cofixpoint. + * reflexivity. + + - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht hB ihB hcum Δ σ hΔ hσ. + eapply type_Cumul. + + eapply iht. all: auto. + + eapply ihB. all: auto. + + eapply inst_cumul => //. + * exact hσ. + * apply hcum. +Qed. + +End Sigma. \ No newline at end of file diff --git a/pcuic/theories/PCUICInversion.v b/pcuic/theories/PCUICInversion.v index 089f47d55..a90aebc66 100644 --- a/pcuic/theories/PCUICInversion.v +++ b/pcuic/theories/PCUICInversion.v @@ -1,11 +1,10 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst PCUICUnivSubst - PCUICTyping PCUICCumulativity PCUICConversion. +From MetaCoq.PCUIC Require Import PCUICAst PCUICCases PCUICLiftSubst PCUICUnivSubst + PCUICTyping PCUICCumulativity PCUICConfluence PCUICConversion. Require Import Equations.Prop.DepElim. - Section Inversion. Context `{checker_flags}. @@ -138,7 +137,7 @@ Section Inversion. wf_local Σ Γ × declared_constant Σ c decl × (consistent_instance_ext Σ decl.(cst_universes) u) × - Σ ;;; Γ |- subst_instance_constr u (cst_type decl) <= T. + Σ ;;; Γ |- subst_instance u (cst_type decl) <= T. Proof. intros Γ c u T h. invtac h. Qed. @@ -148,9 +147,9 @@ Section Inversion. Σ ;;; Γ |- tInd ind u : T -> ∑ mdecl idecl, wf_local Σ Γ × - declared_inductive Σ mdecl ind idecl × + declared_inductive Σ ind mdecl idecl × consistent_instance_ext Σ (ind_universes mdecl) u × - Σ ;;; Γ |- subst_instance_constr u idecl.(ind_type) <= T. + Σ ;;; Γ |- subst_instance u idecl.(ind_type) <= T. Proof. intros Γ ind u T h. invtac h. Qed. @@ -160,45 +159,70 @@ Section Inversion. Σ ;;; Γ |- tConstruct ind i u : T -> ∑ mdecl idecl cdecl, wf_local Σ Γ × - declared_constructor (fst Σ) mdecl idecl (ind, i) cdecl × + declared_constructor (fst Σ) (ind, i) mdecl idecl cdecl × consistent_instance_ext Σ (ind_universes mdecl) u × Σ;;; Γ |- type_of_constructor mdecl cdecl (ind, i) u <= T. Proof. intros Γ ind i u T h. invtac h. Qed. + Variant case_inversion_data Γ ci p c brs mdecl idecl indices := + | case_inv + (ps : Universe.t) + (eq_npars : mdecl.(ind_npars) = ci.(ci_npar)) + (predctx := case_predicate_context ci.(ci_ind) mdecl idecl p) + (wf_pred : wf_predicate mdecl idecl p) + (cons : consistent_instance_ext Σ (ind_universes mdecl) p.(puinst)) + (wf_pctx : wf_local Σ (Γ ,,, p.(pcontext))) + (conv_pctx : conv_context Σ (Γ ,,, p.(pcontext)) (Γ ,,, predctx)) + (wf_brctx : wf_local Σ (Γ ,,, predctx)) + (pret_ty : Σ ;;; Γ ,,, p.(pcontext) |- p.(preturn) : tSort ps) + (allowed_elim : is_allowed_elimination Σ ps idecl.(ind_kelim)) + (ind_inst : ctx_inst typing Σ Γ (p.(pparams) ++ indices) + (List.rev (subst_instance p.(puinst) + (ind_params mdecl ,,, ind_indices idecl)))) + (scrut_ty : Σ ;;; Γ |- c : mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices)) + (not_cofinite : isCoFinite mdecl.(ind_finite) = false) + (ptm := it_mkLambda_or_LetIn p.(pcontext) p.(preturn)) + (wf_brs : wf_branches idecl brs) + (brs_ty : + All2i (fun i cdecl br => + let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in + (wf_local Σ (Γ ,,, br.(bcontext)) × + (wf_local Σ (Γ ,,, brctxty.1)) × + conv_context Σ (Γ ,,, br.(bcontext)) (Γ ,,, brctxty.1)) × + ((Σ ;;; Γ ,,, br.(bcontext) |- br.(bbody) : brctxty.2) × + (Σ ;;; Γ ,,, br.(bcontext) |- brctxty.2 : tSort ps))) + 0 idecl.(ind_ctors) brs). + Lemma inversion_Case : - forall {Γ indnpar p c brs T}, - Σ ;;; Γ |- tCase indnpar p c brs : T -> - ∑ u args mdecl idecl ps pty btys, - let ind := indnpar.1 in - let npar := indnpar.2 in - declared_inductive Σ mdecl ind idecl × - ind_npars mdecl = npar × - let params := firstn npar args in - build_case_predicate_type ind mdecl idecl params u ps = Some pty × - Σ ;;; Γ |- p : pty × - is_allowed_elimination Σ ps (ind_kelim idecl) × - isCoFinite (ind_finite mdecl) = false × - Σ;;; Γ |- c : mkApps (tInd ind u) args × - map_option_out (build_branches_type ind mdecl idecl params u p) - = Some btys × - All2 (fun br bty => (br.1 = bty.1 × Σ ;;; Γ |- br.2 : bty.2) - × isType Σ Γ bty.2) brs btys × - Σ ;;; Γ |- mkApps p (skipn npar args ++ [c]) <= T. + forall {Γ ci p c brs T}, + Σ ;;; Γ |- tCase ci p c brs : T -> + ∑ 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 p.(pcontext) p.(preturn) in + case_inversion_data Γ ci p c brs mdecl idecl indices × + Σ ;;; Γ |- mkApps ptm (indices ++ [c]) <= T. Proof. - intros Γ indnpar p c brs T h. invtac h. + intros Γ ci p c brs T h. + dependent induction h; + [ repeat insum; repeat intimes; try eapply case_inv ; + [ try first [ eassumption | reflexivity ].. | try eapply cumul_refl' ] + | repeat outsum; repeat outtimes; repeat insum; repeat intimes ; tea; + [ try first + [ eassumption | reflexivity ].. + | try eapply cumul_trans; eassumption ] ]. Qed. Lemma inversion_Proj : forall {Γ p c T}, Σ ;;; Γ |- tProj p c : T -> ∑ u mdecl idecl pdecl args, - declared_projection Σ mdecl idecl p pdecl × + declared_projection Σ p mdecl idecl pdecl × Σ ;;; Γ |- c : mkApps (tInd (fst (fst p)) u) args × #|args| = ind_npars mdecl × let ty := snd pdecl in - Σ ;;; Γ |- (subst0 (c :: List.rev args)) (subst_instance_constr u ty) + Σ ;;; Γ |- (subst0 (c :: List.rev args)) (subst_instance u ty) <= T. Proof. intros Γ p c T h. invtac h. diff --git a/pcuic/theories/PCUICLiftSubst.v b/pcuic/theories/PCUICLiftSubst.v index cdf0c1567..516e946fe 100644 --- a/pcuic/theories/PCUICLiftSubst.v +++ b/pcuic/theories/PCUICLiftSubst.v @@ -1,7 +1,8 @@ (* Distributed under the terms of the MIT license. *) +Require Import ssreflect Morphisms. From MetaCoq.Template Require Import utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction. -Require Import ssreflect Morphisms. Import Nat. +Import Nat. (** * Lifting and substitution for the AST @@ -9,113 +10,8 @@ Require Import ssreflect Morphisms. Import Nat. Definition of [closedn] (boolean) predicate for checking if a term is closed. *) - -Notation "`=1`" := (pointwise_relation _ Logic.eq) (at level 80). -Infix "=1" := (pointwise_relation _ Logic.eq) (at level 90). - Derive Signature for Peano.le. -(** Shift a renaming [f] by [k]. *) -Definition shiftn k f := - fun n => if Nat.ltb n k then n else k + (f (n - k)). - -Fixpoint rename f t : term := - match t with - | tRel i => tRel (f i) - | tEvar ev args => tEvar ev (List.map (rename f) args) - | tLambda na T M => tLambda na (rename f T) (rename (shiftn 1 f) M) - | tApp u v => tApp (rename f u) (rename f v) - | tProd na A B => tProd na (rename f A) (rename (shiftn 1 f) B) - | tLetIn na b t b' => tLetIn na (rename f b) (rename f t) (rename (shiftn 1 f) b') - | tCase ind p c brs => - let brs' := List.map (on_snd (rename f)) brs in - tCase ind (rename f p) (rename f c) brs' - | tProj p c => tProj p (rename f c) - | tFix mfix idx => - let mfix' := List.map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let mfix' := List.map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in - tCoFix mfix' idx - | x => x - end. - -Fixpoint lift n k t : term := - match t with - | tRel i => tRel (if Nat.leb k i then (n + i) else i) - | tEvar ev args => tEvar ev (List.map (lift n k) args) - | tLambda na T M => tLambda na (lift n k T) (lift n (S k) M) - | tApp u v => tApp (lift n k u) (lift n k v) - | tProd na A B => tProd na (lift n k A) (lift n (S k) B) - | tLetIn na b t b' => tLetIn na (lift n k b) (lift n k t) (lift n (S k) b') - | tCase ind p c brs => - let brs' := List.map (on_snd (lift n k)) brs in - tCase ind (lift n k p) (lift n k c) brs' - | tProj p c => tProj p (lift n k c) - | tFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in - tCoFix mfix' idx - | x => x - end. - -Notation lift0 n := (lift n 0). - -Definition lift_decl n k d := (map_decl (lift n k) d). - -Definition lift_context n k (Γ : context) : context := - fold_context (fun k' => lift n (k' + k)) Γ. - -(** Parallel substitution: it assumes that all terms in the substitution live in the - same context *) - -Fixpoint subst s k u := - match u with - | tRel n => - if Nat.leb k n then - match nth_error s (n - k) with - | Some b => lift0 k b - | None => tRel (n - List.length s) - end - else tRel n - | tEvar ev args => tEvar ev (List.map (subst s k) args) - | tLambda na T M => tLambda na (subst s k T) (subst s (S k) M) - | tApp u v => tApp (subst s k u) (subst s k v) - | tProd na A B => tProd na (subst s k A) (subst s (S k) B) - | tLetIn na b ty b' => tLetIn na (subst s k b) (subst s k ty) (subst s (S k) b') - | tCase ind p c brs => - let brs' := List.map (on_snd (subst s k)) brs in - tCase ind (subst s k p) (subst s k c) brs' - | tProj p c => tProj p (subst s k c) - | tFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in - tCoFix mfix' idx - | x => x - end. - -(** Substitutes [t1 ; .. ; tn] in u for [Rel 0; .. Rel (n-1)] *in parallel* *) -Notation subst0 t := (subst t 0). -Definition subst1 t k u := subst [t] k u. -Notation subst10 t := (subst1 t 0). -Notation "M { j := N }" := (subst1 N j M) (at level 10, right associativity). - -Definition subst_telescope s k Γ := - mapi (fun k' x => map_decl (subst s (k + k')) x) Γ. - -Definition subst_decl s k (d : context_decl) := map_decl (subst s k) d. - -Definition subst_context s k (Γ : context) : context := - fold_context (fun k' => subst s (k' + k)) Γ. - (** Assumptions contexts do not contain let-ins. *) Inductive assumption_context : context -> Prop := @@ -124,89 +20,6 @@ Inductive assumption_context : context -> Prop := Derive Signature for assumption_context. -(** Smashing a context produces an assumption context. *) - -Fixpoint smash_context (Γ Γ' : context) : context := - match Γ' with - | {| decl_body := Some b |} :: Γ' => smash_context (subst_context [b] 0 Γ) Γ' - | {| decl_body := None |} as d :: Γ' => smash_context (Γ ++ [d]) Γ' - | [] => Γ - end. - -(* Smashing a context Γ with Δ depending on it is the same as smashing Γ - and substituting all references to Γ in Δ by the expansions of let bindings. *) - -Fixpoint extended_subst (Γ : context) (n : nat) - (* Δ, smash_context Γ, n |- extended_subst Γ n : Γ *) := - match Γ with - | nil => nil - | cons d vs => - match decl_body d with - | Some b => - (* Δ , vs |- b *) - let s := extended_subst vs n in - (* Δ , smash_context vs , n |- s : vs *) - let b' := lift (context_assumptions vs + n) #|s| b in - (* Δ, smash_context vs, n , vs |- b' *) - let b' := subst0 s b' in - (* Δ, smash_context vs , n |- b' *) - b' :: s - | None => tRel n :: extended_subst vs (S n) - end - end. - -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 Δ := - (subst_context (extended_subst Γ 0) k (lift_context (context_assumptions Γ) (k + #|Γ|) Δ)). - -Definition expand_lets_ctx Γ Δ := expand_lets_k_ctx Γ 0 Δ. - -Fixpoint closedn k (t : term) : bool := - match t with - | tRel i => Nat.ltb i k - | tEvar ev args => List.forallb (closedn k) args - | tLambda _ T M | tProd _ T M => closedn k T && closedn (S k) M - | tApp u v => closedn k u && closedn k v - | tLetIn na b t b' => closedn k b && closedn k t && closedn (S k) b' - | tCase ind p c brs => - let brs' := List.forallb (test_snd (closedn k)) brs in - closedn k p && closedn k c && brs' - | tProj p c => closedn k c - | tFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (closedn k) (closedn k')) mfix - | tCoFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (closedn k) (closedn k')) mfix - | x => true - end. - -Notation closed t := (closedn 0 t). - -Fixpoint noccur_between k n (t : term) : bool := - match t with - | tRel i => Nat.ltb i k || Nat.leb (k + n) i - | tEvar ev args => List.forallb (noccur_between k n) args - | tLambda _ T M | tProd _ T M => noccur_between k n T && noccur_between (S k) n M - | tApp u v => noccur_between k n u && noccur_between k n v - | tLetIn na b t b' => noccur_between k n b && noccur_between k n t && noccur_between (S k) n b' - | tCase ind p c brs => - let brs' := List.forallb (test_snd (noccur_between k n)) brs in - noccur_between k n p && noccur_between k n c && brs' - | tProj p c => noccur_between k n c - | tFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix - | tCoFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix - | x => true - end. - Create HintDb terms. Ltac arith_congr := repeat (try lia; progress f_equal). @@ -281,50 +94,14 @@ Proof. reflexivity. intros. lia. Qed. -Hint Extern 0 (_ = _) => progress f_equal : all. -Hint Unfold on_snd snd : all. - -Lemma on_snd_eq_id_spec {A B} (f : B -> B) (x : A * B) : - f (snd x) = snd x <-> - on_snd f x = x. -Proof. - destruct x; simpl; unfold on_snd; simpl. split; congruence. -Qed. -Hint Resolve -> on_snd_eq_id_spec : all. -Hint Resolve -> on_snd_eq_spec : all. - -Lemma map_def_eq_spec {A B} (f f' g g' : A -> B) (x : def A) : - f (dtype x) = g (dtype x) -> - f' (dbody x) = g' (dbody x) -> - map_def f f' x = map_def g g' x. -Proof. - intros. unfold map_def; f_equal; auto. -Qed. -Hint Resolve map_def_eq_spec : all. - -Lemma map_def_id_spec {A} (f f' : A -> A) (x : def A) : - f (dtype x) = (dtype x) -> - f' (dbody x) = (dbody x) -> - map_def f f' x = x. +(* Lemma pair_eq_spec {A B} (x : A) (y : B) (z : A * B) : + x = z.1 -> + y = z.2 -> + (x, y) = z. Proof. - intros. rewrite (map_def_eq_spec _ _ id id); auto. destruct x; auto. + destruct z; simpl; congruence. Qed. -Hint Resolve map_def_id_spec : all. - -Hint Extern 10 (_ < _)%nat => lia : all. -Hint Extern 10 (_ <= _)%nat => lia : all. -Hint Extern 10 (@eq nat _ _) => lia : all. - -Ltac change_Sk := - repeat match goal with - |- context [S (?x + ?y)] => progress change (S (x + y)) with (S x + y) - end. - -Ltac solve_all := - unfold tCaseBrsProp, tFixProp in *; - repeat toAll; try All_map; try close_All; - change_Sk; auto with all; - intuition eauto 4 with all. +Hint Resolve pair_eq_spec : all. *) Ltac nth_leb_simpl := match goal with @@ -346,7 +123,7 @@ Proof. try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); try (f_equal; auto; solve_all). - - now elim (leb k n). + now elim (leb k n). Qed. Lemma map_lift0 l : map (lift0 0) l = l. @@ -362,23 +139,24 @@ Lemma simpl_lift : Proof. intros M. elim M using term_forall_list_ind; - intros; simpl; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + intros; simpl; autorewrite with map; try (rewrite -> H, ?H0, ?H1; auto); try (f_equal; auto; solve_all). - - elim (leb_spec k n); intros. - + elim (leb_spec i (n0 + n)); intros; lia. - + elim (leb_spec i n); intros; lia. + elim (leb_spec k n); intros. + + elim (leb_spec i (n0 + n)); intros; lia. + + elim (leb_spec i n); intros; lia. Qed. Lemma simpl_lift0 : forall M n, lift0 (S n) M = lift0 1 (lift0 n M). -Proof. intros; now rewrite simpl_lift. Qed. +Proof. intros; now rewrite simpl_lift. Qed. Lemma simpl_lift_ext n k p i : i <= k + n -> k <= i -> lift p i ∘ lift n k =1 lift (p + n) k. Proof. intros ? ? ?; now apply simpl_lift. Qed. +Hint Rewrite Nat.add_assoc : map. + Lemma permute_lift : forall M n k p i, i <= k -> @@ -387,9 +165,7 @@ Proof. intros M. elim M using term_forall_list_ind; intros; simpl; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, - ?map_length, ?Nat.add_assoc; f_equal; - try solve [solve_all]; repeat nth_leb_simpl. + f_equal; try solve [solve_all]; repeat nth_leb_simpl. Qed. Lemma permute_lift0 : @@ -415,8 +191,7 @@ Lemma simpl_subst_rec : k <= p -> subst N p (lift (List.length N + n) k M) = lift n k M. Proof. intros M. induction M using term_forall_list_ind; - intros; simpl; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + intros; simpl; autorewrite with map; try solve [f_equal; auto; solve_all]; repeat nth_leb_simpl. Qed. @@ -438,9 +213,7 @@ Lemma commut_lift_subst_rec M N n p k : k <= p -> lift n k (subst N p M) = subst N (p + n) (lift n k M). Proof. revert N n p k; elim M using term_forall_list_ind; intros; cbnr; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, - ?map_length, ?Nat.add_assoc; - try solve [f_equal; auto; solve_all]. + f_equal; auto; solve_all; rewrite ?plus_Snm_nSm -?Nat.add_assoc; eauto with all. - repeat nth_leb_simpl. rewrite -> simpl_lift by easy. f_equal; lia. @@ -457,9 +230,7 @@ Lemma distr_lift_subst_rec M N n p k : subst (List.map (lift n k) N) p (lift n (p + length N + k) M). Proof. revert N n p k; elim M using term_forall_list_ind; intros; cbnr; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, - ?map_length, ?Nat.add_assoc; - try solve [f_equal; auto; solve_all]. + f_equal; auto; solve_all. - repeat nth_leb_simpl. rewrite nth_error_map in e0. rewrite e in e0. @@ -507,7 +278,7 @@ Proof. | |- _ => simpl end; try reflexivity; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, - ?map_length, ?Nat.add_assoc; + ?map_length, ?Nat.add_assoc, ?map_predicate_map_predicate; try solve [f_equal; auto; solve_all]. - unfold subst at 2. @@ -543,22 +314,21 @@ Lemma lift_closed n k t : closedn k t -> lift n k t = t. Proof. revert k. elim t using term_forall_list_ind; intros; try easy; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; - unfold test_def in *; - simpl closed in *; try solve [simpl lift; simpl closed; f_equal; auto; - rtoProp; solve_all]; try reflexivity. + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + ?map_predicate_map_predicate, ?map_branch_map_branch; + 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. revert H. elim (Nat.ltb_spec n0 k); intros; try easy. - - simpl lift. f_equal. solve_all. unfold test_def in b. toProp. solve_all. - - simpl lift. f_equal. solve_all. unfold test_def in b. toProp. solve_all. Qed. Lemma closed_upwards {k t} k' : closedn k t -> k' >= k -> closedn k' t. Proof. revert k k'. elim t using term_forall_list_ind; intros; try lia; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; - simpl closed in *; unfold test_snd, test_def in *; + autorewrite with map; + simpl closed in *; unfold test_snd, test_def, test_predicate_k, test_branch_k in *; try solve [(try f_equal; simpl; repeat (rtoProp; solve_all); eauto)]. - elim (ltb_spec n k'); auto. intros. @@ -601,7 +371,7 @@ Proof. induction t in k |- * using term_forall_list_ind; simpl; auto; rewrite ?subst_mkApps; try change_Sk; try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, - ?map_length; eauto; solve_all). + ?map_length, ?map_predicate_map_predicate; eauto; solve_all). - repeat nth_leb_simpl. rewrite nth_error_map in e0. rewrite e in e0. @@ -617,12 +387,17 @@ Proof. induction t in k |- * using term_forall_list_ind; simpl; eauto; rewrite ?subst_mkApps; try change_Sk; try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, - ?map_length, ?Nat.add_assoc; solve_all). + ?map_length, ?Nat.add_assoc, ?map_predicate_map_predicate; solve_all). - repeat nth_leb_simpl. rewrite -> Nat.add_comm, simpl_subst; eauto. Qed. +Lemma subst_app_simpl' (l l' : list term) (k : nat) (t : term) n : + n = #|l| -> + subst (l ++ l') k t = subst l k (subst l' (k + n) t). +Proof. intros ->; apply subst_app_simpl. Qed. + Lemma isLambda_subst (s : list term) k (bod : term) : isLambda bod = true -> isLambda (subst s k bod) = true. Proof. @@ -640,9 +415,6 @@ Proof. rewrite -> permute_lift. f_equal; lia. lia. Qed. -Definition fix_context (m : mfixpoint term) : context := - List.rev (mapi (fun i d => vass d.(dname) (lift0 i d.(dtype))) m). - 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). @@ -654,7 +426,7 @@ Qed. Lemma lift0_context k Γ : lift_context 0 k Γ = Γ. Proof. - unfold lift_context, fold_context. + unfold lift_context, fold_context_k. rewrite rev_mapi. rewrite List.rev_involutive. unfold mapi. generalize 0 at 2. generalize #|List.rev Γ|. induction Γ; intros; simpl; trivial. @@ -662,11 +434,11 @@ Proof. Qed. Lemma lift_context_length n k Γ : #|lift_context n k Γ| = #|Γ|. -Proof. apply fold_context_length. Qed. -Hint Rewrite lift_context_length : lift. +Proof. apply fold_context_k_length. Qed. +Hint Rewrite lift_context_length : lift len. Definition lift_context_snoc0 n k Γ d : lift_context n k (d :: Γ) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d. -Proof. unfold lift_context. now rewrite fold_context_snoc0. Qed. +Proof. unfold lift_context. now rewrite fold_context_k_snoc0. Qed. Hint Rewrite lift_context_snoc0 : lift. Lemma lift_context_snoc n k Γ d : lift_context n k (Γ ,, d) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d. @@ -679,18 +451,40 @@ Lemma lift_context_alt n k Γ : lift_context n k Γ = mapi (fun k' d => lift_decl n (Nat.pred #|Γ| - k' + k) d) Γ. Proof. - unfold lift_context. apply fold_context_alt. + unfold lift_context. apply fold_context_k_alt. Qed. Lemma lift_context_app n k Γ Δ : lift_context n k (Γ ,,, Δ) = lift_context n k Γ ,,, lift_context n (#|Γ| + k) Δ. Proof. - unfold lift_context, fold_context, app_context. + unfold lift_context, fold_context_k, app_context. rewrite List.rev_app_distr. rewrite mapi_app. rewrite <- List.rev_app_distr. f_equal. f_equal. apply mapi_ext. intros. f_equal. rewrite List.rev_length. f_equal. lia. Qed. +Lemma lift_it_mkProd_or_LetIn n k ctx t : + lift n k (it_mkProd_or_LetIn ctx t) = + it_mkProd_or_LetIn (lift_context n k ctx) (lift n (length ctx + k) t). +Proof. + induction ctx in n, k, t |- *; simpl; try congruence. + pose (lift_context_snoc n k ctx a). unfold snoc in e. rewrite -> e. clear e. + simpl. rewrite -> IHctx. + pose (lift_context_snoc n k ctx a). + now destruct a as [na [b|] ty]. +Qed. + +Lemma lift_it_mkLambda_or_LetIn n k ctx t : + lift n k (it_mkLambda_or_LetIn ctx t) = + it_mkLambda_or_LetIn (lift_context n k ctx) (lift n (length ctx + k) t). +Proof. + induction ctx in n, k, t |- *; simpl; try congruence. + pose (lift_context_snoc n k ctx a). unfold snoc in e. rewrite -> e. clear e. + simpl. rewrite -> IHctx. + pose (lift_context_snoc n k ctx a). + now destruct a as [na [b|] ty]. +Qed. + Lemma map_lift_lift n k l : map (fun x => lift0 n (lift0 k x)) l = map (lift0 (n + k)) l. Proof. apply map_ext => x. rewrite simpl_lift; try lia. reflexivity. @@ -755,32 +549,15 @@ Lemma nth_error_lift_context_eq: option_map (lift_decl #|Γ''| (#|Γ'| - S v + k)) (nth_error Γ' v). Proof. induction Γ'; intros. - - simpl. unfold lift_context, fold_context; simpl. now rewrite nth_error_nil. + - simpl. unfold lift_context, fold_context_k; simpl. now rewrite nth_error_nil. - simpl. destruct v; rewrite lift_context_snoc0. + simpl. repeat f_equal; try lia. + simpl. apply IHΓ'; simpl in *; (lia || congruence). Qed. -Lemma subst_context_length s n Γ : #|subst_context s n Γ| = #|Γ|. -Proof. - induction Γ as [|[na [body|] ty] tl] in Γ |- *; cbn; eauto. - - rewrite !List.rev_length !mapi_length !app_length !List.rev_length. simpl. lia. - - rewrite !List.rev_length !mapi_length !app_length !List.rev_length. simpl. lia. -Qed. -Hint Rewrite subst_context_length : len. Hint Rewrite subst_context_length : subst wf. - -Lemma subst_context_snoc s k Γ d : subst_context s k (d :: Γ) = subst_context s k Γ ,, subst_decl s (#|Γ| + k) d. -Proof. - unfold subst_context, fold_context. - rewrite !rev_mapi !rev_involutive /mapi mapi_rec_eqn /snoc. - f_equal. 1: now rewrite Nat.sub_0_r List.rev_length. - rewrite mapi_rec_Sk. simpl. apply mapi_rec_ext. intros. - rewrite app_length !List.rev_length. simpl. f_equal. f_equal. lia. -Qed. Hint Rewrite subst_context_snoc : subst. - Lemma subst_decl0 k d : map_decl (subst [] k) d = d. Proof. destruct d; destruct decl_body; @@ -788,41 +565,25 @@ Proof. f_equal; simpl; rewrite subst_empty; intuition trivial. Qed. -Lemma subst_context_nil s n : subst_context s n [] = []. -Proof. reflexivity. Qed. - Lemma subst0_context k Γ : subst_context [] k Γ = Γ. Proof. - unfold subst_context, fold_context. + unfold subst_context, fold_context_k. rewrite rev_mapi. rewrite List.rev_involutive. unfold mapi. generalize 0. generalize #|List.rev Γ|. induction Γ; intros; simpl; trivial. erewrite subst_decl0; f_equal; eauto. Qed. -Lemma fold_context_length f Γ : #|fold_context f Γ| = #|Γ|. -Proof. - unfold fold_context. now rewrite !List.rev_length mapi_length List.rev_length. -Qed. - Lemma subst_context_snoc0 s Γ d : subst_context s 0 (Γ ,, d) = subst_context s 0 Γ ,, subst_decl s #|Γ| d. Proof. unfold snoc. now rewrite subst_context_snoc Nat.add_0_r. Qed. Hint Rewrite subst_context_snoc : subst. -Lemma subst_context_alt s k Γ : - subst_context s k Γ = - mapi (fun k' d => subst_decl s (Nat.pred #|Γ| - k' + k) d) Γ. -Proof. - unfold subst_context, fold_context. rewrite rev_mapi. rewrite List.rev_involutive. - apply mapi_ext. intros. f_equal. now rewrite List.rev_length. -Qed. - Lemma subst_context_app s k Γ Δ : subst_context s k (Γ ,,, Δ) = subst_context s k Γ ,,, subst_context s (#|Γ| + k) Δ. Proof. - unfold subst_context, fold_context, app_context. + unfold subst_context, fold_context_k, app_context. rewrite List.rev_app_distr. rewrite mapi_app. rewrite <- List.rev_app_distr. f_equal. f_equal. apply mapi_ext. intros. f_equal. rewrite List.rev_length. f_equal. lia. @@ -837,7 +598,7 @@ Proof. intros n' x. rewrite /lift_decl /subst_decl !compose_map_decl. apply map_decl_ext => y. - rewrite !mapi_length Nat.add_0_r; autorewrite with len. + rewrite !mapi_length Nat.add_0_r; autorewrite with len. unf_term. rewrite distr_lift_subst_rec; f_equal. f_equal. lia. Qed. @@ -849,1005 +610,205 @@ Proof. apply mapi_rec_ext. intros. f_equal. rewrite List.skipn_length. lia. Qed. - -Lemma smash_context_length Γ Γ' : #|smash_context Γ Γ'| = #|Γ| + context_assumptions Γ'. -Proof. - induction Γ' as [|[na [body|] ty] tl] in Γ |- *; cbn; eauto. - - now rewrite IHtl subst_context_length. - - rewrite IHtl app_length. simpl. lia. -Qed. -Hint Rewrite smash_context_length : len. - -(* Sigma calculus*) - -Lemma shiftn_ext n f f' : (forall i, f i = f' i) -> forall t, shiftn n f t = shiftn n f' t. + +Lemma lift_extended_subst (Γ : context) k : + extended_subst Γ k = map (lift0 k) (extended_subst Γ 0). +Proof. + induction Γ as [|[? [] ?] ?] in k |- *; simpl; auto; unf_term. + - rewrite IHΓ. f_equal. + autorewrite with len. + rewrite distr_lift_subst. f_equal. + autorewrite with len. rewrite simpl_lift; lia_f_equal. + - rewrite Nat.add_0_r; f_equal. + rewrite IHΓ (IHΓ 1). + rewrite map_map_compose. apply map_ext => x. + rewrite simpl_lift; try lia. + now rewrite Nat.add_1_r. +Qed. + +Lemma lift_extended_subst' Γ k k' : extended_subst Γ (k + k') = map (lift0 k) (extended_subst Γ k'). +Proof. + induction Γ as [|[? [] ?] ?] in k |- *; simpl; auto. + - rewrite IHΓ. f_equal. + autorewrite with len. + rewrite distr_lift_subst. f_equal. + autorewrite with len. rewrite simpl_lift; lia_f_equal. + - f_equal. + rewrite (IHΓ (S k)) (IHΓ 1). + rewrite map_map_compose. apply map_ext => x. + rewrite simpl_lift; lia_f_equal. +Qed. + +Lemma subst_extended_subst_k s Γ k k' : extended_subst (subst_context s k Γ) k' = + map (subst s (k + context_assumptions Γ + k')) (extended_subst Γ k'). +Proof. + induction Γ as [|[na [b|] ty] Γ]; simpl; auto; rewrite subst_context_snoc /=; + autorewrite with len; f_equal; auto. + - rewrite IHΓ. + rewrite commut_lift_subst_rec; try lia. + rewrite distr_subst. now len. + - elim: Nat.leb_spec => //. lia. + - rewrite (lift_extended_subst' _ 1 k') IHΓ. + rewrite (lift_extended_subst' _ 1 k'). + rewrite !map_map_compose. + apply map_ext. + intros x. + erewrite (commut_lift_subst_rec); lia_f_equal. +Qed. + +Lemma extended_subst_app Γ Γ' : + extended_subst (Γ ++ Γ') 0 = + extended_subst (subst_context (extended_subst Γ' 0) 0 + (lift_context (context_assumptions Γ') #|Γ'| Γ)) 0 ++ + extended_subst Γ' (context_assumptions Γ). +Proof. + induction Γ as [|[na [b|] ty] Γ] in |- *; simpl; auto. + - autorewrite with len. + rewrite IHΓ. simpl. rewrite app_comm_cons. + f_equal. + erewrite subst_app_simpl'. + 2:autorewrite with len; reflexivity. + simpl. + rewrite lift_context_snoc subst_context_snoc /=. + len. f_equal. f_equal. + rewrite -{3}(Nat.add_0_r #|Γ|). + erewrite <- (simpl_lift _ _ _ _ (#|Γ| + #|Γ'|)). all:try lia. + rewrite distr_lift_subst_rec. autorewrite with len. + f_equal. apply lift_extended_subst. + - rewrite lift_context_snoc subst_context_snoc /=. lia_f_equal. + rewrite lift_extended_subst. rewrite IHΓ /=. + rewrite map_app. rewrite !(lift_extended_subst _ (S _)). + rewrite (lift_extended_subst _ (context_assumptions Γ)). + rewrite map_map_compose. + f_equal. apply map_ext. intros. + rewrite simpl_lift; lia_f_equal. +Qed. + +Lemma subst_context_comm s s' Γ : + subst_context s 0 (subst_context s' 0 Γ) = + subst_context (map (subst s 0) s' ++ s) 0 Γ. Proof. intros. - unfold shiftn. destruct Nat.ltb; congruence. -Qed. - -Lemma rename_ext f f' : (forall i, f i = f' i) -> (forall t, rename f t = rename f' t). -Proof. - intros. revert f f' H. - elim t0 using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - f_equal; auto. apply H0. intros. - now apply shiftn_ext. - - f_equal; auto. now apply H0, shiftn_ext. - - f_equal; auto. now apply H1, shiftn_ext. - - f_equal; auto. red in X. solve_all. - eapply map_def_eq_spec; auto. now apply b, shiftn_ext. - - f_equal; auto. red in X. solve_all. - eapply map_def_eq_spec; auto. now apply b, shiftn_ext. -Qed. - -Definition lift_renaming n k := - fun i => - if Nat.leb k i then (* Lifted *) n + i - else i. - -Lemma shiftn_lift_renaming n m k : - forall i, shiftn m (lift_renaming n k) i = lift_renaming n (m + k) i. -Proof. - unfold lift_renaming, shiftn. intros i. - destruct (ltb_spec i m). - destruct (ltb_spec (m + k) i). lia. - destruct (leb_spec (m + k) i). lia. lia. - destruct (leb_spec (m + k) i). - destruct (leb_spec k (i - m)). lia. lia. - destruct (leb_spec k (i - m)). lia. lia. -Qed. - -Lemma lift_rename n k t : lift n k t = rename (lift_renaming n k) t. -Proof. - revert n k. - elim t using term_forall_list_ind; simpl in |- *; intros; try reflexivity; - try (rewrite ?H ?H0 ?H1; reflexivity); - try solve [f_equal; solve_all]. - - f_equal; eauto. - rewrite H0. eapply rename_ext. intros i. now rewrite shiftn_lift_renaming. - - f_equal; eauto. - rewrite H0. eapply rename_ext. intros i. now rewrite shiftn_lift_renaming. - - f_equal; eauto. - rewrite H1. eapply rename_ext. intros i. now rewrite shiftn_lift_renaming. - - f_equal; auto. - red in X. solve_all. apply map_def_eq_spec; auto. - rewrite b. apply rename_ext => i; now rewrite shiftn_lift_renaming. - - f_equal; auto. - red in X. solve_all. apply map_def_eq_spec; auto. - rewrite b. apply rename_ext => i; now rewrite shiftn_lift_renaming. -Qed. - -Definition up k (s : nat -> term) := - fun i => - if k <=? i then rename (add k) (s (i - k)) - else tRel i. - -Lemma shiftn_compose n f f' : shiftn n f ∘ shiftn n f' =1 shiftn n (f ∘ f'). -Proof. - unfold shiftn. intros x. - elim (Nat.ltb_spec x n) => H. - - now rewrite (proj2 (Nat.ltb_lt x n)). - - destruct (Nat.ltb_spec (n + f' (x - n)) n). - lia. - assert (n + f' (x - n) - n = f' (x - n)) as ->. lia. - reflexivity. -Qed. - -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; f_equal; - auto; solve_all. - - - rewrite map_map_compose. apply All_map_eq. solve_all. - - rewrite IHx2. apply rename_ext, shiftn_compose. - - rewrite IHx2. apply rename_ext, shiftn_compose. - - rewrite IHx3. apply rename_ext, shiftn_compose. - - rewrite map_map_compose; apply All_map_eq. solve_all. - rewrite on_snd_on_snd. apply on_snd_eq_spec, H. - - rewrite map_map_compose; apply All_map_eq. solve_all. - rewrite map_def_map_def map_length. - apply map_def_eq_spec; auto. - rewrite b. apply rename_ext, shiftn_compose. - - rewrite map_map_compose; apply All_map_eq. solve_all. - rewrite map_def_map_def map_length. - apply map_def_eq_spec; auto. - rewrite b. apply rename_ext, shiftn_compose. -Qed. - -Lemma up_up k k' s : up k (up k' s) =1 up (k + k') s. -Proof. - red. intros x. unfold up. - elim (Nat.leb_spec k x) => H. - - elim (Nat.leb_spec (k + k') x) => H'. - + elim (Nat.leb_spec k' (x - k)) => H''. - ++ rewrite Nat.sub_add_distr. - rewrite -> rename_compose. apply rename_ext. intros. lia. - ++ simpl. lia. - + edestruct (Nat.leb_spec k' (x - k)). lia. - simpl. f_equal. lia. - - elim (Nat.leb_spec (k + k') x) => H'; try f_equal; lia. -Qed. - -Fixpoint inst s u := - match u with - | tRel n => s n - | tEvar ev args => tEvar ev (List.map (inst s) args) - | tLambda na T M => tLambda na (inst s T) (inst (up 1 s) M) - | tApp u v => tApp (inst s u) (inst s v) - | tProd na A B => tProd na (inst s A) (inst (up 1 s) B) - | tLetIn na b ty b' => tLetIn na (inst s b) (inst s ty) (inst (up 1 s) b') - | tCase ind p c brs => - let brs' := List.map (on_snd (inst s)) brs in - tCase ind (inst s p) (inst s c) brs' - | tProj p c => tProj p (inst s c) - | tFix mfix idx => - let mfix' := map (map_def (inst s) (inst (up (List.length mfix) s))) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let mfix' := map (map_def (inst s) (inst (up (List.length mfix) s))) mfix in - tCoFix mfix' idx - | x => x - end. - -Definition subst_fn (l : list term) := - fun i => - match List.nth_error l i with - | None => tRel (i - List.length l) - | Some t => t - end. - -Lemma up_ext k s s' : s =1 s' -> up k s =1 up k s'. -Proof. - unfold up. intros Hs t. elim (Nat.leb_spec k t) => H; auto. - f_equal. apply Hs. -Qed. - -Lemma inst_ext s s' : s =1 s' -> inst s =1 inst s'. -Proof. - intros Hs t. revert s s' Hs. - elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - f_equal; eauto. apply H0. now apply up_ext. - - f_equal; eauto. now apply H0, up_ext. - - f_equal; eauto. now apply H1, up_ext. - - f_equal; eauto. red in X. solve_all. - apply map_def_eq_spec; auto. now apply b, up_ext. - - f_equal; eauto. red in X. solve_all. - apply map_def_eq_spec; auto. now apply b, up_ext. -Qed. - -Definition ren (f : nat -> nat) : nat -> term := - fun i => tRel (f i). - -Lemma ren_shiftn n f : up n (ren f) =1 ren (shiftn n f). -Proof. - unfold ren, up, shiftn. - intros i. - elim (Nat.ltb_spec i n) => H; elim (Nat.leb_spec n i) => H'; try lia; trivial. -Qed. - -Instance proper_inst : Proper (`=1` ==> Logic.eq ==> Logic.eq) inst. -Proof. - intros f f' Hff' t t' ->. now apply inst_ext. -Qed. - -Instance proper_inst' : Proper (`=1` ==> pointwise_relation _ Logic.eq) inst. -Proof. - intros f f' Hff' t. now apply inst_ext. -Qed. - -Instance proper_map_ho {A B} : Proper ((pointwise_relation A Logic.eq) ==> Logic.eq ==> Logic.eq) - (@map A B). -Proof. - intros f g Hfg x y ->. apply map_ext. - apply Hfg. -Qed. - -Instance proper_ext_eq {A B} : Proper (`=1` ==> `=1` ==> iff) (@pointwise_relation A _ (@Logic.eq B)). -Proof. - intros f f' Hff' g g' Hgg'. split; intros. - - intros x. now rewrite <- Hff', <- Hgg'. - - intros x. now rewrite Hff' Hgg'. -Qed. - -Lemma rename_inst f : rename f =1 inst (ren f). -Proof. - intros t. revert f. - elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - - f_equal; eauto. now rewrite H0 -ren_shiftn. - - f_equal; eauto. now rewrite H0 -ren_shiftn. - - f_equal; eauto. now rewrite H1 -ren_shiftn. - - f_equal; eauto. solve_all. apply map_def_eq_spec; auto. - now rewrite b ren_shiftn. - - f_equal; eauto. solve_all. apply map_def_eq_spec; auto. - now rewrite b ren_shiftn. -Qed. - -Hint Rewrite @rename_inst : sigma. - -Instance rename_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) rename. -Proof. intros f f' Hff' t t' ->. now apply rename_ext. Qed. - -(** Show the σ-calculus equations. - - Additional combinators: [idsn n] for n-identity, [consn] for consing a parallel substitution. - *) - -Declare Scope sigma_scope. -Delimit Scope sigma_scope with sigma. -Local Open Scope sigma_scope. - -Definition substitution := nat -> term. -Bind Scope sigma_scope with substitution. - -Notation "t '.[' σ ]" := (inst σ t) (at level 6, format "t .[ σ ]") : sigma_scope. - -Definition subst_cons (t : term) (f : nat -> term) := - fun i => - match i with - | 0 => t - | S n => f n - end. - -Notation " t ⋅ s " := (subst_cons t s) (at level 90) : sigma_scope. - -Instance subst_cons_proper : Proper (Logic.eq ==> `=1` ==> `=1`) subst_cons. -Proof. intros x y -> f f' Hff'. intros i. destruct i; simpl; trivial. Qed. - -Definition shift : nat -> term := tRel ∘ S. -Notation "↑" := shift : sigma_scope. - -Definition subst_compose (σ τ : nat -> term) := - fun i => (σ i).[τ]. - -Infix "∘s" := subst_compose (at level 40) : sigma_scope. - -Instance subst_compose_proper : Proper (`=1` ==> `=1` ==> `=1`) subst_compose. -Proof. - intros f f' Hff' g g' Hgg'. intros x. unfold subst_compose. - now rewrite Hgg' Hff'. -Qed. - -Definition Up σ : substitution := tRel 0 ⋅ (σ ∘s ↑). -Notation "⇑ s" := (Up s) (at level 20). - -Lemma up_Up σ : up 1 σ =1 ⇑ σ. -Proof. - unfold up. - intros i. - elim (Nat.leb_spec 1 i) => H. - - unfold subst_cons, shift. destruct i. - -- lia. - -- simpl. rewrite Nat.sub_0_r. - unfold subst_compose. - now rewrite rename_inst. - - red in H. destruct i; [|lia]. reflexivity. -Qed. - -(** Simplify away [up 1] *) -Hint Rewrite up_Up : sigma. - -Definition ids (x : nat) := tRel x. - -Definition ren_id (x : nat) := x. - -Lemma ren_id_ids : ren ren_id =1 ids. -Proof. reflexivity. Qed. - -Lemma shiftn_id n : shiftn n ren_id =1 ren_id. -Proof. - intros i; unfold shiftn. - elim (Nat.ltb_spec i n) => H. reflexivity. - unfold ren_id. lia. -Qed. - -Lemma rename_ren_id : rename ren_id =1 id. -Proof. - intros t. unfold id. - elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - - f_equal; auto. now rewrite shiftn_id. - - f_equal; auto. now rewrite shiftn_id. - - f_equal; auto. now rewrite shiftn_id. - - f_equal; auto. solve_all. - apply map_def_id_spec; auto. - now rewrite shiftn_id. - - f_equal; auto. solve_all. - apply map_def_id_spec; auto. - now rewrite shiftn_id. + rewrite !subst_context_alt !mapi_compose. + apply mapi_ext => i x. + destruct x as [na [b|] ty] => //. + - rewrite /subst_decl /map_decl /=; f_equal. + + rewrite !mapi_length. f_equal. rewrite {2}Nat.add_0_r. + rewrite subst_app_simpl. + rewrite distr_subst_rec. rewrite Nat.add_0_r; f_equal; try lia. + rewrite map_length. f_equal; lia. + + rewrite mapi_length. + rewrite subst_app_simpl. + rewrite {2}Nat.add_0_r. + rewrite distr_subst_rec. rewrite Nat.add_0_r; f_equal; try lia. + rewrite map_length. f_equal; lia. + - rewrite /subst_decl /map_decl /=; f_equal. + rewrite !mapi_length. rewrite {2}Nat.add_0_r. + rewrite subst_app_simpl. + rewrite distr_subst_rec. rewrite Nat.add_0_r; f_equal; try lia. + rewrite map_length. f_equal. lia. Qed. -Lemma subst_ids t : t.[ids] = t. -Proof. - now rewrite -ren_id_ids -rename_inst rename_ren_id. -Qed. - -Hint Rewrite subst_ids : sigma. - -Lemma compose_ids_r σ : σ ∘s ids =1 σ. -Proof. - unfold subst_compose. intros i; apply subst_ids. -Qed. - -Lemma compose_ids_l σ : ids ∘s σ =1 σ. -Proof. reflexivity. Qed. - -Hint Rewrite compose_ids_r compose_ids_l : sigma. - -Definition shiftk (k : nat) (x : nat) := tRel (k + x). -Notation "↑^ k" := (shiftk k) (at level 30, k at level 2, format "↑^ k") : sigma_scope. - -Lemma shiftk_0 : shiftk 0 =1 ids. -Proof. - intros i. reflexivity. -Qed. - -Definition subst_consn {A} (l : list A) (σ : nat -> A) := - fun i => - match List.nth_error l i with - | None => σ (i - List.length l) - | Some t => t - end. - -Notation " t ⋅n s " := (subst_consn t s) (at level 40) : sigma_scope. - -Lemma subst_consn_nil {A} (σ : nat -> A) : nil ⋅n σ =1 σ. -Proof. - intros i. unfold subst_consn. rewrite nth_error_nil. - now rewrite Nat.sub_0_r. -Qed. - -Lemma subst_consn_subst_cons t l σ : (t :: l) ⋅n σ =1 (t ⋅ subst_consn l σ). -Proof. - intros i. unfold subst_consn. induction i; simpl; trivial. -Qed. - -Lemma subst_consn_tip t σ : [t] ⋅n σ =1 (t ⋅ σ). -Proof. now rewrite subst_consn_subst_cons subst_consn_nil. Qed. - -Instance subst_consn_proper {A} : Proper (Logic.eq ==> `=1` ==> `=1`) (@subst_consn A). -Proof. - intros ? l -> f f' Hff' i. - unfold subst_consn. destruct nth_error eqn:Heq; auto. -Qed. - -Instance subst_consn_proper_ext {A} : Proper (Logic.eq ==> `=1` ==> Logic.eq ==> Logic.eq) (@subst_consn A). -Proof. - intros ? l -> f f' Hff' i i' <-. - unfold subst_consn. destruct nth_error eqn:Heq; auto. -Qed. - -Fixpoint idsn n : list term := - match n with - | 0 => [] - | S n => idsn n ++ [tRel n] - end. - -Definition Upn n σ := idsn n ⋅n (σ ∘s ↑^n). -Notation "⇑^ n σ" := (Upn n σ) (at level 30, n at level 2, format "⇑^ n σ") : sigma_scope. - -Lemma Upn_eq n σ : Upn n σ = idsn n ⋅n (σ ∘s ↑^n). -Proof. reflexivity. Qed. - -Lemma Upn_proper : Proper (Logic.eq ==> `=1` ==> `=1`) Upn. -Proof. intros ? ? -> f g Hfg. unfold Upn. now rewrite Hfg. Qed. +Lemma context_assumptions_subst s n Γ : + context_assumptions (subst_context s n Γ) = context_assumptions Γ. +Proof. apply context_assumptions_fold. Qed. +Hint Rewrite context_assumptions_subst : pcuic. -Definition subst_cons_gen {A} (t : A) (f : nat -> A) := - fun i => - match i with - | 0 => t - | S n => f n - end. - -Instance subst_cons_gen_proper {A} : Proper (Logic.eq ==> `=1` ==> `=1`) (@subst_cons_gen A). -Proof. intros x y <- f g Hfg i. destruct i; simpl; auto. Qed. - -Lemma subst_consn_subst_cons_gen {A} (t : A) l σ : subst_consn (t :: l) σ =1 (subst_cons_gen t (l ⋅n σ)). -Proof. - intros i. unfold subst_consn. induction i; simpl; trivial. -Qed. - -Lemma subst_consn_app {A} {l l' : list A} {σ} : (l ++ l') ⋅n σ =1 l ⋅n (l' ⋅n σ). -Proof. - induction l; simpl; auto. - - now rewrite subst_consn_nil. - - now rewrite !subst_consn_subst_cons_gen IHl. -Qed. - -Lemma subst_consn_ge {A} {l : list A} {i σ} : #|l| <= i -> (l ⋅n σ) i = σ (i - #|l|). -Proof. - induction l in i, σ |- *; simpl. - - now rewrite subst_consn_nil. - - rewrite subst_consn_subst_cons_gen. - intros H. destruct i; [lia|]. simpl. - apply IHl. lia. -Qed. - -Lemma subst_consn_lt {A} {l : list A} {i} : - i < #|l| -> - ∑ x, (List.nth_error l i = Some x) /\ (forall σ, (l ⋅n σ) i = x)%type. -Proof. - induction l in i |- *; simpl. - - intros H; elimtype False; lia. - - intros H. - destruct i. - + simpl. exists a. split; auto. - + specialize (IHl i). forward IHl. - * lia. - * destruct IHl as [x [Hnth Hsubst_cons]]. - exists x. simpl. split; auto. -Qed. - -Lemma idsn_length n : #|idsn n| = n. -Proof. - induction n; simpl; auto. rewrite app_length IHn; simpl; lia. -Qed. - -Lemma idsn_lt {n i} : i < n -> nth_error (idsn n) i = Some (tRel i). -Proof. - induction n in i |- *; simpl; auto. - - intros H; lia. - - intros H. destruct (Compare_dec.le_lt_dec n i). - -- assert (n = i) by lia; subst. - rewrite nth_error_app_ge idsn_length ?Nat.sub_diag; trea. - -- rewrite nth_error_app_lt ?idsn_length //. apply IHn; lia. -Qed. - -Lemma nth_error_idsn_Some : - forall n k, - k < n -> - nth_error (idsn n) k = Some (tRel k). -Proof. - intros n k h. - induction n in k, h |- *. - - inversion h. - - simpl. destruct (Nat.ltb_spec0 k n). - + rewrite nth_error_app1. - * rewrite idsn_length. auto. - * eapply IHn. assumption. - + assert (k = n) by lia. subst. - rewrite nth_error_app2. - * rewrite idsn_length. auto. - * rewrite idsn_length. replace (n - n) with 0 by lia. - simpl. reflexivity. -Qed. - -Lemma nth_error_idsn_None : - forall n k, - k >= n -> - nth_error (idsn n) k = None. +Lemma subst_app_context s s' Γ : subst_context (s ++ s') 0 Γ = subst_context s 0 (subst_context s' #|s| Γ). Proof. - intros n k h. - eapply nth_error_None. - rewrite idsn_length. auto. + induction Γ; simpl; auto. + rewrite !subst_context_snoc /= /subst_decl /map_decl /=. simpl. + rewrite IHΓ. f_equal. f_equal. + - destruct a as [na [b|] ty]; simpl; auto. + f_equal. rewrite subst_context_length Nat.add_0_r. + now rewrite subst_app_simpl. + - rewrite subst_context_length Nat.add_0_r. + now rewrite subst_app_simpl. Qed. -Lemma up_Upn {n σ} : up n σ =1 ⇑^n σ. +Lemma subst_app_context' (s s' : list term) (Γ : context) n : + n = #|s| -> + subst_context (s ++ s') 0 Γ = subst_context s 0 (subst_context s' n Γ). Proof. - unfold up, Upn. - intros i. - elim (Nat.leb_spec n i) => H. - - rewrite rename_inst. - rewrite subst_consn_ge; rewrite idsn_length; auto. - - assert (Hle: i < #|idsn n|) by (rewrite idsn_length; lia). - edestruct (subst_consn_lt Hle) as [x [Hnth Hsubst_cons]]. - rewrite Hsubst_cons. rewrite idsn_lt in Hnth; auto. congruence. + intros ->; apply subst_app_context. Qed. -(** Simplify away iterated up's *) -Hint Rewrite @up_Upn : sigma. - -(** The σ-calculus equations for Coq *) - -Lemma inst_app {s t σ} : (tApp s t).[σ] = tApp s.[σ] t.[σ]. -Proof. reflexivity. Qed. - -Lemma inst_lam {na t b σ} : (tLambda na t b).[σ] = tLambda na t.[σ] b.[⇑ σ]. -Proof. - simpl. now rewrite up_Up. -Qed. - -Lemma inst_prod {na t b σ} : (tProd na t b).[σ] = tProd na t.[σ] b.[⇑ σ]. +Lemma map_subst_app_simpl l l' k (ts : list term) : + map (subst l k ∘ subst l' (k + #|l|)) ts = + map (subst (l ++ l') k) ts. Proof. - simpl. now rewrite up_Up. + eapply map_ext. intros. + now rewrite subst_app_simpl. Qed. -Lemma inst_letin {na t b b' σ} : (tLetIn na t b b').[σ] = tLetIn na t.[σ] b.[σ] b'.[⇑ σ]. +Lemma simpl_map_lift x n k : + map (lift0 n ∘ lift0 k) x = + map (lift k n ∘ lift0 n) x. Proof. - simpl. now rewrite up_Up. + apply map_ext => t. + rewrite simpl_lift => //; try lia. + rewrite simpl_lift; try lia. + now rewrite Nat.add_comm. Qed. -Lemma inst_fix {mfix idx σ} : (tFix mfix idx).[σ] = - tFix (map (map_def (inst σ) (inst (⇑^#|mfix| σ))) mfix) idx. +Lemma subst_it_mkProd_or_LetIn n k ctx t : + subst n k (it_mkProd_or_LetIn ctx t) = + it_mkProd_or_LetIn (subst_context n k ctx) (subst n (length ctx + k) t). Proof. - simpl. f_equal. apply map_ext. intros x. apply map_def_eq_spec. reflexivity. - now rewrite up_Upn. + induction ctx in n, k, t |- *; simpl; try congruence. + pose (subst_context_snoc n k ctx a). unfold snoc in e. rewrite e. clear e. + simpl. rewrite -> IHctx. + pose (subst_context_snoc n k ctx a). simpl. now destruct a as [na [b|] ty]. Qed. -Lemma inst_cofix {mfix idx σ} : (tCoFix mfix idx).[σ] = - tCoFix (map (map_def (inst σ) (inst (⇑^#|mfix| σ))) mfix) idx. +Lemma map_subst_instance_to_extended_list_k u ctx k : + to_extended_list_k (subst_instance u ctx) k + = to_extended_list_k ctx k. Proof. - simpl. f_equal. apply map_ext. intros x. apply map_def_eq_spec. reflexivity. - now rewrite up_Upn. -Qed. - -Lemma inst_mkApps : - forall t l σ, - (mkApps t l).[σ] = mkApps t.[σ] (map (inst σ) l). -Proof. - intros t l σ. - induction l in t, σ |- *. - - reflexivity. - - simpl. rewrite IHl. reflexivity. -Qed. - -Hint Rewrite @inst_app @inst_lam @inst_prod @inst_letin @inst_fix @inst_cofix - @inst_mkApps : sigma. - -Lemma subst_cons_0 t σ : (tRel 0).[t ⋅ σ] = t. Proof. reflexivity. Qed. -Lemma subst_cons_shift t σ : ↑ ∘s (t ⋅ σ) = σ. Proof. reflexivity. Qed. -Hint Rewrite subst_cons_0 subst_cons_shift : sigma. - -Lemma shiftk_shift n : ↑^(S n) =1 ↑^n ∘s ↑. Proof. reflexivity. Qed. - -Lemma shiftk_shift_l n : ↑^(S n) =1 ↑ ∘s ↑^n. -Proof. - intros i. - unfold shiftk. unfold subst_compose, shift. - simpl. f_equal. lia. -Qed. - -Lemma Upn_1_Up σ : ⇑^1 σ =1 ⇑ σ. -Proof. - unfold Upn. - intros i. destruct i; auto. - simpl. rewrite subst_consn_ge. simpl. auto with arith. - simpl. rewrite Nat.sub_0_r. reflexivity. -Qed. -Hint Rewrite Upn_1_Up : sigma. - -Lemma subst_subst_consn s σ τ : (s ⋅ σ) ∘s τ =1 (s.[τ] ⋅ σ ∘s τ). -Proof. - intros i. - destruct i. simpl. reflexivity. - simpl. reflexivity. + unfold to_extended_list_k. + cut (map (subst_instance u) [] = []); [|reflexivity]. + unf_term. generalize (@nil term); intros l Hl. + induction ctx in k, l, Hl |- *; cbnr. + destruct a as [? [] ?]; cbnr; eauto. Qed. -Hint Rewrite subst_subst_consn : sigma. - -Lemma ren_shift : ↑ =1 ren S. -Proof. reflexivity. Qed. - -Lemma compose_ren f g : ren f ∘s ren g =1 ren (g ∘ f). +Lemma to_extended_list_k_subst n k c k' : + to_extended_list_k (subst_context n k c) k' = to_extended_list_k c k'. Proof. - intros i. - destruct i; simpl; reflexivity. + unfold to_extended_list_k. revert k'. + unf_term. generalize (@nil term) at 1 2. + induction c in n, k |- *; simpl; intros. 1: reflexivity. + rewrite subst_context_snoc. unfold snoc. simpl. + destruct a. destruct decl_body. + - unfold subst_decl, map_decl. simpl. + now rewrite IHc. + - simpl. apply IHc. Qed. -Lemma subst_cons_ren i f : (tRel i ⋅ ren f) =1 ren (subst_cons_gen i f). +Lemma it_mkProd_or_LetIn_inj ctx s ctx' s' : + it_mkProd_or_LetIn ctx (tSort s) = it_mkProd_or_LetIn ctx' (tSort s') -> + ctx = ctx' /\ s = s'. Proof. - intros x; destruct x; auto. + move/(f_equal (destArity [])). + rewrite !destArity_it_mkProd_or_LetIn /=. + now rewrite !app_context_nil_l => [= -> ->]. Qed. -Fixpoint ren_ids (n : nat) := - match n with - | 0 => [] - | S n => ren_ids n ++ [n] +Lemma destArity_spec ctx T : + match destArity ctx T with + | Some (ctx', s) => it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s) + | None => True end. - -Lemma ren_ids_length n : #|ren_ids n| = n. -Proof. induction n; simpl; auto. rewrite app_length IHn; simpl; lia. Qed. - -Lemma ren_ids_lt {n i} : i < n -> nth_error (ren_ids n) i = Some i. -Proof. - induction n in i |- *; simpl; auto. - - intros H; lia. - - intros H. destruct (Compare_dec.le_lt_dec n i). - -- assert (n = i) by lia; subst. - rewrite nth_error_app_ge ren_ids_length ?Nat.sub_diag; trea. - -- rewrite nth_error_app_lt ?ren_ids_length //. apply IHn; lia. -Qed. - -Infix "=2" := (Logic.eq ==> (pointwise_relation _ Logic.eq))%signature (at level 80). - -Definition compose2 {A B C} (g : B -> C) (f : A -> B) : A -> C := - fun x => g (f x). -Infix "∘'" := compose2 (at level 90). - -Delimit Scope program_scope with prog. - -Lemma subst_consn_subst_cons' {A} (t : A) l : subst_consn (t :: l) =2 ((subst_cons_gen t) ∘ (subst_consn l)). -Proof. red. - intros x y <-. apply subst_consn_subst_cons_gen. -Qed. - -Lemma subst_consn_ids_ren n f : (idsn n ⋅n ren f) =1 ren (ren_ids n ⋅n f). -Proof. - intros i. - destruct (Nat.leb_spec n i). - - rewrite subst_consn_ge idsn_length. auto. - unfold ren. f_equal. rewrite subst_consn_ge ren_ids_length; auto. - - assert (Hr:i < #|ren_ids n|) by (rewrite ren_ids_length; lia). - assert (Hi:i < #|idsn n|) by (rewrite idsn_length; lia). - destruct (subst_consn_lt Hi) as [x' [Hnth He]]. - destruct (subst_consn_lt Hr) as [x'' [Hnth' He']]. - rewrite (idsn_lt H) in Hnth. - rewrite (ren_ids_lt H) in Hnth'. - injection Hnth as <-. injection Hnth' as <-. rewrite He. - unfold ren. now rewrite He'. -Qed. - -Lemma ren_shiftk n : ↑^n =1 ren (add n). -Proof. reflexivity. Qed. - -(** Specific lemma for the fix/cofix cases where we are subst_cons'ing a list of ids in front - of the substitution. *) -Lemma ren_subst_consn_comm: - forall (f : nat -> nat) (σ : nat -> term) (n : nat), - ren (subst_consn (ren_ids n) (Init.Nat.add n ∘ f)) ∘s subst_consn (idsn n) (σ ∘s ↑^n) =1 - subst_consn (idsn n) (ren f ∘s σ ∘s ↑^n). Proof. - intros f σ m i. - destruct (Nat.leb_spec m i). - -- unfold ren, subst_compose. simpl. - rewrite [subst_consn (idsn _) _ i]subst_consn_ge ?idsn_length. lia. - rewrite [subst_consn (ren_ids _) _ i]subst_consn_ge ?ren_ids_length. lia. - rewrite subst_consn_ge ?idsn_length. lia. - f_equal. f_equal. lia. - -- assert (Hr:i < #|ren_ids m |) by (rewrite ren_ids_length; lia). - assert (Hi:i < #|idsn m |) by (rewrite idsn_length; lia). - destruct (subst_consn_lt Hi) as [x' [Hnth He]]. - rewrite He. - unfold ren, subst_compose. simpl. - destruct (subst_consn_lt Hr) as [x'' [Hnth' He']]. - rewrite He'. rewrite (idsn_lt H) in Hnth. injection Hnth as <-. - rewrite (ren_ids_lt H) in Hnth'. injection Hnth' as <-. - rewrite He. reflexivity. + induction T in ctx |- *; simpl; try easy. + - specialize (IHT2 (ctx,, vass na T1)). now destruct destArity. + - specialize (IHT3 (ctx,, vdef na T1 T2)). now destruct destArity. Qed. -Lemma rename_inst_assoc t f σ : t.[ren f].[σ] = t.[ren f ∘s σ]. +Lemma destArity_spec_Some ctx T ctx' s : + destArity ctx T = Some (ctx', s) + -> it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s). Proof. - revert f σ. - elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - - f_equal. rewrite map_map_compose; solve_all. - - f_equal; auto. autorewrite with sigma. - unfold Up. - simpl. rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. - apply inst_ext. intros i. destruct i; auto. - - f_equal; auto. autorewrite with sigma. - unfold Up. - rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. - apply inst_ext. intros i. destruct i; auto. - - f_equal; auto. autorewrite with sigma. - unfold Up. - rewrite ren_shift. rewrite compose_ren subst_cons_ren H1. - apply inst_ext. intros i. destruct i; auto. - - f_equal; auto. - red in X. rewrite map_map_compose. solve_all. - rewrite on_snd_on_snd. - solve_all. - - f_equal; auto. - red in X. rewrite map_map_compose. solve_all. - rewrite map_def_map_def map_length. apply map_def_eq_spec; solve_all. - autorewrite with sigma. - unfold Upn. rewrite !compose_ren. - rewrite !subst_consn_ids_ren. - rewrite b. simpl. apply inst_ext. apply ren_subst_consn_comm. - - f_equal; auto. - red in X. rewrite map_map_compose. solve_all. - rewrite map_def_map_def map_length. apply map_def_eq_spec; solve_all. - autorewrite with sigma. - unfold Upn. rewrite !compose_ren. - rewrite !subst_consn_ids_ren. - rewrite b. simpl. apply inst_ext, ren_subst_consn_comm. -Qed. - -Lemma inst_rename_assoc_n: - forall (f : nat -> nat) (σ : nat -> term) (n : nat), - subst_consn (idsn n) (σ ∘s ↑^n) ∘s ren (subst_consn (ren_ids n) (Init.Nat.add n ∘ f)) =1 - subst_consn (idsn n) (σ ∘s ren f ∘s ↑^n). -Proof. - intros f σ m. rewrite ren_shiftk. - intros i. - destruct (Nat.leb_spec m i). - -- rewrite [subst_consn (idsn _) _ i]subst_consn_ge ?idsn_length. lia. - unfold subst_compose. - rewrite [subst_consn (idsn _) _ i]subst_consn_ge ?idsn_length. lia. - rewrite !rename_inst_assoc !compose_ren. - apply inst_ext. intros i'. - unfold ren. f_equal. rewrite subst_consn_ge ?ren_ids_length. lia. - now assert (m + i' - m = i') as -> by lia. - -- assert (Hr:i < #|ren_ids m |) by (rewrite ren_ids_length; lia). - assert (Hi:i < #|idsn m |) by (rewrite idsn_length; lia). - destruct (subst_consn_lt Hi) as [x' [Hnth He]]. - rewrite He. - unfold subst_compose. simpl. - rewrite (idsn_lt H) in Hnth. injection Hnth as <-. rewrite He. - simpl. unfold ren. f_equal. - destruct (subst_consn_lt Hr) as [x'' [Hnth' He']]. - rewrite (ren_ids_lt H) in Hnth'. injection Hnth' as <-. now rewrite He'. -Qed. - -Lemma inst_rename_assoc t f σ : t.[σ].[ren f] = t.[σ ∘s ren f]. -Proof. - revert f σ. - elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - - f_equal. rewrite map_map_compose; solve_all. - - f_equal; auto. autorewrite with sigma. - unfold Up. - rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. - apply inst_ext. intros i. destruct i; auto. simpl. - unfold subst_compose. simpl. now rewrite !rename_inst_assoc !compose_ren. - - f_equal; auto. autorewrite with sigma. - unfold Up. - rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. - apply inst_ext. intros i. destruct i; auto. - unfold subst_compose. simpl. now rewrite !rename_inst_assoc !compose_ren. - - f_equal; auto. autorewrite with sigma. - unfold Up. - rewrite ren_shift. rewrite compose_ren subst_cons_ren H1. - apply inst_ext. intros i. destruct i; auto. - unfold subst_compose. simpl. now rewrite !rename_inst_assoc !compose_ren. - - f_equal; auto. - red in X. rewrite map_map_compose. solve_all. - rewrite on_snd_on_snd. - solve_all. - - f_equal; auto. - red in X. rewrite map_map_compose. solve_all. - rewrite map_def_map_def map_length. apply map_def_eq_spec; solve_all. - autorewrite with sigma. - unfold Upn. rewrite !compose_ren. - rewrite !subst_consn_ids_ren. - rewrite b. simpl. apply inst_ext. apply inst_rename_assoc_n. - - f_equal; auto. - red in X. rewrite map_map_compose. solve_all. - rewrite map_def_map_def map_length. apply map_def_eq_spec; solve_all. - autorewrite with sigma. - unfold Upn. rewrite !compose_ren. - rewrite !subst_consn_ids_ren. - rewrite b. simpl. apply inst_ext, inst_rename_assoc_n. -Qed. - -Lemma rename_subst_compose1 r s s' : ren r ∘s (s ∘s s') =1 ren r ∘s s ∘s s'. -Proof. unfold subst_compose. simpl. intros i. reflexivity. Qed. - -Lemma rename_subst_compose2 r s s' : s ∘s (ren r ∘s s') =1 s ∘s ren r ∘s s'. -Proof. - unfold subst_compose. simpl. intros i. - rewrite rename_inst_assoc. reflexivity. -Qed. - -Lemma rename_subst_compose3 r s s' : s ∘s (s' ∘s ren r) =1 s ∘s s' ∘s ren r. -Proof. - unfold subst_compose. simpl. intros i. - rewrite inst_rename_assoc. reflexivity. -Qed. - -Lemma Up_Up_assoc: - forall s s' : nat -> term, (⇑ s) ∘s (⇑ s') =1 ⇑ (s ∘s s'). -Proof. - intros s s'. - unfold Up. - rewrite ren_shift. - rewrite subst_subst_consn. - simpl. apply subst_cons_proper. reflexivity. - rewrite - rename_subst_compose2. - rewrite - rename_subst_compose3. - apply subst_compose_proper; auto. reflexivity. - reflexivity. -Qed. - -Hint Rewrite Up_Up_assoc : sigma. - -Lemma up_up_assoc: - forall (s s' : nat -> term) (n : nat), up n s ∘s up n s' =1 up n (s ∘s s'). -Proof. - intros s s' n i. - unfold up, subst_compose. simpl. - destruct (Nat.leb_spec n i). - rewrite !(rename_inst (add n) (s (i - n))). - rewrite rename_inst_assoc. - rewrite !(rename_inst (add n) _). - rewrite inst_rename_assoc. - apply inst_ext. - intros i'. unfold subst_compose. - unfold ren. simpl. - destruct (Nat.leb_spec n (n + i')). - rewrite rename_inst. - assert (n + i' - n = i') as -> by lia. reflexivity. - lia. - simpl. - destruct (Nat.leb_spec n i). lia. reflexivity. -Qed. - -Lemma inst_assoc t s s' : t.[s].[s'] = t.[s ∘s s']. -Proof. - revert s s'. - elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - - f_equal. rewrite map_map_compose; solve_all. - - f_equal; auto. autorewrite with sigma. - now rewrite H0 Up_Up_assoc. - - f_equal; auto. autorewrite with sigma. - now rewrite H0 Up_Up_assoc. - - f_equal; auto. autorewrite with sigma. - now rewrite H1 Up_Up_assoc. - - f_equal; auto. autorewrite with sigma. - rewrite map_map_compose; solve_all. - rewrite on_snd_on_snd. solve_all. - - f_equal; auto. autorewrite with sigma. - rewrite map_map_compose; solve_all. - rewrite map_def_map_def. - apply map_def_eq_spec; auto. - rewrite b. - now rewrite map_length up_up_assoc. - - f_equal; auto. autorewrite with sigma. - rewrite map_map_compose; solve_all. - rewrite map_def_map_def. - apply map_def_eq_spec; auto. - rewrite b. - now rewrite map_length up_up_assoc. -Qed. - -Hint Rewrite inst_assoc : sigma. - -Lemma subst_compose_assoc s s' s'' : (s ∘s s') ∘s s'' =1 s ∘s (s' ∘s s''). -Proof. - intros i; unfold subst_compose at 1 3 4. - now rewrite inst_assoc. -Qed. - -Hint Rewrite subst_compose_assoc : sigma. - -Lemma Upn_0 σ : ⇑^0 σ =1 σ. -Proof. - unfold Upn. simpl. - now rewrite subst_consn_nil shiftk_0 compose_ids_r. -Qed. - -Lemma Upn_Up σ n : ⇑^(S n) σ =1 ⇑^n ⇑ σ. -Proof. - intros i. unfold Upn. - simpl. rewrite subst_consn_app. - 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. unfold shiftk. now rewrite Nat.add_0_r. - simpl. now rewrite inst_assoc. -Qed. - -Lemma Upn_1 σ : ⇑^1 σ =1 ⇑ σ. -Proof. now rewrite Upn_Up Upn_0. Qed. - -Lemma subst_cons_0_shift : tRel 0 ⋅ ↑ =1 ids. -Proof. intros i. destruct i; reflexivity. Qed. - -Hint Rewrite subst_cons_0_shift : sigma. - -Lemma subst_cons_0s_shifts σ : (σ 0) ⋅ (↑ ∘s σ) =1 σ. -Proof. - intros i. destruct i; auto. -Qed. - -Hint Rewrite subst_cons_0s_shifts : sigma. - -(* Print Rewrite HintDb sigma. *) - -Lemma subst_inst_aux s k t : subst s k t = inst (up k (subst_fn s)) t. -Proof. - revert s k. - elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); - try solve [f_equal; solve_all]. - - - unfold subst_fn, up. - elim (leb_spec k n). intros H. - destruct nth_error eqn:Heq. - apply lift_rename. - simpl. eapply nth_error_None in Heq. f_equal. lia. - reflexivity. - - - f_equal; eauto. - rewrite H0. apply inst_ext. intros t'; now rewrite (up_up 1 k). - - f_equal; eauto. - rewrite H0. apply inst_ext. intros t'; now rewrite (up_up 1 k). - - f_equal; eauto. - rewrite H1. apply inst_ext. intros t'; now rewrite (up_up 1 k). - - f_equal; eauto. - solve_all; auto. apply map_def_eq_spec; auto. - rewrite b. apply inst_ext. intros t'; now rewrite (up_up #|m| k). - - f_equal; eauto. - solve_all; auto. apply map_def_eq_spec; auto. - rewrite b. apply inst_ext. intros t'; now rewrite (up_up #|m| k). -Qed. - -Lemma subst_fn_subst_consn s : subst_fn s =1 subst_consn s ids. -Proof. reflexivity. Qed. - -Theorem subst_inst s k t : subst s k t = inst (⇑^k (subst_consn s ids)) t. -Proof. - rewrite subst_inst_aux up_Upn. apply inst_ext. - unfold Upn. now rewrite subst_fn_subst_consn. -Qed. - -(** Simplify away [subst] to the σ-calculus [inst] primitive. *) -Hint Rewrite @subst_inst : sigma. - -Hint Rewrite shiftk_shift_l shiftk_shift : sigma. -(* Hint Rewrite Upn_eq : sigma. *) - -(** Can't move to PCUICInduction because of fix_context definition *) -Lemma term_forall_ctx_list_ind : - forall P : context -> term -> Type, - (forall Γ (n : nat), P Γ (tRel n)) -> - (forall Γ (i : ident), P Γ (tVar i)) -> - (forall Γ (n : nat) (l : list term), All (P Γ) l -> P Γ (tEvar n l)) -> - (forall Γ s, P Γ (tSort s)) -> - (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P (vass n t :: Γ) t0 -> P Γ (tProd n t t0)) -> - (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), 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 Γ (p : inductive * nat) (t : term), - P Γ t -> forall t0 : term, P Γ t0 -> forall l : list (nat * term), - tCaseBrsProp (P Γ) l -> P Γ (tCase p t t0 l)) -> - (forall Γ (s : projection) (t : term), P Γ t -> P Γ (tProj s t)) -> - (forall Γ (m : mfixpoint term) (n : nat), tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tFix m n)) -> - (forall Γ (m : mfixpoint term) (n : nat), tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tCoFix m n)) -> - (forall Γ p, P Γ (tPrim p)) -> - forall Γ (t : term), P Γ t. -Proof. - intros. revert Γ t0. - fix auxt 2. - move auxt at top. - destruct t0; match goal with - H : _ |- _ => apply H - end; auto. - revert l. - fix auxl' 1. - destruct l; constructor; [|apply auxl']. - apply auxt. - revert brs. - fix auxl' 1. - destruct brs; constructor; [|apply auxl']. - apply auxt. - - generalize (fix_context mfix). revert mfix. - fix auxm 1. - destruct mfix; constructor. - split. apply auxt. apply auxt. apply auxm. - - generalize (fix_context mfix). revert mfix. - fix auxm 1. - destruct mfix; constructor. - split. apply auxt. apply auxt. apply auxm. -Defined. - - -Fixpoint subst_app (t : term) (us : list term) : term := - match t, us with - | tLambda _ A t, u :: us => subst_app (t {0 := u}) us - | _, [] => t - | _, _ => mkApps t us - end. - + pose proof (destArity_spec ctx T) as H. + intro e; now rewrite e in H. +Qed. \ No newline at end of file diff --git a/pcuic/theories/PCUICNameless.v b/pcuic/theories/PCUICNameless.v index 198c9d82d..a919483c6 100644 --- a/pcuic/theories/PCUICNameless.v +++ b/pcuic/theories/PCUICNameless.v @@ -2,10 +2,14 @@ From Coq Require Import RelationClasses. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction - PCUICLiftSubst PCUICEquality PCUICTyping PCUICPosition PCUICUnivSubst. + PCUICLiftSubst PCUICEquality PCUICTyping PCUICPosition PCUICUnivSubst + PCUICContextRelation + PCUICSigmaCalculus (* for context manipulations *). Require Import Equations.Prop.DepElim. Require Import ssreflect. +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 @@ -25,6 +29,10 @@ Definition anon (na : name) : bool := Definition banon (na : binder_annot name) : bool := anon na.(binder_name). +Definition nameless_decl nameless (d : context_decl) := + banon (decl_name d) && nameless d.(decl_type) && + option_default nameless d.(decl_body) true. + Fixpoint nameless (t : term) : bool := match t with | tRel n => true @@ -38,8 +46,11 @@ Fixpoint nameless (t : term) : bool := | tConst c u => true | tInd i u => true | tConstruct i n u => true - | tCase indn p c brs => - nameless p && nameless c && forallb (test_snd nameless) brs + | tCase ci p c brs => + forallb nameless p.(pparams) && + forallb (nameless_decl nameless) p.(pcontext) && + 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 => forallb (fun d => banon d.(dname)) mfix && @@ -50,6 +61,8 @@ Fixpoint nameless (t : term) : bool := | tPrim _ => true end. +Notation nameless_ctx := (forallb (nameless_decl nameless)). + Definition anonymize (b : binder_annot name) : binder_annot name := map_binder_annot (fun _ => nAnon) b. @@ -60,6 +73,22 @@ Definition map_def_anon {A B} (tyf bodyf : A -> B) (d : def A) := {| rarg := d.(rarg) |}. +Definition map_decl_anon (f : term -> term) (d : context_decl) := {| + decl_name := anonymize d.(decl_name) ; + decl_body := option_map f d.(decl_body) ; + decl_type := f d.(decl_type) +|}. + +Definition nl_predicate (nl : term -> term) (p : predicate term) : predicate term := + {| pparams := map nl p.(pparams); + puinst := p.(puinst); + pcontext := map (map_decl_anon nl) p.(pcontext); + preturn := nl p.(preturn); |}. + +Definition nl_branch (nl : term -> term) (b : branch term) : branch term := + {| bcontext := map (map_decl_anon nl) b.(bcontext); + bbody := nl b.(bbody); |}. + Fixpoint nl (t : term) : term := match t with | tRel n => tRel n @@ -73,33 +102,35 @@ Fixpoint nl (t : term) : term := | tConst c u => tConst c u | tInd i u => tInd i u | tConstruct i n u => tConstruct i n u - | tCase indn p c brs => tCase indn (nl p) (nl c) (map (on_snd nl) brs) + | tCase ci p c brs => tCase ci (nl_predicate nl p) (nl c) (map (nl_branch nl) brs) | tProj p c => tProj p (nl c) | tFix mfix idx => tFix (map (map_def_anon nl nl) mfix) idx | tCoFix mfix idx => tCoFix (map (map_def_anon nl nl) mfix) idx | tPrim p => tPrim p end. -Definition map_decl_anon f (d : context_decl) := {| - decl_name := anonymize d.(decl_name) ; - decl_body := option_map f d.(decl_body) ; - decl_type := f d.(decl_type) -|}. - Definition nlctx (Γ : context) : context := map (map_decl_anon nl) Γ. - Definition nl_constant_body c := Build_constant_body (nl c.(cst_type)) (option_map nl c.(cst_body)) c.(cst_universes). +Definition nl_constructor_body c := + {| 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_one_inductive_body o := Build_one_inductive_body o.(ind_name) + (nlctx o.(ind_indices)) + o.(ind_sort) (nl o.(ind_type)) o.(ind_kelim) - (map (fun '((x,y),n) => ((x, nl y), n)) o.(ind_ctors)) + (map nl_constructor_body o.(ind_ctors)) (map (fun '(x,y) => (x, nl y)) o.(ind_projs)) o.(ind_relevance). @@ -117,9 +148,12 @@ Definition nl_global_decl (d : global_decl) : global_decl := | InductiveDecl mib => InductiveDecl (nl_mutual_inductive_body mib) end. +Definition nl_global_env (Σ : global_env) : global_env := + (map (on_snd nl_global_decl) Σ). + Definition nlg (Σ : global_env_ext) : global_env_ext := let '(Σ, φ) := Σ in - (map (on_snd nl_global_decl) Σ, φ). + (nl_global_env Σ, φ). Ltac destruct_one_andb := lazymatch goal with @@ -155,6 +189,33 @@ Proof. now unfold eq_binder_annot; simpl; intros ->. Qed. +Lemma nameless_eqctx_IH P ctx ctx' : + nameless_ctx ctx -> nameless_ctx ctx' -> + eq_context_gen upto_names' upto_names' ctx ctx' -> + onctx P ctx -> + (forall napp x, P x -> + forall y, nameless x -> nameless y -> + eq_term_upto_univ_napp [] eq eq napp x y -> x = y) -> + ctx = ctx'. +Proof. + solve_all. + induction X; auto. + all:destruct p; depelim H0; depelim X0; auto; f_equal; auto. + - destruct p. + unfold nameless_decl in i, i0; rtoProp. + f_equal. + * eapply banon_eq_binder_annot; eauto. + * simpl in *. + eapply H1; eauto. apply o. + - destruct p as [? [? ?]]. + unfold nameless_decl in i, i0; rtoProp. + f_equal. + * eapply banon_eq_binder_annot; eauto. + * simpl in *. + eapply H1; eauto. + * simpl in *. eapply H1; eauto. +Qed. + Lemma nameless_eq_term_spec : forall u v napp, nameless u -> @@ -187,16 +248,33 @@ Proof. - f_equal ; try solve [ ih ]. eapply eq_univ_make. assumption. - f_equal ; try solve [ ih ]. - revert brs' H3 H0 a. - induction l ; intros brs' h1 h2 h. - + destruct brs' ; inversion h. reflexivity. - + destruct brs' ; inversion h. subst. - cbn in h1, h2. destruct_andb. - inversion X. subst. - f_equal. - * destruct a, p0. cbn in *. destruct X0. subst. - f_equal. eapply H8; eassumption. - * eapply IHl ; assumption. + * destruct e as [eqpar [eqinst [eqctx eqret]]]. + destruct X as [? [? ?]]. + destruct p, p'; simpl in *. f_equal. + + apply All2_eq; solve_all. + + red in eqinst. + apply Forall2_eq. eapply Forall2_map_inv in eqinst. + eapply (Forall2_impl eqinst); solve_all. + now apply Universe.make_inj in H. + + simpl in *. + eapply nameless_eqctx_IH; eauto. + + ih. + * revert brs' H3 H0 a. + induction l ; intros brs' h1 h2 h. + + destruct brs' ; inversion h. reflexivity. + + destruct brs' ; inversion h. subst. + cbn in h1, h2. destruct_andb. + inversion X. subst. simpl in H5. + move/andb_and: H5 => [/andb_and [Hac Hab] Hl]. + apply forallb_All in Hac. + f_equal. + ++ destruct a, b. cbn in *. destruct X1. + depelim h. destruct p0. depelim X0. simpl in *. + destruct p0 as []. + destruct X4. + f_equal; try ih. + { eapply nameless_eqctx_IH; eauto; solve_all. } + ++ eapply IHl ; tas. now depelim X0. - f_equal ; try solve [ ih ]. revert mfix' H1 H2 H H0 a. induction m ; intros m' h1 h2 h3 h4 h. @@ -235,6 +313,11 @@ Proof. * eapply IHm ; assumption. Qed. +Lemma banon_list l : forallb (banon ∘ anonymize) l. +Proof. + induction l; simpl; auto. +Qed. + Lemma nl_spec : forall u, nameless (nl u). Proof. @@ -242,12 +325,22 @@ Proof. all: try reflexivity. all: try (simpl ; repeat (eapply andb_true_intro ; split) ; assumption). - cbn. eapply All_forallb. eapply All_map. assumption. - - simpl ; repeat (eapply andb_true_intro ; split) ; try assumption. - induction l. - + reflexivity. - + cbn. inversion X. subst. - repeat (eapply andb_true_intro ; split) ; try assumption. - eapply IHl. assumption. + - destruct X as [? [? ?]]. + simpl ; repeat (eapply andb_true_intro ; split) ; try assumption. + * eapply All_forallb, All_map; assumption. + * rewrite forallb_map. + eapply All_forallb. unfold ondecl in *. solve_all. + rewrite /nameless_decl /= a0. + destruct (decl_body x); simpl in *; auto. + * induction l. + + reflexivity. + + cbn. depelim X0. destruct p0. + repeat (eapply andb_true_intro ; split) ; try assumption. + ++ rewrite forallb_map. + eapply All_forallb. unfold ondecl in *; solve_all. + rewrite /nameless_decl /= a2. + destruct (decl_body x); simpl in *; auto. + ++ eapply IHl. assumption. - simpl ; repeat (eapply andb_true_intro ; split) ; try assumption. + induction m. * reflexivity. @@ -272,7 +365,7 @@ Qed. Lemma nl_lookup_env : forall Σ c, - lookup_env (map (on_snd nl_global_decl) Σ) c + lookup_env (nl_global_env Σ) c = option_map nl_global_decl (lookup_env Σ c). Proof. intros Σ c. @@ -303,7 +396,7 @@ Proof. Qed. Lemma global_variance_nl_sigma_mon {Σ gr napp} : - global_variance (map (on_snd nl_global_decl) Σ) gr napp = + global_variance (nl_global_env Σ) gr napp = global_variance Σ gr napp. Proof. rewrite /global_variance /lookup_constructor /lookup_inductive /lookup_minductive. @@ -323,22 +416,39 @@ Proof. destruct nth_error => /= //. rewrite nth_error_map. destruct nth_error => /= //. - destruct p as [[id t] args] => /= //. Qed. Lemma R_global_instance_nl Σ Re Rle gr napp : CRelationClasses.subrelation (R_global_instance Σ Re Rle gr napp) - (R_global_instance (map (on_snd nl_global_decl) Σ) Re Rle gr napp). + (R_global_instance (nl_global_env Σ) Re Rle gr napp). Proof. intros t t'. unfold R_global_instance. now rewrite global_variance_nl_sigma_mon. Qed. +Lemma eq_context_nl_IH Σ Re Rle ctx ctx' : + (forall (napp : nat) (t t' : term) + (Rle : Universe.t -> Universe.t -> Prop), + eq_term_upto_univ_napp Σ Re Rle napp t t' -> + eq_term_upto_univ_napp (nl_global_env Σ) Re Rle napp + (nl t) (nl t')) -> + eq_context_gen (eq_term_upto_univ Σ Re Re) + (eq_term_upto_univ Σ Re Rle) ctx ctx' -> + eq_context_gen (eq_term_upto_univ (nl_global_env Σ) Re Re) + (eq_term_upto_univ (nl_global_env Σ) Re Rle) + (map (map_decl_anon nl) ctx) + (map (map_decl_anon nl) ctx'). +Proof. + intros aux H. + induction H; simpl; constructor; simpl; destruct p; simpl; + intuition (constructor; auto). +Defined. + Lemma nl_eq_term_upto_univ : forall Σ Re Rle napp t t', eq_term_upto_univ_napp Σ Re Rle napp t t' -> - eq_term_upto_univ_napp (map (on_snd nl_global_decl) Σ) Re Rle napp (nl t) (nl t'). + eq_term_upto_univ_napp (nl_global_env Σ) Re Rle napp (nl t) (nl t'). Proof. intros Σ Re Rle napp t t' h. revert napp t t' Rle h. fix aux 5. @@ -355,9 +465,14 @@ Proof. - econstructor. all: try solve [ eauto ]. eapply R_global_instance_nl; eauto. - econstructor; eauto. - induction a; constructor; auto. - intuition auto. - destruct x, y; simpl in *. apply aux; auto. + + red. destruct e; intuition auto; simpl. + * induction a0; constructor; auto. + * apply eq_context_nl_IH; tas. + * apply aux. auto. + + induction a; constructor; auto. + intuition auto; simpl. + * apply eq_context_nl_IH; tas. + * destruct x, y; simpl in *. apply aux; auto. - econstructor; eauto. induction a; constructor; auto. intuition auto. @@ -370,10 +485,23 @@ Proof. * destruct x, y; simpl in *. apply aux; auto. Qed. +Lemma eq_context_nl Σ Re Rle ctx ctx' : + eq_context_gen (eq_term_upto_univ Σ Re Re) + (eq_term_upto_univ Σ Re Rle) ctx ctx' -> + eq_context_gen + (eq_term_upto_univ (nl_global_env Σ) Re Re) + (eq_term_upto_univ (nl_global_env Σ) Re Rle) + (nlctx ctx) (nlctx ctx'). +Proof. + intros H. + induction H; constructor; simpl; destruct p; intuition + (constructor; auto using nl_eq_term_upto_univ). +Qed. + Lemma nl_leq_term {cf:checker_flags} Σ: forall φ t t', leq_term Σ φ t t' -> - leq_term (map (on_snd nl_global_decl) Σ) φ (nl t) (nl t'). + leq_term (nl_global_env Σ) φ (nl t) (nl t'). Proof. intros. apply nl_eq_term_upto_univ. assumption. Qed. @@ -381,7 +509,7 @@ Qed. Lemma nl_eq_term {cf:checker_flags} Σ: forall φ t t', eq_term Σ φ t t' -> - eq_term (map (on_snd nl_global_decl) Σ) φ (nl t) (nl t'). + eq_term (nl_global_env Σ) φ (nl t) (nl t'). Proof. intros. apply nl_eq_term_upto_univ. assumption. Qed. @@ -389,7 +517,7 @@ Qed. Lemma nl_compare_term {cf:checker_flags} le Σ: forall φ t t', compare_term le Σ φ t t' -> - compare_term le (map (on_snd nl_global_decl) Σ) φ (nl t) (nl t'). + compare_term le (nl_global_env Σ) φ (nl t) (nl t'). Proof. destruct le; intros. - apply nl_leq_term. assumption. @@ -415,6 +543,31 @@ Local Ltac ih3 := eapply ih ; assumption end. +Lemma eq_context_nl_inv_IH Σ Re ctx ctx' : + onctx + (fun u : term => + 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 -> + eq_context_gen + (eq_term_upto_univ Σ Re Re) + (eq_term_upto_univ Σ Re Re) + (map (map_decl_anon nl) ctx) + (map (map_decl_anon nl) ctx') -> + eq_context_gen (eq_term_upto_univ Σ Re Re) + (eq_term_upto_univ Σ Re Re) ctx ctx'. +Proof. + intros Hctx. unfold ondecl in *. + 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. + * depelim c. + * depelim c; constructor; auto. +Qed. + Lemma eq_term_upto_univ_nl_inv : forall Σ Re Rle napp u v, eq_term_upto_univ_napp Σ Re Rle napp (nl u) (nl v) -> @@ -436,39 +589,31 @@ Proof. - cbn in H. inversion H. subst. constructor. apply All2_map_inv in a. solve_all. - cbn in H. inversion H. subst. constructor ; try ih3. - apply All2_map_inv in a. solve_all. + + red. destruct e; solve_all. + * simpl in a0. eapply All2_map_inv in a0. solve_all. + * eapply eq_context_nl_inv_IH; tea. + + apply All2_map_inv in a. solve_all. + eapply eq_context_nl_inv_IH; tea. - cbn in H. inversion H. subst. constructor ; try ih3. apply All2_map_inv in a. solve_all. - cbn in H. inversion H. subst. constructor ; try ih3. apply All2_map_inv in a. solve_all. Qed. -(* TODO MOVE *) -Definition test_option {A} f (o : option A) : bool := - match o with - | None => true - | Some x => f x - end. - -Definition nameless_ctx (Γ : context) : bool := - forallb (fun d => - banon d.(decl_name) && - test_option nameless d.(decl_body) && - nameless d.(decl_type) - ) Γ. - Lemma nlctx_spec : forall Γ, nameless_ctx (nlctx Γ). Proof. intros Γ. induction Γ as [| [na [b|] B] Γ ih]. - reflexivity. - - simpl. rewrite 2!nl_spec ih. reflexivity. - - simpl. rewrite nl_spec ih. reflexivity. + - simpl. rewrite /nameless_decl /= 2!nl_spec ih. reflexivity. + - simpl. rewrite /nameless_decl /= nl_spec ih. reflexivity. Qed. Lemma binder_anonymize n : eq_binder_annot n (anonymize n). Proof. destruct n; reflexivity. Qed. Hint Resolve binder_anonymize : core. +Hint Constructors compare_decls : core. +Local Hint Unfold map_decl_anon : core. Lemma eq_term_upto_univ_tm_nl : forall Σ Re Rle napp u, @@ -486,11 +631,25 @@ Proof. + constructor. + simpl. inversion X. subst. constructor ; eauto. - simpl. destruct p. constructor ; eauto. - induction l. - + constructor. - + simpl. inversion X. subst. constructor. - * split ; auto. - * eapply IHl. assumption. + * destruct X; red; simpl in *; intuition auto. + + induction a; constructor; auto. + + reflexivity. + + clear -a0 hRe hRle. induction a0. + { constructor; auto. } + destruct x as [na [b|] ty]; simpl; constructor; auto; + destruct p; simpl in *; intuition (simpl; auto); + constructor; auto. + * induction l. + + constructor. + + simpl. depelim X0. destruct p. + simpl in *. repeat constructor. + ++ simpl. + clear -hRe hRle a0. + induction a0; [constructor; auto|]. + destruct x as [na [b|] ty]; simpl; constructor; auto; + destruct p; simpl in *; intuition auto; constructor; auto. + ++ auto. + ++ eapply IHl. assumption. - simpl. constructor. induction m. + constructor. + simpl. inversion X. subst. constructor ; auto. @@ -512,84 +671,6 @@ Proof. - intro. eapply eq_universe_refl. Qed. -Fixpoint nlstack (π : stack) : stack := - match π with - | ε => ε - | App u ρ => - App (nl u) (nlstack ρ) - | Fix f n args ρ => - Fix (map (map_def_anon nl nl) f) n (map nl args) (nlstack ρ) - | Fix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - Fix_mfix_ty (anonymize na) (nl bo) ra (map (map_def_anon nl nl) mfix1) (map (map_def_anon nl nl) mfix2) idx (nlstack ρ) - | Fix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - Fix_mfix_bd (anonymize na) (nl ty) ra (map (map_def_anon nl nl) mfix1) (map (map_def_anon nl nl) mfix2) idx (nlstack ρ) - | CoFix f n args ρ => - CoFix (map (map_def_anon nl nl) f) n (map nl args) (nlstack ρ) - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - CoFix_mfix_ty (anonymize na) (nl bo) ra (map (map_def_anon nl nl) mfix1) (map (map_def_anon nl nl) mfix2) idx (nlstack ρ) - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - CoFix_mfix_bd (anonymize na) (nl ty) ra (map (map_def_anon nl nl) mfix1) (map (map_def_anon nl nl) mfix2) idx (nlstack ρ) - | Case_p indn c brs ρ => - Case_p indn (nl c) (map (on_snd nl) brs) (nlstack ρ) - | Case indn p brs ρ => - Case indn (nl p) (map (on_snd nl) brs) (nlstack ρ) - | Case_brs indn p c m brs1 brs2 ρ => - Case_brs - indn (nl p) (nl c) m - (map (on_snd nl) brs1) (map (on_snd nl) brs2) (nlstack ρ) - | Proj p ρ => - Proj p (nlstack ρ) - | Prod_l na B ρ => - Prod_l (anonymize na) (nl B) (nlstack ρ) - | Prod_r na A ρ => - Prod_r (anonymize na) (nl A) (nlstack ρ) - | Lambda_ty na b ρ => - Lambda_ty (anonymize na) (nl b) (nlstack ρ) - | Lambda_tm na A ρ => - Lambda_tm (anonymize na) (nl A) (nlstack ρ) - | LetIn_bd na B u ρ => - LetIn_bd (anonymize na) (nl B) (nl u) (nlstack ρ) - | LetIn_ty na b u ρ => - LetIn_ty (anonymize na) (nl b) (nl u) (nlstack ρ) - | LetIn_in na b B ρ => - LetIn_in (anonymize na) (nl b) (nl B) (nlstack ρ) - | coApp t ρ => - coApp (nl t) (nlstack ρ) - end. - -Lemma nlstack_appstack : - forall args ρ, - nlstack (appstack args ρ) = appstack (map nl args) (nlstack ρ). -Proof. - intros args ρ. - induction args in ρ |- *. - - reflexivity. - - simpl. f_equal. eapply IHargs. -Qed. - -Lemma nlstack_cat : - forall ρ θ, - nlstack (ρ +++ θ) = nlstack ρ +++ nlstack θ. -Proof. - intros ρ θ. - induction ρ in θ |- *. - all: solve [ simpl ; rewrite ?IHρ ; reflexivity ]. -Qed. - -Lemma stack_position_nlstack : - forall ρ, - stack_position (nlstack ρ) = stack_position ρ. -Proof. - intros ρ. - induction ρ. - all: try solve [ simpl ; rewrite ?IHρ ; reflexivity ]. - - simpl. rewrite IHρ. rewrite map_length. reflexivity. - - simpl. rewrite IHρ. rewrite map_length. reflexivity. - - simpl. rewrite IHρ. rewrite map_length. reflexivity. - - simpl. rewrite IHρ. rewrite map_length. reflexivity. - - simpl. rewrite IHρ. rewrite map_length. reflexivity. -Qed. - Lemma nl_decompose_prod_assum : forall Γ t, decompose_prod_assum (nlctx Γ) (nl t) @@ -634,23 +715,31 @@ Proof. - simpl. f_equal. apply ih. Qed. -Lemma nl_subst_instance_constr : +Lemma nl_subst_instance : forall u b, - nl (subst_instance_constr u b) = subst_instance_constr u (nl b). + nl (subst_instance u b) = subst_instance u (nl b). Proof. intros u b. + rewrite /subst_instance /=. induction b using term_forall_list_ind. all: try (simpl ; rewrite ?IHb ?IHb1 ?IHb2 ?IHb3 ; reflexivity). - simpl. f_equal. rename X into H; induction H. + reflexivity. + simpl. rewrite p IHAll. reflexivity. - - simpl. rewrite IHb1 IHb2. f_equal. - induction X. - + reflexivity. - + simpl. f_equal. - * unfold on_snd. destruct p, x. simpl in *. - rewrite p0. reflexivity. - * apply IHX. + - simpl. rewrite IHb. f_equal. + * unfold nl_predicate, map_predicate. simpl. f_equal; solve_all. simpl. + unfold ondecl in *; solve_all. + unfold map_decl_anon, map_decl; destruct x as [na [bod|] ty]; simpl in *; + f_equal; auto. f_equal; auto. + * induction X0. + + reflexivity. + + simpl. f_equal. + ++ destruct x. simpl in *. unfold nl_branch, map_branch. + simpl. f_equal; solve_all. + unfold ondecl in *; solve_all. + unfold map_decl_anon, map_decl; destruct x as [na [bod|] ty]; simpl in *; + f_equal; auto. f_equal; auto. + ++ apply IHX0. - simpl. f_equal. induction X ; try reflexivity. simpl. rewrite IHX. f_equal. destruct p as [h1 h2]. @@ -675,59 +764,6 @@ Proof. - simpl. rewrite ih. reflexivity. Qed. -Lemma xposition_nlctx : - forall Γ π, - xposition (nlctx Γ) π = xposition Γ π. -Proof. - intros Γ π. - unfold xposition. - rewrite context_position_nlctx. - reflexivity. -Qed. - -Lemma xposition_nlstack : - forall Γ π, - xposition Γ (nlstack π) = xposition Γ π. -Proof. - intros Γ π. - unfold xposition. - rewrite stack_position_nlstack. - reflexivity. -Qed. - -Lemma nl_zipc : - forall t π, - nl (zipc t π) = zipc (nl t) (nlstack π). -Proof. - intros t π. - induction π in t |- *. - all: try solve [ simpl ; rewrite ?IHπ ; reflexivity ]. - all: try solve [ - simpl ; rewrite IHπ ; cbn ; f_equal ; - rewrite nl_mkApps ; reflexivity - ]. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite map_app. cbn. reflexivity. -Qed. - -Lemma nl_zipx : - forall Γ t π, - nl (zipx Γ t π) = zipx (nlctx Γ) (nl t) (nlstack π). -Proof. - intros Γ t π. - unfold zipx. rewrite nl_it_mkLambda_or_LetIn. f_equal. - apply nl_zipc. -Qed. - - Lemma global_ext_levels_nlg : forall Σ, global_ext_levels (nlg Σ) = global_ext_levels Σ. @@ -782,6 +818,15 @@ Proof. + assumption. Qed. +Lemma All_mapi_spec {A B} {P : A -> Type} {l} {f g : nat -> A -> B} {n} : + All P l -> (forall n x, P x -> f n x = g n x) -> + mapi_rec f l n = mapi_rec g l n. +Proof. + induction 1 in n |- *; simpl; trivial. + intros Heq. rewrite Heq; f_equal; auto. +Qed. +Hint Resolve All_mapi_spec : all. + Lemma nl_lift : forall n k t, nl (lift n k t) = lift n k (nl t). @@ -795,10 +840,20 @@ Proof. + simpl. f_equal. * eapply p. * eapply IHAll. - - f_equal. 1-2: solve [ auto ]. - induction X. 1: reflexivity. - simpl. f_equal. 2: assumption. - unfold on_snd. cbn. f_equal. auto. + - rewrite /map_predicate_k /= map_length. + f_equal; auto. + * unfold nl_predicate, map_predicate; simpl; f_equal; solve_all. + eapply All_mapi_spec; [tea|]. + intros i x []. rewrite /map_decl_anon /map_decl /shiftf /=. + f_equal; auto. rewrite !option_map_two. + destruct (decl_body x) => /= //. f_equal; auto. + * induction X0. 1: reflexivity. + simpl. f_equal. 2: assumption. + unfold nl_branch, map_branch_k. cbn. f_equal; auto; solve_all. + eapply All_mapi_spec; [tea|]. + intros i' x' []. rewrite /map_decl_anon /map_decl /shiftf /=. + f_equal; auto. rewrite !option_map_two. + destruct (decl_body x') => /= //. f_equal; auto. - f_equal. rewrite map_length. generalize (#|m| + k). intro l. induction X. @@ -845,6 +900,7 @@ Proof. reflexivity. Qed. +(* Lemma nlctx_stack_context : forall ρ, nlctx (stack_context ρ) = stack_context (nlstack ρ). @@ -861,7 +917,10 @@ Proof. rewrite map_app. simpl. rewrite 2!map_def_sig_nl. reflexivity. + - simpl. rewrite nlctx_app_context. now rewrite IHρ. + - simpl. rewrite nlctx_app_context. now rewrite IHρ. Qed. +*) Lemma nl_subst : forall s k u, @@ -880,10 +939,21 @@ Proof. + simpl. f_equal. * eapply p. * eapply IHAll. - - f_equal. 1-2: solve [ auto ]. - induction X. 1: reflexivity. - simpl. f_equal. 2: assumption. - unfold on_snd. cbn. f_equal. auto. + - f_equal; auto. + * unfold nl_predicate, map_predicate_k; simpl; f_equal; + rewrite ?map_map_compose ?map_length; solve_all. + eapply All_mapi_spec; eauto. + rewrite /ondecl /map_decl_anon /map_decl /=. intuition auto. + rewrite !option_map_two; f_equal; solve_all. + destruct (decl_body x) => /= //. f_equal; eauto. + * induction X0. 1: reflexivity. + simpl. f_equal. 2: assumption. + unfold nl_branch, map_branch_k. cbn. + rewrite map_length. f_equal; solve_all. + eapply All_mapi_spec; eauto. + rewrite /ondecl /map_decl_anon /map_decl /=. intuition auto. + rewrite !option_map_two; f_equal; solve_all. + destruct (decl_body x0) => /= //. f_equal; eauto. - f_equal. rewrite map_length. generalize (#|m| + k). intro l. induction X. @@ -905,41 +975,29 @@ Qed. Lemma nl_eq_decl {cf:checker_flags} : forall le Σ φ d d', eq_decl le Σ φ d d' -> - eq_decl le (map (on_snd nl_global_decl) Σ) φ (map_decl nl d) (map_decl nl d'). + eq_decl le (nl_global_env Σ) φ (map_decl nl d) (map_decl nl d'). Proof. - intros le Σ φ d d' [[hann h1] h2]. - split. - - simpl. destruct d as [? [?|] ?], d' as [? [?|] ?]. - all: cbn in *. - all: split; trivial. - apply nl_eq_term. assumption. - - apply nl_compare_term. assumption. + intros le Σ φ d d' []; constructor; destruct le; + intuition auto using nl_eq_term, nl_leq_term. Qed. Lemma nl_eq_decl' {cf:checker_flags} : forall le Σ φ d d', eq_decl le Σ φ d d' -> - eq_decl le (map (on_snd nl_global_decl) Σ) φ (map_decl_anon nl d) (map_decl_anon nl d'). + eq_decl le (nl_global_env Σ) φ (map_decl_anon nl d) (map_decl_anon nl d'). Proof. - intros le Σ φ d d' [[hann h1] h2]. - split. - - simpl. destruct d as [? [?|] ?], d' as [? [?|] ?]. - all: cbn in *. - all: split; trivial. - apply nl_eq_term. assumption. - - apply nl_compare_term. assumption. + intros le Σ φ d d' []; constructor; destruct le; + intuition auto using nl_eq_term, nl_leq_term. Qed. Lemma nl_eq_context {cf:checker_flags} : forall le Σ φ Γ Γ', eq_context le Σ φ Γ Γ' -> - eq_context le (map (on_snd nl_global_decl) Σ) φ (nlctx Γ) (nlctx Γ'). + eq_context le (nl_global_env Σ) φ (nlctx Γ) (nlctx Γ'). Proof. intros le Σ φ Γ Γ' h. unfold eq_context, nlctx. - eapply All2_map, All2_impl. - - eassumption. - - apply nl_eq_decl'. + destruct le; now eapply eq_context_nl. Qed. Lemma nl_decompose_app : @@ -955,6 +1013,19 @@ Proof. apply IHt1. Qed. +Lemma nl_pred_set_pcontext p pcontext : + nl_predicate nl (set_pcontext p pcontext) = + set_pcontext (nl_predicate nl p) (nlctx pcontext). +Proof. reflexivity. Qed. + +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) = + set_pparams (nl_predicate nl p) (map nl pret). +Proof. reflexivity. Qed. + Lemma nl_fix_context : forall mfix, nlctx (fix_context mfix) = fix_context (map (map_def_anon nl nl) mfix). @@ -969,25 +1040,365 @@ Proof. + unfold map_decl_anon. cbn. rewrite nl_lift. reflexivity. Qed. +From MetaCoq.PCUIC Require Import PCUICCases. + +Lemma nl_declared_inductive Σ ind mdecl idecl : + declared_inductive Σ ind mdecl idecl -> + declared_inductive (nl_global_env Σ) ind + (nl_mutual_inductive_body mdecl) (nl_one_inductive_body idecl). +Proof. + intros []. split. + - unfold declared_minductive. + rewrite nl_lookup_env H. + simpl. reflexivity. + - simpl. now rewrite nth_error_map H0. +Qed. + +Lemma nl_declared_constructor Σ c mdecl idecl cdecl : + declared_constructor Σ c mdecl idecl cdecl -> + declared_constructor (nl_global_env Σ) c + (nl_mutual_inductive_body mdecl) (nl_one_inductive_body idecl) + (nl_constructor_body cdecl). +Proof. + intros []. split. + - now eapply nl_declared_inductive. + - simpl. now rewrite nth_error_map H0. +Qed. +From MetaCoq.PCUIC Require Import PCUICUnivSubstitution. + +Lemma nl_to_extended_list: + forall indctx : list context_decl, + map nl (to_extended_list indctx) = to_extended_list (nlctx indctx). +Proof. + intros indctx. unfold to_extended_list, to_extended_list_k. + change [] with (map nl []) at 2. + unf_term. generalize (@nil term), 0. + induction indctx. + - reflexivity. + - simpl. intros l n. + destruct a as [? [?|] ?]. + all: cbn. + all: apply IHindctx. +Qed. + +Lemma nlctx_subst_instance : + forall u Γ, + nlctx (subst_instance u Γ) = subst_instance u (nlctx Γ). +Proof. + intros u Γ. + rewrite /subst_instance /=. + induction Γ as [| [na [b|] B] Δ ih] in Γ |- *; rewrite /= ?subst_context_snoc /snoc /= + /map_decl. + - reflexivity. + - f_equal; auto. + rewrite /subst_decl /map_decl /= /map_decl_anon /=; repeat f_equal; + now rewrite nl_subst_instance. + - f_equal; [|apply ih]. + rewrite /subst_decl /map_decl /= /map_decl_anon /=; repeat f_equal; + now rewrite nl_subst_instance. +Qed. + +Lemma nlctx_subst_context : + forall s k Γ, + nlctx (subst_context s k Γ) = subst_context (map nl s) k (nlctx Γ). +Proof. + intros s k Γ. + induction Γ as [| [na [b|] B] Δ ih] in Γ |- *; rewrite /= ?subst_context_snoc /snoc /= + /map_decl. + - reflexivity. + - 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. + - simpl. f_equal; [|apply ih]. + rewrite /subst_decl /map_decl /= /map_decl_anon /=; repeat f_equal. + now rewrite nl_subst; len. +Qed. + + +Lemma nlctx_lift_context : + forall n k Γ, + nlctx (lift_context n k Γ) = lift_context n k (nlctx Γ). +Proof. + intros s k Γ. + induction Γ as [| [na [b|] B] Δ ih] in Γ |- *; rewrite /= ?lift_context_snoc /snoc /= + /map_decl. + - reflexivity. + - 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. + - simpl. f_equal; [|apply ih]. + rewrite /subst_decl /map_decl /= /map_decl_anon /=; repeat f_equal. + now rewrite nl_lift; len. +Qed. + +Lemma nl_it_mkProd_or_LetIn : + forall Γ A, + nl (it_mkProd_or_LetIn Γ A) = it_mkProd_or_LetIn (nlctx Γ) (nl A). +Proof. + intros Γ A. + induction Γ in A |- *. + - reflexivity. + - simpl. rewrite IHΓ. f_equal. + destruct a as [? [?|] ?]. + all: reflexivity. +Qed. + +Lemma nl_extended_subst Γ k : + map nl (extended_subst Γ k) = extended_subst (nlctx Γ) k. +Proof. + revert k; induction Γ as [|[? [] ?] ?]; intros k; simpl; f_equal; auto; + rewrite ?nl_subst ?nl_lift ?nl_context_assumptions ?IHΓ; len => //. +Qed. + +Hint Rewrite nl_context_assumptions : len. + +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. +Qed. + +Lemma nl_expand_lets Γ t : + nl (expand_lets Γ t) = + expand_lets (nlctx Γ) (nl t). +Proof. + now rewrite /expand_lets nl_expand_lets_k. +Qed. + +Lemma subst_instance_nlctx u ctx : + subst_instance u (nlctx ctx) = nlctx (subst_instance u ctx). +Proof. + induction ctx; cbnr. + f_equal. 2: apply IHctx. + clear. destruct a as [? [] ?]; unfold map_decl, map_decl_anon; cbn; f_equal. + all: now rewrite nl_subst_instance. +Qed. + +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) = + fold_context_k g' (map (map_decl_anon nl) ctx). +Proof. + intros hg. + rewrite !fold_context_k_alt map_mapi mapi_map. + apply mapi_ext => i d. + rewrite /map_decl /map_decl_anon. len. + f_equal. + - destruct (decl_body d) => /= //. + f_equal. apply hg. + - apply hg. +Qed. + +Lemma nl_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. + intros i x. now rewrite nl_subst. +Qed. + +Lemma nl_subst_telescope s k ctx : + nlctx (subst_telescope s k ctx) = + subst_telescope (map nl s) k (nlctx ctx). +Proof. + rewrite /nlctx /subst_telescope. + rewrite map_mapi mapi_map. apply mapi_ext => i d. + rewrite /map_decl_anon /map_decl; destruct d as [na [b|] ty]; cbn; f_equal; + now rewrite nl_subst. +Qed. + +Lemma nl_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. + intros i x. now rewrite nl_lift. +Qed. + +Lemma nl_expand_lets_ctx Γ Δ : + nlctx (expand_lets_ctx Γ Δ) = + expand_lets_ctx (nlctx Γ) (nlctx Δ). +Proof. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + now rewrite nl_subst_context nl_extended_subst nl_lift_context; len. +Qed. + +Lemma nl_inds ind puinst bodies : + map nl (inds ind puinst bodies) = + inds ind puinst (map nl_one_inductive_body bodies). +Proof. + rewrite /inds; len. + induction #|bodies|; simpl; f_equal; auto. +Qed. + + +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' : + 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. + apply IHl. +Qed. + +Lemma nlctx_length Γ : #|nlctx Γ| = #|Γ|. +Proof. now rewrite map_length. Qed. +Hint Rewrite nlctx_length : len. + +Lemma map2_map_left {A B C D} (f : A -> B) (g : B -> C -> D) (l : list A) (l' : list C) : + map2 g (map f l) l' = map2 (fun x y => g (f x) y) l l'. +Proof. + induction l in l' |- *; destruct l'; simpl; auto. f_equal; eauto. +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) -> + map2 f l l' = map2 g l l'. +Proof. + intros H. + induction l in l' |- *; destruct l'; simpl; auto. f_equal; eauto. +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) + (nl_predicate nl p). +Proof. + unfold case_predicate_context, case_predicate_context_gen. + simpl. + rewrite /nlctx /=. + simpl. rewrite /forget_types map_map_compose. + rewrite /pre_case_predicate_context_gen. + destruct (pcontext p); simpl; auto. + f_equal. + - rewrite /map_decl_anon /= /set_binder_name /=; f_equal. + rewrite nl_mkApps /=; f_equal; rewrite map_app map_map_compose. + rewrite nl_to_extended_list. f_equal. + rewrite map_map_compose. apply map_ext => t. + now rewrite nl_lift; len. + - rewrite -map_rev. + rewrite -nl_expand_lets_ctx -nlctx_subst_instance -nlctx_subst_context. + rewrite map_map2 map2_map. + rewrite map2_map_left. + apply map2_ext. intros [] []; reflexivity. +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_constructor_body cdecl). +Proof. + unfold case_branch_context, case_branch_context_gen. simpl. + rewrite nlctx_subst_context map_rev. f_equal. + rewrite nl_expand_lets_ctx nlctx_subst_instance. + f_equal. + rewrite nl_subst_context nl_inds nlctx_subst_instance; len. + f_equal. f_equal. + now rewrite /nlctx map_map2 map2_map. +Qed. + +Lemma nl_case_branch_type ci mdecl idecl p br i cdecl : + let ptm := it_mkLambda_or_LetIn (pcontext p) (preturn p) in + case_branch_type ci (nl_mutual_inductive_body mdecl) + (nl_one_inductive_body idecl) (nl_predicate nl p) + (nl_branch nl br) + (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. + unfold case_branch_type, case_branch_type_gen. + simpl. unfold map_pair. simpl. f_equal. + - rewrite nl_case_branch_context. + now rewrite /forget_types !map_map_compose. + - rewrite nl_mkApps nl_lift; len. f_equal. + rewrite !map_map_compose map_app /= !map_map_compose nl_mkApps. + f_equal. + * apply map_ext => idx. rewrite nl_subst nl_expand_lets_k map_rev. + now rewrite nlctx_subst_instance nl_subst nl_inds nl_subst_instance. + * f_equal. + simpl. f_equal. + rewrite map_app !map_map_compose. + setoid_rewrite nl_lift. + now rewrite nl_to_extended_list. +Qed. + +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 : + wf_predicate mdecl idecl p -> + wf_predicate (nl_mutual_inductive_body mdecl) (nl_one_inductive_body idecl) (nl_predicate nl p). +Proof. + intros []; split. + { len => //. } + depelim H0. + simpl. rewrite nl_forget_types H2 /=. constructor; auto. + eapply Forall2_map. solve_all. +Qed. + +Lemma nl_wf_branch cdecl br : + wf_branch cdecl br -> + wf_branch (nl_constructor_body cdecl) (nl_branch nl br). +Proof. + unfold wf_branch, wf_branch_gen. + simpl. + rewrite nl_forget_types /=. + intros H; apply Forall2_map; solve_all. +Qed. + +Lemma nl_wf_branches idecl brs : + wf_branches idecl 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. + eapply (Forall2_impl H). + apply nl_wf_branch. +Qed. + Lemma nl_red1 : forall Σ Γ M N, red1 Σ Γ M N -> - red1 (map (on_snd nl_global_decl) Σ) (nlctx Γ) (nl M) (nl N). + red1 (nl_global_env Σ) (nlctx Γ) (nl M) (nl N). Proof. intros Σ Γ M N h. induction h using red1_ind_all. all: simpl. - all: rewrite ?nl_lift ?nl_subst ?nl_subst_instance_constr. + all: rewrite ?nl_lift ?nl_subst ?nl_subst_instance. all: try solve [ econstructor ; eauto ]. - constructor. unfold nlctx. rewrite nth_error_map. destruct (nth_error Γ i). 2: discriminate. cbn in *. apply some_inj in H. rewrite H. reflexivity. - rewrite nl_mkApps. cbn. - replace (nl (iota_red pars c args brs)) - with (iota_red pars c (map nl args) (map (on_snd nl) brs)). - + eapply red_iota. - + unfold iota_red. rewrite nl_mkApps. - rewrite map_skipn. rewrite nth_map. all: reflexivity. + rewrite map_rev map_skipn nl_extended_subst nl_lift. + rewrite -(nl_context_assumptions (bcontext br)). + change (nl (bbody br)) with (bbody (nl_branch nl br)). + rewrite -(nlctx_length (bcontext br)). + change (subst0 (extended_subst (nlctx br.(bcontext)) 0) + (lift (context_assumptions (nlctx br.(bcontext))) #| + nlctx br.(bcontext)| (bbody (nl_branch nl br)))) with + (expand_lets (nlctx br.(bcontext)) (bbody (nl_branch nl br))). + epose proof (nth_error_map (nl_branch nl) c brs). + change (nlctx (bcontext br)) with (bcontext (nl_branch nl br)). + eapply red_iota => //. + * rewrite H1 H //. + * now rewrite !List.skipn_length in H0 |- *; len. - rewrite !nl_mkApps. cbn. eapply red_fix with (narg:=narg). + unfold unfold_fix in *. rewrite nth_error_map. destruct (nth_error mfix idx). 2: discriminate. @@ -1035,13 +1446,34 @@ Proof. * discriminate. - rewrite nl_mkApps. cbn. constructor. rewrite nth_error_map H. reflexivity. + - rewrite nl_pred_set_pparams. + econstructor; tea. + eapply OnOne2_map, OnOne2_impl. 1: eassumption. + solve_all. + - rewrite nl_pred_set_pcontext. econstructor. + simpl. eapply OnOne2_local_env_map, OnOne2_local_env_impl; tea. + unfold on_Trel; intros ? ?; intuition eauto. + eapply on_one_decl_map_na. + eapply on_one_decl_impl; tea. + intros Γ' x' y'. now rewrite nlctx_app_context. + - rewrite nl_pred_set_preturn. econstructor. + rewrite -nlctx_app_context. apply IHh. + - econstructor; tea. + simpl. + eapply OnOne2_map, OnOne2_impl. 1: eassumption. + cbn. intros x y [[? ?]|]; cbn; solve_all. + * red; simpl; left. solve_all. + rewrite e. now rewrite -nlctx_app_context. + * right. simpl. rewrite -b; intuition auto. + eapply OnOne2_local_env_map, OnOne2_local_env_impl; tea. + unfold on_Trel; intros ? ?; intuition eauto. + eapply on_one_decl_map_na. + eapply on_one_decl_impl; tea. + intros Γ' x' y'. now rewrite nlctx_app_context. - constructor. eapply OnOne2_map, OnOne2_impl. 1: eassumption. - cbn. intros x y [[? ?] ?]. split. all: assumption. - - constructor. eapply OnOne2_map, OnOne2_impl. 1: eassumption. - cbn. intros x y [? ?]. all: assumption. - - constructor. eapply OnOne2_map, OnOne2_impl. 1: eassumption. - cbn. intros x y [[? ?] ?]. split. 1: assumption. - cbn. congruence. + cbn. intros x y [? ?]; auto. + - constructor. apply OnOne2_map. eapply OnOne2_impl; [eassumption|]. + cbn. intros x y [? ?]; auto. red; simpl; intuition auto. congruence. - apply fix_red_body. eapply OnOne2_map, OnOne2_impl. 1: eassumption. cbn. intros x y [[? ?] ?]. split. + rewrite nlctx_app_context nl_fix_context in r0. assumption. @@ -1055,6 +1487,22 @@ Proof. + cbn. congruence. Qed. +Lemma nl_conv {cf:checker_flags} : + forall Σ Γ A B, + Σ ;;; Γ |- A = B -> + nlg Σ ;;; nlctx Γ |- nl A = nl B. +Proof. + intros Σ Γ A B h. + induction h. + - constructor. rewrite global_ext_constraints_nlg. + unfold nlg. destruct Σ. apply nl_eq_term. + assumption. + - eapply conv_red_l. 2: eassumption. + destruct Σ. apply nl_red1. assumption. + - eapply conv_red_r. 1: eassumption. + destruct Σ. apply nl_red1. assumption. +Qed. + Lemma nl_cumul {cf:checker_flags} : forall Σ Γ A B, Σ ;;; Γ |- A <= B -> @@ -1071,6 +1519,44 @@ Proof. destruct Σ. apply nl_red1. assumption. Qed. +Notation nldecl := (map_decl_anon nl). + +Lemma nl_conv_decls {cf} {Σ Γ Γ'} {d d'} : + conv_decls Σ Γ Γ' d d' -> + conv_decls (nlg Σ) (nlctx Γ) (nlctx Γ') (nldecl d) (nldecl d'). +Proof. + intros Hd; depelim Hd; constructor; tas; + eapply nl_conv; tea. +Qed. + +Lemma nl_cumul_decls {cf} {Σ Γ Γ' d d'} : + cumul_decls Σ Γ Γ' d d' -> + cumul_decls (nlg Σ) (nlctx Γ) (nlctx Γ') (nldecl d) (nldecl d'). +Proof. + intros Hd; depelim Hd; constructor; tas; + (eapply nl_conv || eapply nl_cumul); tea. +Qed. + +Lemma nl_conv_ctx {cf} {Σ Γ Δ} : + conv_context Σ Γ Δ -> + conv_context (nlg Σ) (nlctx Γ) (nlctx Δ). +Proof. + intros. + induction X; simpl; constructor; eauto; simpl; now eapply nl_conv_decls in p. +Qed. +Hint Resolve @nl_conv_ctx : nl. + +Lemma nl_cumul_ctx {cf} {Σ Γ Δ} : + cumul_context Σ Γ Δ -> + cumul_context (nlg Σ) (nlctx Γ) (nlctx Δ). +Proof. + intros. + induction X; simpl; constructor; eauto; simpl; now + (eapply nl_conv_decls in p || eapply nl_cumul_decls in p). +Qed. +Hint Resolve @nl_cumul_ctx : nl. + +(* Lemma nl_instantiate_params : forall params args ty, option_map nl (instantiate_params params args ty) = @@ -1105,49 +1591,20 @@ Proof. - simpl. f_equal. apply nl_subst. - reflexivity. Qed. +*) -Lemma nl_inds : - forall kn u bodies, - map nl (inds kn u bodies) = inds kn u (map nl_one_inductive_body bodies). -Proof. - intros kn u bodies. - unfold inds. rewrite map_length. - induction #|bodies|. - - reflexivity. - - simpl. rewrite IHn. reflexivity. -Qed. - -Lemma nl_it_mkProd_or_LetIn : - forall Γ A, - nl (it_mkProd_or_LetIn Γ A) = it_mkProd_or_LetIn (nlctx Γ) (nl A). -Proof. - intros Γ A. - induction Γ in A |- *. - - reflexivity. - - simpl. rewrite IHΓ. f_equal. - destruct a as [? [?|] ?]. - all: reflexivity. -Qed. - -Lemma nl_to_extended_list: - forall indctx : list context_decl, - map nl (to_extended_list indctx) = to_extended_list (nlctx indctx). +Lemma nl_check_one_fix d : check_one_fix d = check_one_fix (map_def_anon nl nl d). Proof. - intros indctx. unfold to_extended_list, to_extended_list_k. - change [] with (map nl []) at 2. - unf_term. generalize (@nil term), 0. - induction indctx. - - reflexivity. - - simpl. intros l n. - destruct a as [? [?|] ?]. - all: cbn. - all: apply IHindctx. -Qed. + destruct d; simpl. + rewrite (nl_decompose_prod_assum [] dtype). + destruct decompose_prod_assum. +Admitted. Lemma nl_wf_fixpoint Σ mfix : wf_fixpoint Σ.1 mfix = wf_fixpoint (nlg Σ).1 (map (map_def_anon nl nl) mfix). Proof. unfold wf_fixpoint. + destruct (map check_one_fix mfix) eqn:hmap. Admitted. Lemma nl_wf_cofixpoint Σ mfix : @@ -1156,15 +1613,6 @@ Proof. unfold wf_fixpoint. Admitted. -Lemma subst_instance_context_nlctx u ctx : - subst_instance_context u (nlctx ctx) = nlctx (subst_instance_context u ctx). -Proof. - induction ctx; cbnr. - f_equal. 2: apply IHctx. - clear. destruct a as [? [] ?]; unfold map_decl, map_decl_anon; cbn; f_equal. - all: now rewrite nl_subst_instance_constr. -Qed. - Lemma nl_monomorphic_levels_decl g : monomorphic_levels_decl (nl_global_decl g) = monomorphic_levels_decl g. Proof. destruct g; simpl. @@ -1172,7 +1620,7 @@ Proof. - destruct m; reflexivity. Qed. -Lemma nl_global_levels Σ : global_levels (map (on_snd nl_global_decl) Σ) = global_levels Σ. +Lemma nl_global_levels Σ : global_levels (nl_global_env Σ) = global_levels Σ. Proof. induction Σ; simpl; auto. destruct a; simpl. now rewrite IHΣ nl_monomorphic_levels_decl. @@ -1193,13 +1641,34 @@ Proof. now rewrite nl_global_ext_levels. Qed. +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. + split. + - induction 1; constructor; auto. + - induction l in n, l' |- *; destruct l'; intros H; depelim H; constructor; auto. +Qed. + +Lemma nl_is_allowed_elimination {cf:checker_flags} (Σ : global_env_ext) ps kelim : + is_allowed_elimination Σ ps kelim -> + is_allowed_elimination (nlg Σ) ps kelim. +Proof. + now rewrite global_ext_constraints_nlg. +Qed. + +Axiom nl_fix_guard : forall Σ Γ mfix, + fix_guard Σ Γ mfix -> fix_guard (nlg Σ) (nlctx Γ) (map (map_def_anon nl nl) mfix). +Axiom nl_cofix_guard : forall Σ Γ mfix, + cofix_guard Σ Γ mfix -> cofix_guard (nlg Σ) (nlctx Γ) (map (map_def_anon nl nl) mfix). + Lemma typing_nlg {cf : checker_flags} : env_prop (fun Σ Γ t T => nlg Σ ;;; nlctx Γ |- nl t : nl T) - (fun Σ Γ _ => wf_local (nlg Σ) (nlctx Γ)). + (fun Σ Γ => wf_local (nlg Σ) (nlctx Γ)). Proof. clear. - apply typing_ind_env; cbn; intros; - rewrite ?nl_lift ?nl_subst ?nl_subst_instance_constr; + apply typing_ind_env; intros; cbn in *; + rewrite ?nl_lift ?nl_subst ?nl_subst_instance; try (econstructor; eauto using nlg_wf_local; fail). - induction X; simpl; constructor; auto. * now exists (tu.π1). @@ -1226,12 +1695,12 @@ Proof. rewrite nth_error_map H2. reflexivity. + unfold consistent_instance_ext. rewrite global_ext_levels_nlg global_ext_constraints_nlg; assumption. - - destruct cdecl as [[id t] n]. cbn. + - cbn. rewrite nl_inds. eapply type_Construct with (idecl0:=nl_one_inductive_body idecl) (mdecl0:=nl_mutual_inductive_body mdecl) - (cdecl:=(id, nl t, n)) - ; eauto using nlg_wf_local. + (cdecl0:=nl_constructor_body cdecl); + eauto using nlg_wf_local. + destruct isdecl as [[H1 H2] H3]. repeat split. * eapply lookup_env_nlg in H1. eapply H1. * replace (ind_bodies (nl_mutual_inductive_body mdecl)) with @@ -1240,86 +1709,56 @@ Proof. * rewrite nth_error_map H3. reflexivity. + unfold consistent_instance_ext. rewrite global_ext_levels_nlg global_ext_constraints_nlg; assumption. - - rewrite nl_mkApps map_app map_skipn. cbn. + - rewrite nl_mkApps map_app nl_it_mkLambda_or_LetIn. cbn. eapply type_Case with (mdecl0:=nl_mutual_inductive_body mdecl) (idecl0:=nl_one_inductive_body idecl) - (btys0:=map (on_snd nl) btys) - (u0:=u) - ; tea. + (p0:=nl_predicate nl p); tea. + destruct isdecl as [HH1 HH2]. split. * eapply lookup_env_nlg in HH1. eapply HH1. * replace (ind_bodies (nl_mutual_inductive_body mdecl)) with (map nl_one_inductive_body (ind_bodies mdecl)); [|now destruct mdecl]. rewrite nth_error_map HH2. reflexivity. - + exact (todo "build_case_predicate_type Nameless"). - (* + clear -H0. unfold types_of_case in *. *) - (* set (params := instantiate_params *) - (* (subst_instance_context u (ind_params mdecl)) *) - (* (firstn npar args) *) - (* (subst_instance_constr u (ind_type idecl))) in H0. *) - (* replace (instantiate_params _ _ _) with (option_map nl params). *) - (* * destruct params; [|discriminate]. simpl. *) - (* case_eq (destArity [] t); *) - (* [|intro HH; rewrite HH in H0; discriminate]. *) - (* intros [Δ s] H. rewrite H in H0. *) - (* apply nl_destArity in H. cbn in H; rewrite H; clear H. *) - (* case_eq (destArity [] pty); *) - (* [|intro HH; rewrite HH in H0; discriminate]. *) - (* intros [Δ' s'] H. rewrite H in H0. *) - (* apply nl_destArity in H. cbn in H; rewrite H; clear H. *) - (* case_eq (map_option_out (build_branches_type ind mdecl idecl *) - (* (firstn npar args) u p)); *) - (* [|intro HH; rewrite HH in H0; discriminate]. *) - (* intros tys H; rewrite H in H0. *) - (* inversion H0; subst; clear H0. *) - (* replace (map_option_out (build_branches_type ind (nl_mutual_inductive_body mdecl) (nl_one_inductive_body idecl) (firstn npar (map nl args)) u (nl p))) *) - (* with (option_map (map (on_snd nl)) (map_option_out (build_branches_type ind mdecl idecl (firstn npar args) u p))). *) - (* now rewrite H. *) - (* rewrite <- map_option_out_map_option_map. f_equal. *) - (* rewrite firstn_map. generalize (firstn npar args); intro args'. clear. *) - (* unfold build_branches_type. simpl. *) - (* rewrite mapi_map, map_mapi. apply mapi_ext. *) - (* intros n [[id t] k]. *) - (* rewrite <- nl_subst_instance_constr, <- nl_inds, <- nl_subst. *) - (* rewrite subst_instance_context_nlctx. *) - (* rewrite <- nl_instantiate_params. *) - (* destruct (instantiate_params _ _ _); [|reflexivity]. *) - (* cbn. change (nil context_decl) with (nlctx []) at 2. *) - (* rewrite nl_decompose_prod_assum. *) - (* destruct (decompose_prod_assum [] t0); cbn. *) - (* rewrite nl_decompose_app. *) - (* destruct (decompose_app t1) as [t11 t12]; cbn. *) - (* case_eq (chop (ind_npars mdecl) t12). *) - (* intros paramrels args eq. *) - (* erewrite chop_map; tea. cbn. *) - (* unfold on_snd. cbn. f_equal. f_equal. *) - (* rewrite nl_it_mkProd_or_LetIn, nl_mkApps, nl_lift. *) - (* unfold nlctx at 3; rewrite map_length. f_equal. f_equal. *) - (* rewrite map_app. cbn. rewrite nl_mkApps. cbn. repeat f_equal. *) - (* rewrite map_app. f_equal. apply nl_to_extended_list. *) - (* * rewrite firstn_map. cbn. subst params. *) - (* rewrite nl_instantiate_params. f_equal. *) - (* now rewrite <- subst_instance_context_nlctx. *) - (* apply nl_subst_instance_constr. *) - (* + clear -H1. unfold check_correct_arity in *. *) - (* rewrite global_ext_constraints_nlg. *) - (* inversion H1; subst. cbn. constructor. *) - (* * clear -H2. destruct H2 as [H1 H2]; cbn in *. *) - (* destruct y as [? [?|] ?]; cbn in *; [contradiction|]. *) - (* split; cbn; tas. apply nl_eq_term in H2. *) - (* refine (eq_rect _ (fun d => eq_term _ d _) H2 _ _). *) - (* clear. rewrite nl_mkApps, map_app, firstn_map, !map_map. *) - (* f_equal. rewrite nl_to_extended_list. f_equal. *) - (* apply map_ext. intro; rewrite nl_lift; cbn. *) - (* unfold nlctx; now rewrite map_length. *) - (* * eapply All2_map, All2_impl; tea. *) - (* apply nl_eq_decl'. *) - + rewrite global_ext_constraints_nlg. exact H1. - + rewrite -> nl_mkApps in *; eassumption. - + exact (todo "build_branches_type Nameless"). - + clear -X5. eapply All2_map, All2_impl; tea. cbn. - clear. intros x y [[[? ?] ?] ?]. intuition eauto. - destruct s as [s [Hs IH]] ; exists s; eauto. + + destruct H0 as [wfpars wfpctx]. + split; simpl; rewrite ?map_length //. + clear -wfpctx. depelim wfpctx. + rewrite nl_forget_types H0 /=. + simpl. constructor => //. + eapply Forall2_map; solve_all. + + simpl. tas. + unfold consistent_instance_ext. + rewrite global_ext_levels_nlg global_ext_constraints_nlg; assumption. + + now rewrite -nlctx_app_context. + + simpl. + rewrite -nl_case_predicate_context. + rewrite - !nlctx_app_context. + eapply nl_conv_ctx; tea. + + rewrite - !nlctx_app_context; exact X3. + + rewrite -nl_case_predicate_context -nlctx_app_context. exact X4. + + now apply nl_is_allowed_elimination. + + revert X6. simpl. + rewrite -map_app -nlctx_app_context. + rewrite -nlctx_subst_instance. + rewrite -[List.rev (nlctx _)]map_rev. + clear. induction 1; simpl; constructor; eauto. + * now rewrite -(nl_subst_telescope [i] 0 Δ). + * now rewrite -(nl_subst_telescope [b] 0 Δ). + + now rewrite nl_mkApps map_app in X8. + + now eapply nl_wf_branches. + + eapply All2i_map, (All2i_impl X9). + intros i cdecl br. + set (cbt := case_branch_type _ _ _ _ _ _ _ _) in *. + intros ((wfctx & convctx) & (bbodyty & wfbctx) & IHbody & bty & IHbty). + simpl preturn. rewrite -nl_it_mkLambda_or_LetIn. + cbn -[case_branch_type]. + rewrite nl_case_branch_type. + rewrite -/cbt. unfold map_pair. cbn. + repeat split. + * cbn. now rewrite -[_ ++ _]nlctx_app_context. + * now rewrite - ![_ ++ _]nlctx_app_context. + * rewrite - ![_ ++ _]nlctx_app_context. + now eapply nl_conv_ctx. + * now rewrite nlctx_app_context in IHbody. + * now rewrite nlctx_app_context in IHbty. - destruct pdecl as [pdecl1 pdecl2]; simpl. rewrite map_rev. eapply type_Proj with (mdecl0:=nl_mutual_inductive_body mdecl) @@ -1340,13 +1779,9 @@ Proof. = nlctx (Γ ,,, fix_context mfix)) by now rewrite <- nl_fix_context, <- nlctx_app_context. constructor. - + todo "fix_guard spec". - (*eapply fix_guard_eq_term with (idx:=n). 1: eassumption. - constructor. clear. induction mfix. 1: constructor. - simpl. constructor; tas. cbn. - repeat split; now apply eq_term_upto_univ_tm_nl.*) + + now eapply nl_fix_guard. + now rewrite nth_error_map H0. - + auto. + + rewrite nlctx_app_context in X. now eapply wf_local_app_inv in X. + clear -X0. apply All_map. eapply All_impl; tea. simpl. intros x [s Hs]. now exists s. @@ -1363,12 +1798,9 @@ Proof. = nlctx (Γ ,,, fix_context mfix)) by now rewrite <- nl_fix_context, <- nlctx_app_context. constructor; auto. - + todo "cofix_guard eq_term". - (* eapply cofix_guard_eq_term with (idx:=n). 1: eassumption. - constructor. clear. induction mfix. 1: constructor. - simpl. constructor; tas. cbn. - repeat split; now apply eq_term_upto_univ_tm_nl.*) + + now apply nl_cofix_guard. + now rewrite nth_error_map H0. + + now rewrite nlctx_app_context in X; apply wf_local_app_inv in X. + clear -X0. apply All_map. eapply All_impl; tea. simpl. intros x [s Hs]. now exists s. @@ -1432,8 +1864,16 @@ Proof. induction M using term_forall_list_ind; cbnr. all: rewrite ?IHM1 ?IHM2 ?IHM3 ?IHM; cbnr. - f_equal. induction X; cbnr. congruence. - - f_equal. induction X; cbnr. f_equal; tas. - destruct x; unfold on_snd; simpl in *. congruence. + - destruct X; cbnr. + f_equal; solve_all. + * unfold nl_predicate; cbn; f_equal; solve_all. + unfold ondecl in *; solve_all. + unfold nldecl; destruct x as [na [bod|] ty]; simpl in *; f_equal; auto. + f_equal; eauto. + * unfold nl_branch; destruct x; cbn. f_equal; auto. + unfold ondecl in *; solve_all. + unfold nldecl; destruct x as [na [bod|] ty]; simpl; f_equal; auto. + f_equal; eauto. - f_equal. induction X; cbnr. f_equal; tas. destruct p, x; unfold map_def_anon; simpl in *. rewrite anonymize_two; congruence. @@ -1447,7 +1887,7 @@ Local Ltac aa := match goal with | |- ∑ _ : _, _ × ?t = _ => exists t end; split; [|symmetry; apply nl_two]; simpl; - rewrite ?nl_lift ?nl_subst ?nl_subst_instance_constr. + rewrite ?nl_lift ?nl_subst ?nl_subst_instance. Local Ltac bb := repeat match goal with @@ -1459,267 +1899,3 @@ Local Ltac bb' := bb; [econstructor|]; tea; cbn. Arguments on_snd {_ _ _} _ _/. Arguments map_def_anon {_ _} _ _ _/. - -(* -Lemma nl_red1' Σ Γ M N : - red1 Σ Γ M N -> - ∑ N', red1 Σ (nlctx Γ) (nl M) N' × nl N = nl N'. -Proof. - assert (maptwo : forall brs, map (on_snd (A:=nat) nl) (map (on_snd nl) brs) - = map (on_snd nl) brs). { - intro. rewrite map_map. - apply map_ext. intros; simpl; now rewrite nl_two. } - intros h. - induction h using red1_ind_all. - all: try solve [ bb'; pose proof nl_two; congruence ]. - all: try solve [ aa; econstructor; eauto ]. - - - aa. constructor. unfold nlctx. rewrite nth_error_map. - destruct (nth_error Γ i). 2: discriminate. - cbn in *. apply some_inj in H. rewrite H. reflexivity. - - aa. rewrite nl_mkApps. cbn. - replace (nl (iota_red pars c args brs)) - with (iota_red pars c (map nl args) (map (on_snd nl) brs)). - + eapply red_iota. - + unfold iota_red. rewrite nl_mkApps. - rewrite map_skipn. rewrite nth_map. all: reflexivity. - - aa. rewrite !nl_mkApps. cbn. eapply red_fix with (narg:=narg). - + unfold unfold_fix in *. rewrite nth_error_map. - destruct (nth_error mfix idx). 2: discriminate. - cbn. - replace (isLambda (nl (dbody d))) with (isLambda (dbody d)) - by (destruct (dbody d) ; reflexivity). - destruct (isLambda (dbody d)). 2: discriminate. - inversion H. subst. rewrite nl_subst. - repeat f_equal. clear. - unfold fix_subst. rewrite map_length. - induction #|mfix|. - * reflexivity. - * cbn. rewrite IHn. reflexivity. - + unfold is_constructor in *. - rewrite nth_error_map. destruct (nth_error args narg) ; [| discriminate ]. - cbn. unfold isConstruct_app in *. rewrite nl_decompose_app. - destruct (decompose_app t) as [u ?]. - destruct u. all: try discriminate. - reflexivity. - - aa. rewrite !nl_mkApps. simpl. eapply red_cofix_case with (narg := narg). - unfold unfold_cofix in *. rewrite nth_error_map. - destruct (nth_error mfix idx). 2: discriminate. - cbn. - inversion H. subst. rewrite nl_subst. - repeat f_equal. clear. - unfold cofix_subst. rewrite map_length. - induction #|mfix|. - * reflexivity. - * cbn. rewrite IHn. reflexivity. - - aa. rewrite !nl_mkApps. simpl. eapply red_cofix_proj with (narg := narg). - unfold unfold_cofix in *. rewrite nth_error_map. - destruct (nth_error mfix idx). 2: discriminate. - cbn. - inversion H. subst. rewrite nl_subst. - repeat f_equal. clear. - unfold cofix_subst. rewrite map_length. - induction #|mfix|. - * reflexivity. - * cbn. rewrite IHn. reflexivity. - - aa. rewrite nl_mkApps. constructor. - rewrite nth_error_map, H. reflexivity. - - assert (Y : ∑ brs'', map (on_snd nl) brs' = map (on_snd nl) brs'' - × OnOne2 (on_Trel_eq (red1 Σ (nlctx Γ)) snd fst) (map (on_snd nl) brs) brs''). - { - induction X. - + destruct p0 as [[? [hd'' [? ?]]] ?]. - eexists ((hd'.1, hd'') :: map (on_snd nl) tl); cbn; split. - 1: congruence. - constructor; cbn. split; tas. - + destruct IHX as [brs'' [? ?]]. exists ((hd.1, nl hd.2) :: brs''); cbn; split. - * rewrite nl_two. congruence. - * now constructor. - } - destruct Y as [brs'' [? ?]]. - exists (tCase ind (nl p) (nl c) brs''); cbn; split; [|rewrite !nl_two; congruence]. - now constructor. - - assert (Y : ∑ l'', map nl l' = map nl l'' - × OnOne2 (red1 Σ (nlctx Γ)) (map nl l) l''). - { - induction X. - + destruct p as [? [hd'' [? ?]]]. - eexists (hd'' :: map nl tl); cbn; split. - * f_equal; tas. - rewrite map_map; apply map_ext; intro; now rewrite nl_two. - * now constructor. - + destruct IHX as [l'' [? ?]]. exists (nl hd :: l''); cbn; split. - * rewrite nl_two. congruence. - * now constructor. - } - destruct Y as [l'' [? ?]]. - exists (tEvar ev l''); cbn; split. 1: now constructor. congruence. - - assert (Y : ∑ mfix'', map (map_def_anon nl nl) mfix1 - = map (map_def_anon nl nl) mfix'' - × OnOne2 (fun x y => red1 Σ (nlctx Γ) (dtype x) (dtype y) - × (dname x, dbody x, rarg x) = (dname y, dbody y, rarg y)) - (map (map_def_anon nl nl) mfix0) mfix''). - { - induction X. - + destruct p as [[? [typ'' [? ?]]] ?]. cbn. - eexists ({|dname:=nAnon; dtype:=typ''; dbody:=nl (dbody hd'); - rarg:=rarg hd' |} - :: map (map_def_anon nl nl) tl); cbn; split. - * f_equal; simpl. - -- rewrite nl_two. congruence. - -- rewrite map_map; apply map_ext; intros []; simpl; now rewrite !nl_two. - * constructor. cbn. split; auto. congruence. - + destruct IHX as [mfix'' [? ?]]. - exists (map_def_anon nl nl hd :: mfix''); cbn; split. - * rewrite !nl_two. congruence. - * now constructor. - } - destruct Y as [mfix'' [? ?]]. - exists (tFix mfix'' idx); cbn; split. 1: now constructor. congruence. - - assert (Y : ∑ mfix'', map (map_def_anon nl nl) mfix1 - = map (map_def_anon nl nl) mfix'' - × OnOne2 (fun x y : def term => - red1 Σ (nlctx Γ ,,, fix_context (map (map_def_anon nl nl) mfix0)) - (dbody x) (dbody y) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) - (map (map_def_anon nl nl) mfix0) mfix''). { - (* induction mfix1 in mfix0, X |- *; inversion X; subst. *) - (* + destruct X0 as [[X1 [hd'' [X3 X4]]] X5]. *) - (* eexists ({|dname:=nAnon; dtype:=nl (dtype a); dbody:=hd''; *) - (* rarg:=rarg a |} :: map (map_def_anon nl nl) mfix1). *) - (* split. cbn. f_equal. rewrite nl_two. f_equal; tas. *) - (* rewrite map_map; apply map_ext; intros []; simpl; now rewrite !nl_two. *) - (* constructor. split. *) - (* now rewrite nlctx_app_context, nl_fix_context in X3. *) - (* cbn. congruence. *) - (* + specialize (IHmfix1 _ X0); clear X0. *) - - (* simpl. exact X3. *) - - (* + *) - - - - (* rewrite nlctx_app_context in X. rewrite <- nl_fix_context. *) - (* set (c := fix_context mfix0) in *. cut (c = fix_context mfix0); cbnr. *) - (* clearbody c. *) - (* induction X; intro; subst c. *) - (* + destruct p as [[? [bo'' [? ?]]] ?]. simpl. *) - (* eexists ({|dname:=nAnon; dtype:=nl (dtype hd'); dbody:=bo''; *) - (* rarg:=rarg hd' |} *) - (* :: map (map_def_anon nl nl) tl); simpl; split. *) - (* f_equal; simpl. rewrite nl_two. congruence. *) - (* rewrite map_map; apply map_ext; intros []; simpl; now rewrite !nl_two. *) - (* constructor. simpl. split; auto. congruence. *) - (* (* now rewrite nlctx_app_context, nl_fix_context in r0. *) *) - (* + destruct IHX as [mfix'' [? ?]]. *) - (* exists (map_def_anon nl nl hd :: mfix''); cbn; split. *) - (* rewrite !nl_two. congruence. now constructor. } *) - - - (* } *) - (* destruct Y as [mfix'' [? ?]]. *) - (* exists (tFix mfix'' idx); cbn; split. apply fix_red_body; tas. *) - (* congruence. *) - - - -(* - constructor. eapply OnOne2_map, OnOne2_impl. 1: eassumption. *) -(* cbn. intros x y [[? ?] ?]. split. all: assumption. *) -(* - constructor. eapply OnOne2_map, OnOne2_impl. 1: eassumption. *) -(* cbn. intros x y [? ?]. all: assumption. *) -(* - constructor. eapply OnOne2_map, OnOne2_impl. 1: eassumption. *) -(* cbn. intros x y [[? ?] ?]. split. 1: assumption. *) -(* cbn. congruence. *) -(* - apply fix_red_body. eapply OnOne2_map, OnOne2_impl. 1: eassumption. *) -(* cbn. intros x y [[? ?] ?]. split. *) -(* + rewrite nlctx_app_context, nl_fix_context in r0. assumption. *) -(* + cbn. congruence. *) -(* - constructor. eapply OnOne2_map, OnOne2_impl. 1: eassumption. *) -(* cbn. intros x y [[? ?] ?]. split. 1: assumption. *) -(* cbn. congruence. *) -(* - apply cofix_red_body. eapply OnOne2_map, OnOne2_impl. 1: eassumption. *) -(* cbn. intros x y [[? ?] ?]. split. *) -(* + rewrite nlctx_app_context, nl_fix_context in r0. assumption. *) -(* + cbn. congruence. *) -(* Qed. *) -*) - - (* Lemma nleq_term_zipc : *) - (* forall u v π, *) - (* nleq_term u v -> *) - (* nleq_term (zipc u π) (zipc v π). *) - (* Proof. *) - (* intros u v π h. *) - (* eapply ssrbool.introT. *) - (* - eapply reflect_nleq_term. *) - (* - cbn. rewrite 2!nl_zipc. f_equal. *) - (* eapply ssrbool.elimT. *) - (* + eapply reflect_nleq_term. *) - (* + assumption. *) - (* Qed. *) - - (* Lemma nleq_term_zipx : *) - (* forall Γ u v π, *) - (* nleq_term u v -> *) - (* nleq_term (zipx Γ u π) (zipx Γ v π). *) - (* Proof. *) - (* intros Γ u v π h. *) - (* unfold zipx. *) - (* eapply nleq_term_it_mkLambda_or_LetIn. *) - (* eapply nleq_term_zipc. *) - (* assumption. *) - (* Qed. *) - - (* Corollary type_nameless : *) - (* forall Σ Γ u A, *) - (* wf Σ.1 -> *) - (* Σ ;;; Γ |- u : A -> *) - (* Σ ;;; Γ |- nl u : A. *) - (* Proof. *) - (* intros Σ Γ u A hΣ h. *) - (* eapply typing_alpha ; eauto. *) - (* eapply eq_term_upto_univ_tm_nl. all: auto. *) - (* Qed. *) - - (* Lemma upto_names_nl t *) - (* : t ≡ nl t. *) - (* Proof. *) - (* eapply eq_term_upto_univ_tm_nl; exact _. *) - (* Qed. *) - - (* Lemma upto_names_nlctx Γ *) - (* : Γ ≡Γ nlctx Γ. *) - (* Proof. *) - (* induction Γ as [|a Γ]; try constructor. *) - (* destruct a as [na [bo|] ty]; simpl; constructor; cbn; tas. *) - (* all: apply upto_names_nl. *) - (* Qed. *) - - (* Lemma wellformed_nlctx Γ u : *) - (* wellformed Σ Γ u -> *) - (* wellformed Σ (nlctx Γ) u. *) - (* Proof. *) - (* destruct hΣ as [hΣ']. *) - (* assert (Γ ≡Γ nlctx Γ) by apply upto_names_nlctx. *) - (* intros [[A hu]|[[ctx [s [X1 X2]]]]]; [left|right]. *) - (* - exists A. eapply context_conversion'. all: try eassumption. *) - (* 1:{ eapply wf_local_alpha with Γ. all: try eassumption. *) - (* eapply typing_wf_local. eassumption. *) - (* } *) - (* eapply upto_names_conv_context. assumption. *) - (* - constructor. exists ctx, s. split; tas. *) - (* eapply wf_local_alpha; tea. *) - (* now eapply eq_context_upto_cat. *) - (* Qed. *) - - (* Lemma fresh_global_nl : *) - (* forall Σ k, *) - (* fresh_global k Σ -> *) - (* fresh_global k (map (on_snd nl_global_decl) Σ). *) - (* Proof. *) - (* intros Σ k h. eapply Forall_map. *) - (* eapply Forall_impl ; try eassumption. *) - (* intros x hh. cbn in hh. *) - (* destruct x ; assumption. *) - (* Qed. *) diff --git a/pcuic/theories/PCUICNormal.v b/pcuic/theories/PCUICNormal.v index 679a65f37..23dd4b4bf 100644 --- a/pcuic/theories/PCUICNormal.v +++ b/pcuic/theories/PCUICNormal.v @@ -3,8 +3,9 @@ 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 PCUICContextRelation - PCUICEquality PCUICLiftSubst PCUICTyping PCUICInduction. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICContextRelation + PCUICContextReduction PCUICEquality PCUICLiftSubst PCUICTyping PCUICWeakeningEnv + PCUICInduction PCUICRedTypeIrrelevance. Require Import ssreflect. Set Asymmetric Patterns. @@ -199,7 +200,7 @@ Defined. Lemma negb_is_true b : ~ is_true b -> is_true (negb b). Proof. - destruct b; pcuicfo. + destruct b; pcuicfo. congruence. Qed. Hint Resolve negb_is_true : core. @@ -315,7 +316,7 @@ Set Firstorder Solver auto with core. Definition whnf_whne_dec flags Σ Γ t : ({∥whnf flags Σ Γ t∥} + {~∥whnf flags Σ Γ t∥}) * ({∥whne flags Σ Γ t∥} + {~∥whne flags Σ Γ t∥}). -Proof with eauto using sq with pcuic. +Proof with eauto using sq with pcuic; try congruence. induction t using term_forall_mkApps_ind in Γ |- *; split... all: try now (right; intros [H]; depelim H;help). - destruct (RedFlags.zeta flags) eqn:Er. @@ -398,7 +399,7 @@ Proof with eauto using sq with pcuic. ++ destruct (nth_error_all E2 X Γ) as [_ []]. ** left. destruct s. constructor. eauto. ** destruct (RedFlags.fix_ flags) eqn:?. - --- right. intros ?. depelim H0. 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. @@ -409,9 +410,7 @@ Proof with eauto using sq with pcuic. apply n0; sq; auto. --- left. constructor. apply whne_mkApps. constructor. assumption. ++ right. intros [[ | (mfix' & idx' & narg' & body' & a' & [=] & ? & ? & ?) ] % whne_mkApps_inv]; subst; cbn... - congruence. -- right. intros [[ | (mfix' & idx' & narg' & body' & a' & [=] & ? & ? & ?) ] % whne_mkApps_inv]; subst; cbn... - congruence. * right. intros [[ | (mfix' & idx' & narg' & body' & a' & [=] & ? & ? & ?) ] % whne_mkApps_inv]; subst; cbn... - destruct (RedFlags.delta flags) eqn:Er... destruct (lookup_env Σ s) as [[] | ] eqn:E. @@ -428,11 +427,11 @@ Proof with eauto using sq with pcuic. - left. constructor. eapply whnf_indapp with (v := []). - left. constructor. eapply whnf_cstrapp with (v := []). - destruct (RedFlags.iota flags) eqn:Eq... - destruct (IHt2 Γ) as [_ []]. + destruct (IHt Γ) as [_ []]. + left. destruct s... + right. intros [w]. depelim w. depelim w. all:help... - - destruct (RedFlags.iota flags) eqn:Eq... - destruct (IHt2 Γ) as [_ []]. + - destruct (RedFlags.iota flags) eqn:Eq... + destruct (IHt Γ) as [_ []]. + left. destruct s... + right. intros [w]. depelim w. all:help... - destruct (RedFlags.iota flags) eqn:Eq... @@ -512,7 +511,7 @@ Lemma red1_mkApps_tFix_inv Σ Γ mfix id v t' : red1 Σ Γ (mkApps (tFix mfix id) v) t' -> (∑ v', (t' = mkApps (tFix mfix id) v') * (OnOne2 (red1 Σ Γ) v v')) + (∑ mfix', (t' = mkApps (tFix mfix' id) v) * (OnOne2 (on_Trel_eq (red1 Σ Γ) dtype (fun x0 : def term => (dname x0, dbody x0, rarg x0))) mfix mfix')) - + (∑ mfix', (t' = mkApps (tFix mfix' id) v) * (OnOne2 (on_Trel_eq (red1 Σ (Γ ,,, PCUICLiftSubst.fix_context mfix)) dbody (fun x0 : def term => (dname x0, dtype x0, rarg x0))) mfix mfix')). + + (∑ mfix', (t' = mkApps (tFix mfix' id) v) * (OnOne2 (on_Trel_eq (red1 Σ (Γ ,,, fix_context mfix)) dbody (fun x0 : def term => (dname x0, dtype x0, rarg x0))) mfix mfix')). Proof. intros not_ctor. revert t'. induction v using rev_ind; intros. - cbn in *. depelim X; help; eauto. @@ -541,7 +540,7 @@ Lemma red1_mkApps_tCoFix_inv Σ Γ mfix id v t' : red1 Σ Γ (mkApps (tCoFix mfix id) v) t' -> (∑ v', (t' = mkApps (tCoFix mfix id) v') * (OnOne2 (red1 Σ Γ) v v')) + (∑ mfix', (t' = mkApps (tCoFix mfix' id) v) * (OnOne2 (on_Trel_eq (red1 Σ Γ) dtype (fun x0 : def term => (dname x0, dbody x0, rarg x0))) mfix mfix')) - + (∑ mfix', (t' = mkApps (tCoFix mfix' id) v) * (OnOne2 (on_Trel_eq (red1 Σ (Γ ,,, PCUICLiftSubst.fix_context mfix)) dbody (fun x0 : def term => (dname x0, dtype x0, rarg x0))) mfix mfix')). + + (∑ mfix', (t' = mkApps (tCoFix mfix' id) v) * (OnOne2 (on_Trel_eq (red1 Σ (Γ ,,, fix_context mfix)) dbody (fun x0 : def term => (dname x0, dtype x0, rarg x0))) mfix mfix')). Proof. revert t'. induction v using rev_ind; intros. - cbn in *. depelim X; help; eauto. @@ -720,18 +719,32 @@ Lemma whne_red1_ind ((dname x, dtype x, rarg x) = (dname y, dtype y, rarg y))) defs mfix1 -> P (tFix defs i) (tFix mfix1 i)) - (Hcase_discr : forall i p c brs p', + (Hcase_params : forall i p c brs params', + whne flags Σ Γ c -> + OnOne2 (red1 Σ Γ) p.(pparams) params' -> + P (tCase i p c brs) (tCase i (set_pparams p params') c brs)) + + (Hcase_pcontext : forall i p c brs pcontext', + whne flags Σ Γ c -> + OnOne2_local_env (on_one_decl (fun Γ' => red1 Σ (Γ ,,, Γ'))) p.(pcontext) pcontext' -> + P (tCase i p c brs) (tCase i (set_pcontext p pcontext') c brs)) + + (Hcase_discr : forall i p c brs p', whne flags Σ Γ c -> - red1 Σ Γ p p' -> - P (tCase i p c brs) (tCase i p' c brs)) + red1 Σ (Γ ,,, p.(pcontext)) p.(preturn) p' -> + P (tCase i p c brs) (tCase i (set_preturn p p') c brs)) (Hcase_motive : forall i p c brs c', whne flags Σ Γ c -> red1 Σ Γ c c' -> 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 (on_Trel_eq (red1 Σ Γ) snd fst) brs brs' -> + whne flags Σ Γ c -> + OnOne2 (fun br br' => + let ctx := br.(bcontext) in + (on_Trel_eq (red1 Σ (Γ ,,, ctx)) bbody bcontext br br' + + on_Trel_eq (OnOne2_local_env (on_one_decl (fun Γ' => red1 Σ (Γ ,,, Γ')))) + bcontext bbody br br'))%type brs brs' -> P (tCase i p c brs) (tCase i p c brs')) (Hcase_noiota : forall t' i p c brs, RedFlags.iota flags = false -> @@ -965,11 +978,19 @@ Inductive whnf_red Σ Γ : term -> term -> Type := red Σ (Γ,,, fix_context mfix) (dbody d) (dbody d')) mfix mfix' -> whnf_red Σ Γ (tFix mfix idx) (tFix mfix' idx) -| whnf_red_tCase p motive motive' discr discr' brs brs' : - red Σ Γ motive motive' -> +| whnf_red_tCase ci motive motivepars motivectx motiveret discr discr' brs brs' : + All2 (red Σ Γ) motive.(pparams) motivepars -> + red_ctx_rel Σ Γ (pcontext motive) motivectx -> + red Σ (Γ ,,, motive.(pcontext)) motive.(preturn) motiveret -> red Σ Γ discr discr' -> - All2 (fun br br' => br.1 = br'.1 × red Σ Γ br.2 br'.2) brs brs' -> - whnf_red Σ Γ (tCase p motive discr brs) (tCase p motive' discr' brs') + All2 (fun br br' => + red_ctx_rel Σ Γ br.(bcontext) br'.(bcontext) × + red Σ (Γ ,,, br.(bcontext)) br.(bbody) br'.(bbody)) brs brs' -> + whnf_red Σ Γ (tCase ci motive discr brs) + (tCase ci {| pparams := motivepars; + puinst := motive.(puinst); + pcontext := motivectx; + preturn := motiveret |} discr' brs') | whnf_red_tProj p c c' : red Σ Γ c c' -> whnf_red Σ Γ (tProj p c) (tProj p c') @@ -999,6 +1020,14 @@ Derive Signature for whnf_red. 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'') : + (forall x y z, P x y z -> Q x y z) -> + All3 Q l l' l''. +Proof. + intros HPQ; induction a; constructor; auto. +Qed. + Lemma whnf_red_red Σ Γ t t' : whnf_red Σ Γ t t' -> red Σ Γ t t'. @@ -1012,17 +1041,16 @@ Proof. cbn. intros ? ? (->&->&r1&r2). eauto. - - apply red_case; auto. + - eapply red_case; eauto. eapply All2_impl; eauto. - cbn. - intros ? ? (->&?). - eauto. + cbn. intros ? ? (eq&?). + intuition eauto. - apply red_proj_c; auto. - apply red_prod; auto. - apply red_abs; auto. - eapply context_change_decl_types_red; eauto. + eapply context_pres_let_bodies_red; eauto. constructor; [|constructor]. - apply context_relation_refl. + apply All2_fold_refl. reflexivity. - apply red_cofix_congr. eapply All2_impl; eauto. @@ -1105,10 +1133,15 @@ Lemma whnf_red_refl_whne Σ Γ t : Proof. intros wh. induction wh; cbn in *; try discriminate; eauto using whnf_red with pcuic. - apply whnf_red_mkApps; auto. - 2: apply All2_same; auto. - constructor. - apply All2_same; auto. + - apply whnf_red_mkApps; auto. + 2: apply All2_same; auto. + constructor. + apply All2_same; auto. + - destruct p. econstructor; simpl; eauto. + * eapply All2_same; auto. + * reflexivity. + * eapply All2_same; intuition auto. + reflexivity. Qed. Lemma whnf_red_refl Σ Γ t : @@ -1128,9 +1161,9 @@ Proof. apply All2_same; auto. Qed. -Instance whnf_red_trans Σ Γ : CRelationClasses.Transitive (whnf_red Σ Γ). +Instance whnf_red_trans {cf:checker_flags} Σ Γ : wf Σ -> CRelationClasses.Transitive (whnf_red Σ Γ). Proof. - intros x y z xy yz. + intros wf x y z xy yz. revert z yz. induction xy; intros z yz; depelim yz; eauto using whnf_red. - constructor. @@ -1147,25 +1180,37 @@ Proof. cbn. intros ? ? (->&->&?&?). do 3 (split; auto). - eapply context_change_decl_types_red; eauto. - apply fix_context_change_decl_types. + eapply context_pres_let_bodies_red; eauto. + apply fix_context_pres_let_bodies. now apply All2_length in a. - - constructor; try solve [etransitivity; eauto]. - eapply All2_trans; eauto. - intros ? ? ? (->&?) (->&?). - split; auto. - etransitivity; eauto. + - simpl in *. + constructor; try solve [etransitivity; eauto]. + + eapply All2_trans; eauto. + typeclasses eauto. + + etransitivity; [eassumption|]. + eapply red_red_ctx; eauto. + apply red_context_app_right; eauto. + * apply red_context_refl. + * apply red_ctx_rel_red_context_rel; eauto. + + eapply All2_trans; eauto. + clear -wf. + intros x y z (?&?) (?&?). + split; etransitivity; eauto. + eapply red_red_ctx; eauto. + eapply red_context_app_right; eauto. + * apply red_context_refl. + * eapply red_ctx_rel_red_context_rel; eauto. - constructor. etransitivity; eauto. - constructor; etransitivity; eauto. - eapply context_change_decl_types_red; eauto. + eapply context_pres_let_bodies_red; eauto. constructor; eauto; [|constructor]. - apply context_relation_refl. + apply All2_fold_refl. intros; reflexivity. - constructor; etransitivity; eauto. - eapply context_change_decl_types_red; eauto. + eapply context_pres_let_bodies_red; eauto. constructor; eauto; [|constructor]. - apply context_relation_refl. + apply All2_fold_refl. intros; reflexivity. - constructor. eapply All2_trans; eauto. @@ -1176,8 +1221,8 @@ Proof. cbn. intros ? ? (->&->&?&?). do 3 (split; auto). - eapply context_change_decl_types_red; eauto. - apply fix_context_change_decl_types. + eapply context_pres_let_bodies_red; eauto. + apply fix_context_pres_let_bodies. now apply All2_length in a. Qed. @@ -1212,12 +1257,37 @@ Proof. auto. + apply All2_same; auto. - constructor; auto. - apply All2_same; auto. - - constructor; auto. - apply All2_same; auto. - - constructor; auto. - eapply OnOne2_All2; eauto. - intros ? ? (?&?); auto. + * eapply OnOne2_All2; eauto. + * reflexivity. + * eapply All2_same; intuition auto. reflexivity. + - econstructor; auto. apply All2_same; auto. + eapply red_one_decl_red_ctx_rel. red. + eapply OnOne2_local_env_impl; tea. + intros Δ' x' y'. + eapply on_one_decl_impl => Γ' ? ? IH. + now constructor. + eapply All2_same; intuition auto. reflexivity. + - econstructor; auto. + * apply All2_same; auto. + * reflexivity. + * apply All2_same; intuition auto; reflexivity. + - destruct p; econstructor; eauto; simpl. + * eapply All2_same; auto. + * reflexivity. + * eapply All2_same; intuition auto. reflexivity. + - destruct p; econstructor; eauto; simpl. + * eapply All2_same; reflexivity. + * reflexivity. + * eapply OnOne2_All2; eauto. + cbn. intros ? ? [[? [= <-]]|[? ?]]; + intuition eauto; try reflexivity. + + eapply red_one_decl_red_ctx_rel. red. + eapply OnOne2_local_env_impl; tea. + intros Δ' x' y'. + eapply on_one_decl_impl => Γ' ? ? IH. + now constructor. + + now rewrite -e. + + intuition auto. reflexivity. Qed. Lemma whnf_red1_inv Σ Γ t t' : @@ -1282,12 +1352,13 @@ Proof. - depelim r; solve_discr. Qed. -Lemma whnf_red_inv Σ Γ t t' : +Lemma whnf_red_inv {cf:checker_flags} Σ Γ t t' : + wf Σ -> whnf RedFlags.default Σ Γ t -> red Σ Γ t t' -> whnf_red Σ Γ t t'. Proof. - intros wh r. + intros wf wh r. induction r using red_rect_n1. - apply whnf_red_refl; auto. - eapply whnf_red1_inv in X. diff --git a/pcuic/theories/PCUICOnFreeVars.v b/pcuic/theories/PCUICOnFreeVars.v new file mode 100644 index 000000000..7c6506613 --- /dev/null +++ b/pcuic/theories/PCUICOnFreeVars.v @@ -0,0 +1,1252 @@ +(* Distributed under the terms of the MIT license. *) +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 + PCUICEquality PCUICSigmaCalculus PCUICClosed. + +(* For the last proof only, about reduction, requiring closed global declarations. *) +From MetaCoq.PCUIC Require Import PCUICTyping PCUICWeakeningEnv. + +From Equations Require Import Equations. +Require Import Equations.Prop.DepElim. +Set Equations With UIP. + +(** * Preservation of free variables *) + +Open Scope sigma_scope. +Set Keyed Unification. + +Set Default Goal Selector "!". + +Implicit Type (cf : checker_flags). + +Definition shiftnP k p i := + (i `=1`) (shiftnP k). +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. + +Lemma shiftnP_impl (p q : nat -> bool) : (forall i, p i -> q i) -> + forall n i, shiftnP n p i -> shiftnP n q i. +Proof. + intros Hi n i. rewrite /shiftnP. + nat_compare_specs => //. apply Hi. +Qed. + +Fixpoint on_free_vars (p : nat -> bool) (t : term) : bool := + match t with + | tRel i => p i + | tEvar ev args => List.forallb (on_free_vars p) args + | tLambda _ T M | tProd _ T M => on_free_vars p T && on_free_vars (shiftnP 1 p) M + | tApp u v => on_free_vars p u && on_free_vars p v + | tLetIn na b t b' => [&& on_free_vars p b, on_free_vars p t & on_free_vars (shiftnP 1 p) b'] + | tCase ind pred c brs => + [&& forallb (on_free_vars p) pred.(pparams), + on_free_vars (shiftnP #|pred.(pcontext)| p) pred.(preturn), + test_context_k (fun k => on_free_vars (shiftnP k p)) 0 pred.(pcontext), + on_free_vars p c & + forallb (fun br => + test_context_k (fun k => on_free_vars (shiftnP k p)) 0 br.(bcontext) && + on_free_vars (shiftnP #|br.(bcontext)| p) br.(bbody)) brs] + | tProj _ c => on_free_vars p c + | tFix mfix idx | tCoFix mfix idx => + List.forallb (test_def (on_free_vars p) (on_free_vars (shiftnP #|mfix| p))) mfix + | tVar _ | tSort _ | tConst _ _ | tInd _ _ | tConstruct _ _ _ + | tPrim _ => true + end. + +Lemma on_free_vars_ext (p q : nat -> bool) t : + p =1 q -> + on_free_vars p t = on_free_vars q t. +Proof. + revert p q. + induction t using PCUICInduction.term_forall_list_ind; simpl => //; intros; + unfold test_def; + rewrite ?forallb_map; try eapply All_forallb_eq_forallb; tea; eauto 2. + all: try now rewrite (IHt1 p q) // ?(IHt2 (shiftnP 1 p) (shiftnP 1 q)) // H. + - now rewrite (IHt1 p q) // ?(IHt2 p q) // (IHt3 (shiftnP 1 p) (shiftnP 1 q)) // H. + - rewrite (IHt1 p q) // (IHt2 p q) //. + - destruct X as [? [? ?]]. red in X0. + f_equal. + * eapply All_forallb_eq_forallb; tea. solve_all. + * f_equal; [eapply e; rewrite H //|]. + f_equal. + + solve_all; rewrite Nat.add_0_r. apply H0 => //. + now apply shiftnP_ext. + + f_equal; [eapply IHt; rewrite H //|]. + eapply All_forallb_eq_forallb; tea. intros. + destruct X. + f_equal; [|eapply e0; rewrite H //]. + solve_all; rewrite Nat.add_0_r; apply H0 => //. + now apply shiftnP_ext. + - simpl; intuition auto. f_equal; eauto 2. + eapply b; rewrite H //. + - simpl; intuition auto. f_equal; eauto 2. + eapply b; rewrite H //. +Qed. + +Instance on_free_vars_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) on_free_vars. +Proof. intros f g Hfg ? ? ->. now apply on_free_vars_ext. Qed. + +Instance on_free_vars_proper_pointwise : Proper (`=1` ==> `=1`) on_free_vars. +Proof. intros f g Hfg x. now apply on_free_vars_ext. Qed. + +Lemma shiftnP_xpredT n : shiftnP n xpredT =1 xpredT. +Proof. intros i; rewrite /shiftnP. nat_compare_specs => //. Qed. + +Lemma test_context_k_ctx p k (ctx : context) : test_context_k (fun=> p) k ctx = test_context p ctx. +Proof. + induction ctx; simpl; auto. +Qed. +Hint Rewrite test_context_k_ctx : map. + +Lemma on_free_vars_true t : on_free_vars xpredT t. +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; + try rtoProp; solve_all). + - rtoProp. setoid_rewrite shiftnP_xpredT. + rewrite test_context_k_ctx. + now move/onctxP: a0. + - setoid_rewrite shiftnP_xpredT. + rewrite test_context_k_ctx. + now move/onctxP: a1. + - unfold test_def in *. apply /andP. now rewrite shiftnP_xpredT. + - unfold test_def in *. apply /andP. now rewrite shiftnP_xpredT. +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 q t. +Proof. + unfold pointwise_relation, Basics.impl. + intros Himpl onf. revert onf Himpl. + revert t p q. + induction t using PCUICInduction.term_forall_list_ind; simpl => //; solve_all. + all:unfold test_def in *; rtoProp; now (eauto using shiftnP_impl with all). +Qed. + +Definition closedP (n : nat) (P : nat -> bool) := + fun i => if i `=1`) (closedP n). +Proof. intros f g Hfg. intros i; rewrite /closedP. now rewrite Hfg. Qed. + +Lemma shiftnP_closedP k n P : shiftnP k (closedP n P) =1 closedP (k + n) (shiftnP k P). +Proof. + intros i; rewrite /shiftnP /closedP. + repeat nat_compare_specs => //. +Qed. + +Lemma closedP_on_free_vars {n t} : closedn n t -> on_free_vars (closedP n xpredT) t. +Proof. + revert n t. + apply: term_closedn_list_ind; simpl => //; intros. + all:(rewrite ?shiftnP_closedP ?shiftnP_xpredT). + all:try (rtoProp; now rewrite ?IHt1 ?IHt2 ?IHt3). + - rewrite /closedP /=. now nat_compare_specs. + - solve_all. + - destruct X. rtoProp. intuition solve_all. + * setoid_rewrite shiftnP_closedP. + setoid_rewrite shiftnP_xpredT. + eapply onctx_k_shift in a0. simpl in a0. + case: (onctx_k_P reflectT_pred2) => //. + * red in X0. solve_all. + + setoid_rewrite shiftnP_closedP. + setoid_rewrite shiftnP_xpredT. + eapply onctx_k_shift in a1. simpl in a1. + case: (onctx_k_P reflectT_pred2) => //. + + now rewrite shiftnP_closedP shiftnP_xpredT. + - unfold test_def. solve_all. + rewrite shiftnP_closedP shiftnP_xpredT. + now len in b. + - unfold test_def; solve_all. + rewrite shiftnP_closedP shiftnP_xpredT. + now len in b. +Qed. + +Lemma closedn_on_free_vars {P n t} : closedn n t -> on_free_vars (shiftnP n P) t. +Proof. + move/closedP_on_free_vars. + eapply on_free_vars_impl. + intros i; rewrite /closedP /shiftnP /= //. + nat_compare_specs => //. +Qed. + +(** Any predicate is admissible as there are no free variables to consider *) +Lemma closed_on_free_vars {P t} : closed t -> on_free_vars P t. +Proof. + move/closedP_on_free_vars. + eapply on_free_vars_impl. + intros i; rewrite /closedP /= //. +Qed. + +Lemma on_free_vars_subst_instance {p u t} : on_free_vars p t = on_free_vars p (subst_instance u t). +Proof. + rewrite /subst_instance /=. revert t p. + apply: term_forall_list_ind; simpl => //; intros. + all:try (rtoProp; now rewrite -?IHt1 -?IHt2 -?IHt3). + - rewrite forallb_map. eapply All_forallb_eq_forallb; eauto. + - repeat (solve_all; f_equal). + - unfold test_def. solve_all. + - unfold test_def; solve_all. +Qed. + +Definition on_free_vars_decl P d := + test_decl (on_free_vars P) d. + +Instance on_free_vars_decl_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) on_free_vars_decl. +Proof. rewrite /on_free_vars_decl => f g Hfg x y <-. now rewrite Hfg. Qed. + +Instance on_free_vars_decl_proper_pointwise : Proper (`=1` ==> `=1`) on_free_vars_decl. +Proof. rewrite /on_free_vars_decl => f g Hfg x. now rewrite Hfg. Qed. + +Definition on_free_vars_ctx P ctx := + alli (fun k => (on_free_vars_decl (shiftnP k P))) 0 (List.rev 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. +Qed. + +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. + apply test_decl_impl. intros t. + now apply on_free_vars_impl. +Qed. + +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. + eapply alli_impl => i x. + apply on_free_vars_decl_impl. + intros k; rewrite /shiftnP. + now nat_compare_specs. +Qed. + +Lemma closed_decl_on_free_vars {n d} : closed_decl n d -> on_free_vars_decl (closedP n xpredT) d. +Proof. + rewrite /on_free_vars_decl /test_decl. + move=> /andP [clb cld]. + rewrite (closedP_on_free_vars cld) /=. + destruct (decl_body d) eqn:db => /= //. + now rewrite (closedP_on_free_vars clb). +Qed. + +Lemma closedn_ctx_on_free_vars {n ctx} : closedn_ctx n ctx -> + on_free_vars_ctx (closedP n xpredT) ctx. +Proof. + rewrite /on_free_vars_ctx test_context_k_eq. + apply alli_impl => i x. + rewrite shiftnP_closedP Nat.add_comm shiftnP_xpredT. + eapply closed_decl_on_free_vars. +Qed. + +Lemma closedn_ctx_on_free_vars_shift {n ctx P} : + closedn_ctx n ctx -> + on_free_vars_ctx (shiftnP n P) ctx. +Proof. + move/closedn_ctx_on_free_vars. + rewrite /on_free_vars_ctx. + apply alli_impl => i x. + rewrite shiftnP_closedP shiftnP_add shiftnP_xpredT. + eapply on_free_vars_decl_impl => //. + intros k. + rewrite /closedP /shiftnP. + now nat_compare_specs => //. +Qed. + +(** This uses absurdity elimination as [ctx] can't have any free variable *) +Lemma closed_ctx_on_free_vars P ctx : closed_ctx ctx -> + on_free_vars_ctx P ctx. +Proof. + move/closedn_ctx_on_free_vars => /=. + rewrite /closedP /=. + eapply on_free_vars_ctx_impl => //. +Qed. + +Definition nocc_betweenp k n i := + (i (i bool) := + fun i => if i `=1`) (strengthenP n k). +Proof. + intros f g Hfg i. rewrite /strengthenP. now rewrite (Hfg i) (Hfg (i - k)). +Qed. + +Lemma shiftnP_strengthenP k' k n p : + shiftnP k' (strengthenP k n p) =1 strengthenP (k' + k) n (shiftnP k' p). +Proof. + intros i. rewrite /shiftnP /strengthenP. + repeat nat_compare_specs => /= //. + lia_f_equal. +Qed. + +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. + induction t using PCUICInduction.term_forall_list_ind; simpl => //; intros; + rewrite ?forallb_map; try eapply All_forallb_eq_forallb; tea; simpl. + 2-6:try now rewrite ?shiftnP_strengthenP ?IHt1 ?IHt2 ?IHt3. + - rename n0 into i. rewrite /strengthenP. + repeat nat_compare_specs => //. + lia_f_equal. + - rtoProp; solve_all. len; rewrite !shiftnP_strengthenP e IHt. + f_equal; solve_all. f_equal; solve_all. f_equal; solve_all. + + len. rewrite !shiftnP_strengthenP /shiftf. now rewrite Nat.sub_0_r H. + + f_equal. solve_all. + f_equal; solve_all. + * len; rewrite !shiftnP_strengthenP /shiftf. + now rewrite Nat.sub_0_r H. + * len. now rewrite !shiftnP_strengthenP. + - unfold test_def in *. simpl; intros ? []. + len; rewrite shiftnP_strengthenP. f_equal; eauto. + - unfold test_def in *. simpl; intros ? []. + len; rewrite shiftnP_strengthenP. f_equal; eauto. +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 => + if i /= //. + f_equal; [f_equal|] => /= //. + * lia_f_equal. + * rewrite /strengthenP. simpl. + repeat nat_compare_specs => //. + lia_f_equal. +Qed. + +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). +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). + - 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. + 2:now rewrite -> on_free_vars_lift. + rewrite /strengthenP. simpl. + intros i. nat_compare_specs => //. + intros ->. now rewrite orb_true_r. + + eapply nth_error_None in eq. + simpl. rewrite /substP. + replace (n - #|s| + #|s|) with n by lia. + nat_compare_specs. + now rewrite H0. + * simpl. rewrite /substP /strengthenP /=. + rewrite H0. now nat_compare_specs. + - solve_all. + - rtoProp. destruct X. solve_all. + * len. rewrite shiftnP_substP. solve_all. + * len in H6. len; rewrite Nat.sub_0_r /shiftf !shiftnP_substP; solve_all. + * len in H7; len. rewrite Nat.sub_0_r /shift !shiftnP_substP; solve_all. + * len. rewrite shiftnP_substP; solve_all. + - unfold test_def in *; red in X; solve_all. + rtoProp. rewrite shiftnP_substP; len. solve_all. + - unfold test_def in *; solve_all. rtoProp. + rewrite shiftnP_substP; len. solve_all. +Qed. + +Lemma rshiftk_S x f : S (rshiftk x f) = rshiftk (S x) f. +Proof. reflexivity. Qed. + +Lemma substP_shiftnP n p : + substP 0 n p (shiftnP n p) =1 p. +Proof. + intros i; rewrite /shiftnP /substP /= /strengthenP /=. + nat_compare_specs. + replace (i + n - n) with i by lia. + now rewrite Nat.sub_0_r orb_diag. +Qed. + +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). +Proof. + intros hs ht. + epose proof (on_free_vars_subst_gen (shiftnP #|s| p) p s 0 t). + rewrite -> substP_shiftnP in H. + apply H. + - exact hs. + - apply ht. +Qed. + +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). +Proof. + intros hs ht. + rewrite /subst1. + epose proof (on_free_vars_subst_gen (shiftnP 1 p) p [s] 0 t). + rewrite -> substP_shiftnP in H. + apply H. + - now rewrite /on_free_vars_terms /= hs. + - apply ht. +Qed. + +Definition addnP n (p : nat -> bool) := + fun i => p (i + n). + +Instance addnP_proper n : Proper (`=1` ==> Logic.eq ==> Logic.eq) (addnP n). +Proof. + intros i f g Hfg; now rewrite /addnP. +Qed. + +Instance addnP_proper_pointwise : Proper (Logic.eq ==> `=1` ==> `=1`) addnP. +Proof. + intros i f g Hfg; now rewrite /addnP. +Qed. + +Lemma addnP_add n k p : addnP n (addnP k p) =1 addnP (n + k) p. +Proof. + rewrite /addnP => i. lia_f_equal. +Qed. + +Lemma addnP0 p : addnP 0 p =1 p. +Proof. intros i; now rewrite /addnP Nat.add_0_r. Qed. + +Lemma addnP_shiftnP n P : addnP n (shiftnP n P) =1 P. +Proof. + intros i; rewrite /addnP /shiftnP /=. + nat_compare_specs => /=. lia_f_equal. +Qed. + +Lemma addnP_orP n p q : addnP n (predU p q) =1 predU (addnP n p) (addnP n q). +Proof. reflexivity. Qed. + +Definition on_ctx_free_vars P ctx := + alli (fun k d => P k ==> (on_free_vars_decl (addnP (S k) P) d)) 0 ctx. + +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. +Qed. + +Instance on_ctx_free_vars_proper_pointwise : Proper (`=1` ==> `=1`) on_ctx_free_vars. +Proof. + rewrite /on_ctx_free_vars => f g Hfg x. + apply alli_ext => k. + now setoid_rewrite Hfg. +Qed. + +Lemma nth_error_on_free_vars_ctx P n ctx i d : + on_ctx_free_vars (addnP n P) ctx -> + P (n + i) -> + nth_error ctx i = Some d -> + test_decl (on_free_vars (addnP (n + S i) P)) d. +Proof. + rewrite /on_ctx_free_vars. + solve_all. + eapply alli_Alli, Alli_nth_error in H; eauto. + rewrite /= {1}/addnP Nat.add_comm H0 /= in H. + now rewrite Nat.add_comm -addnP_add. +Qed. + +Definition aboveP k (p : nat -> bool) := + fun i => if i //. + lia_f_equal. +Qed. + +Lemma on_free_vars_lift0 i p t : + on_free_vars (addnP i p) t -> + on_free_vars p (lift0 i t). +Proof. + rewrite -(on_free_vars_lift _ i 0). + rewrite /strengthenP /= /aboveP /addnP. + unshelve eapply on_free_vars_impl. + simpl. intros i'. nat_compare_specs => //. + now replace (i' - i + i) with i' by lia. +Qed. + +Lemma on_free_vars_lift0_above i p t : + on_free_vars (addnP i p) t = on_free_vars (aboveP i p) (lift0 i t). +Proof. + rewrite -(on_free_vars_lift _ i 0). + rewrite /strengthenP /= /aboveP /addnP. + unshelve eapply on_free_vars_ext. + simpl. intros i'. nat_compare_specs => //. + now replace (i' - i + i) with i' by lia. +Qed. + +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 |- * => /=. + - now rewrite andb_true_r. + - 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))) + (extended_subst ctx (n + k)) = + forallb (on_free_vars (shiftnP (k + (context_assumptions ctx)) p)) + (extended_subst ctx k). +Proof. + rewrite lift_extended_subst' forallb_map. + eapply forallb_ext => t. + rewrite -(on_free_vars_lift _ n 0 t) //. +Qed. + +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. + rewrite lift_extended_subst' forallb_map. + eapply forallb_ext => t. + 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)) + (extended_subst ctx k) -> + forallb (on_free_vars (shiftnP (n + k + context_assumptions ctx) p)) + (extended_subst ctx (n + k)). +Proof. + rewrite lift_extended_subst' forallb_map. + eapply forallb_impl => t _. + rewrite -(on_free_vars_lift _ n 0 t). + rewrite /strengthenP /=. + apply on_free_vars_impl => i. + rewrite /shiftnP. + repeat nat_compare_specs => /= //. + intros. + red; rewrite -H2. lia_f_equal. +Qed. + +Definition occ_betweenP k n := + fun i => (k <=? i) && (i /= //; now rewrite andb_true_r. +Qed. + +Lemma on_free_vars_mkProd_or_LetIn P 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 /= + ?andb_assoc /foroptb /=; try bool_congr. +Qed. + +Lemma on_free_vars_ctx_all_term P ctx s : + on_free_vars_ctx P ctx = on_free_vars P (it_mkProd_or_LetIn ctx (tSort s)). +Proof. + rewrite /on_free_vars_ctx. + rewrite -{2}[P](shiftnP0 P). + generalize 0 as k. + induction ctx using rev_ind; simpl; auto; intros k. + rewrite List.rev_app_distr alli_app /= andb_true_r. + rewrite IHctx it_mkProd_or_LetIn_app /= on_free_vars_mkProd_or_LetIn. + now rewrite shiftnP_add. +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 := + [pred i | p i ==> q i]. + +Definition eq_simpl_pred {A} (x y : simpl_pred A) := + `=1` x y. + +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 : + predA p q =1 xpredT -> + on_free_vars p t -> on_free_vars q t. +Proof. + rewrite /predA /=. intros Hp. + eapply on_free_vars_impl. + intros i hp. specialize (Hp i). now rewrite /= hp in Hp. +Qed. + +Definition shiftnP_predU n p q : + shiftnP n (predU p q) =1 predU (shiftnP n p) (shiftnP n q). +Proof. + intros i. + rewrite /shiftnP /predU /=. + repeat nat_compare_specs => //. +Qed. + +Instance orP_Proper {A} : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predU A). +Proof. + intros f g Hfg f' g' Hfg' i; rewrite /predU /=. + now rewrite Hfg Hfg'. +Qed. + +Instance andP_Proper A : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predI A). +Proof. + intros f g Hfg f' g' Hfg' i; rewrite /predI /=. + now rewrite Hfg Hfg'. +Qed. + +Instance pred_of_simpl_proper {A} : Proper (eq_simpl_pred ==> `=1`) (@PredOfSimpl.coerce A). +Proof. + now move=> f g; rewrite /eq_simpl_pred => Hfg. +Qed. + +Lemma orPL (p q : pred nat) : (predA p (predU p q)) =1 predT. +Proof. + intros i. rewrite /predA /predU /=. + rewrite (ssrbool.implybE (p i)). + destruct (p i) => //. +Qed. + + +Lemma orPR (p q : nat -> bool) i : q i -> (predU p q) i. +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 + [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. + 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)) + (occ_betweenP k (context_assumptions ctx)))) + (extended_subst ctx k). +Proof. + rewrite /on_free_vars_ctx_k. + induction ctx as [|[na [b|] ty] ctx] in p, k |- *; auto. + - simpl. rewrite alli_app /= andb_true_r => /andP [] hctx. + rewrite /on_free_vars_decl /test_decl /=; len => /andP [] hty /= hb. + specialize (IHctx _ k hctx). + rewrite IHctx // andb_true_r. + eapply on_free_vars_subst => //. + len. erewrite on_free_vars_implP => //; cycle 1. + { erewrite on_free_vars_lift; eauto. } + now rewrite shiftnP_predU /= shiftnP_strengthenP Nat.add_0_r shiftnP_add /= orPL. + - cbn. rewrite alli_app /= andb_true_r => /andP [] hctx. + rewrite /on_free_vars_decl /test_decl /= => hty. + len in hty. + specialize (IHctx p k). + rewrite andb_idl. + * move => _. rewrite /occ_betweenP. repeat nat_compare_specs => /= //. + * specialize (IHctx hctx). + rewrite (lift_extended_subst' _ 1). + rewrite forallb_map. + solve_all. + apply on_free_vars_lift0. + rewrite addnP_orP. + eapply on_free_vars_implP; eauto. + intros i. rewrite /predA /predU /=. + rewrite /strengthenP /= /addnP /=. + repeat nat_compare_specs => /= //. + + rewrite /occ_betweenP /implb => /=. + repeat nat_compare_specs => /= //. + + rewrite /shiftnP /occ_betweenP /=. + repeat nat_compare_specs => /= //. + 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. +Qed. + +Lemma on_free_vars_expand_lets_k P Γ n t : + n = context_assumptions Γ -> + on_free_vars_ctx P Γ -> + on_free_vars (shiftnP #|Γ| P) t -> + on_free_vars (shiftnP n P) (expand_lets_k Γ 0 t). +Proof. + intros -> HΓ Ht. + rewrite /expand_lets_k /=. + eapply on_free_vars_impl; cycle 1. + - eapply on_free_vars_subst_gen. + 1:eapply on_free_vars_extended_subst; eauto. + rewrite -> on_free_vars_lift. eauto. + - len. rewrite /substP /= /strengthenP /=. + intros i. simpl. rewrite /shiftnP. + repeat nat_compare_specs => /= //. + rewrite Nat.sub_0_r. rewrite /orP. + replace (i + #|Γ| - context_assumptions Γ - #|Γ|) with (i - context_assumptions Γ) by lia. + rewrite /occ_betweenP. repeat nat_compare_specs => /= //. + rewrite orb_false_r Nat.sub_0_r. + now rewrite orb_diag. +Qed. + +Lemma on_free_vars_terms_inds P ind puinst bodies : + on_free_vars_terms P (inds ind puinst bodies). +Proof. + rewrite /inds. + induction #|bodies|; simpl; auto. +Qed. + +Lemma on_free_vars_decl_map P f d : + (forall i, on_free_vars P i = on_free_vars P (f i)) -> + on_free_vars_decl P d = on_free_vars_decl P (map_decl f d). +Proof. + intros Hi. + rewrite /on_free_vars_decl /test_decl. + rewrite Hi. f_equal. + simpl. destruct (decl_body d) => //. + now rewrite /foroptb /= (Hi t). +Qed. + +Lemma on_free_vars_subst_instance_context P u Γ : + on_free_vars_ctx P (subst_instance u Γ) = on_free_vars_ctx P Γ. +Proof. + rewrite /on_free_vars_ctx. + rewrite /subst_instance -map_rev alli_map. + apply alli_ext => i d. + symmetry. apply on_free_vars_decl_map. + intros. apply on_free_vars_subst_instance. +Qed. + +Lemma on_free_vars_map2_cstr_args p bctx ctx : + #|bctx| = #|ctx| -> + on_free_vars_ctx p ctx = + on_free_vars_ctx p (map2 set_binder_name bctx ctx). +Proof. + rewrite /on_free_vars_ctx. + induction ctx as [|d ctx] in bctx |- *; simpl; auto. + - destruct bctx; reflexivity. + - destruct bctx => /= //. + intros [= hlen]. + rewrite alli_app (IHctx bctx) // alli_app. f_equal. + len. rewrite map2_length // hlen. f_equal. +Qed. + + +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. + change #|ctx| with (0 + #|ctx|). + have: (forallb (on_free_vars (shiftnP (0 + #|ctx|) P)) []) by easy. + generalize (@nil term), 0. + induction ctx; intros l n. + - simpl; auto. + - simpl. intros Hl. + destruct a as [? [?|] ?]. + * rewrite Nat.add_succ_r in Hl. + specialize (IHctx _ (S n) Hl). + now rewrite Nat.add_succ_r Nat.add_1_r. + * rewrite Nat.add_succ_r Nat.add_1_r. eapply (IHctx _ (S n)). + rewrite -[_ + _](Nat.add_succ_r n #|ctx|) /= Hl. + rewrite /shiftnP. + nat_compare_specs => /= //. +Qed. + +(** This is less precise than the strengthenP lemma above *) +Lemma on_free_vars_lift_impl (p : nat -> bool) (n k : nat) (t : term) : + on_free_vars (shiftnP k p) t -> + on_free_vars (shiftnP (n + k) p) (lift n k t). +Proof. + rewrite -(on_free_vars_lift _ n k t). + eapply on_free_vars_impl. + intros i. + rewrite /shiftnP /strengthenP. + repeat nat_compare_specs => /= //. + now replace (i - n - k) with (i - (n + k)) by lia. +Qed. + + +Lemma foron_free_vars_extended_subst brctx p : + on_free_vars_ctx p brctx -> + forallb (on_free_vars (shiftnP (context_assumptions brctx) p)) + (extended_subst brctx 0). +Proof. + move/on_free_vars_extended_subst. + eapply forallb_impl. + intros x hin. + rewrite Nat.add_0_r shiftnP0. + eapply on_free_vars_impl. + intros i. rewrite /orP /strengthenP /= /occ_betweenP /shiftnP. + repeat nat_compare_specs => /= //. + now rewrite orb_false_r. +Qed. + +From MetaCoq.PCUIC Require Import PCUICReduction. + +Lemma on_free_vars_fix_subst P mfix idx : + on_free_vars P (tFix mfix idx) -> + forallb (on_free_vars P) (fix_subst mfix). +Proof. + move=> /=; rewrite /fix_subst. + intros hmfix. generalize hmfix. + induction mfix at 2 4; simpl; auto. + move/andP => [ha hm]. rewrite IHm // andb_true_r //. +Qed. + +Lemma on_free_vars_unfold_fix P mfix idx narg fn : + unfold_fix mfix idx = Some (narg, fn) -> + on_free_vars P (tFix mfix idx) -> + on_free_vars P fn. +Proof. + rewrite /unfold_fix. + destruct nth_error eqn:hnth => // [=] _ <- /=. + intros hmfix; generalize hmfix. + move/forallb_All/(nth_error_all hnth) => /andP [] _ Hbody. + eapply on_free_vars_subst; len => //. + eapply (on_free_vars_fix_subst _ _ idx) => //. +Qed. + +Lemma on_free_vars_cofix_subst P mfix idx : + on_free_vars P (tCoFix mfix idx) -> + forallb (on_free_vars P) (cofix_subst mfix). +Proof. + move=> /=; rewrite /cofix_subst. + intros hmfix. generalize hmfix. + induction mfix at 2 4; simpl; auto. + move/andP => [ha hm]. rewrite IHm // andb_true_r //. +Qed. + +Lemma on_free_vars_unfold_cofix P mfix idx narg fn : + unfold_cofix mfix idx = Some (narg, fn) -> + on_free_vars P (tCoFix mfix idx) -> + on_free_vars P fn. +Proof. + rewrite /unfold_cofix. + destruct nth_error eqn:hnth => // [=] _ <- /=. + intros hmfix; generalize hmfix. + move/forallb_All/(nth_error_all hnth) => /andP [] _ Hbody. + eapply on_free_vars_subst; len => //. + eapply (on_free_vars_cofix_subst _ _ idx) => //. +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 => /= //. + - assert (n = i + 1) as -> by lia. + now replace (i + 1 - (i + 1)) with 0 by lia. + - lia_f_equal. +Qed. + +Lemma on_ctx_free_vars_concat P Γ Δ : + on_ctx_free_vars P Γ -> + on_ctx_free_vars (shiftnP #|Δ| P) Δ -> + on_ctx_free_vars (shiftnP #|Δ| P) (Γ ,,, Δ). +Proof. + rewrite /on_ctx_free_vars alli_app. + move=> hΓ -> /=; rewrite alli_shiftn. + eapply alli_impl; tea => i d /=. + simpl. + rewrite {1}/shiftnP. nat_compare_specs. + replace (#|Δ| + i - #|Δ|) with i by lia. + destruct (P i) eqn:pi => /= //. + apply on_free_vars_decl_impl => k. + rewrite /addnP /shiftnP. + nat_compare_specs. + now replace (k + S (#|Δ| + i) - #|Δ|) with (k + S i) by lia. +Qed. + +Lemma on_ctx_free_vars_tip P d : on_ctx_free_vars P [d] = P 0 ==> on_free_vars_decl (addnP 1 P) d. +Proof. + now rewrite /on_ctx_free_vars /= /= andb_true_r. +Qed. + +Lemma shiftnPS n P : shiftnP (S n) P n. +Proof. + rewrite /shiftnP /=. + now nat_compare_specs. +Qed. + +Lemma on_ctx_free_vars_extend P Γ Δ : + on_free_vars_ctx P Δ -> + on_ctx_free_vars P Γ -> + on_ctx_free_vars (shiftnP #|Δ| P) (Γ ,,, Δ). +Proof. + intros hΔ hΓ. + apply on_ctx_free_vars_concat => //. + revert P Γ hΓ hΔ. + induction Δ using rev_ind; simpl; auto; intros P Γ hΓ. + rewrite /on_ctx_free_vars /on_free_vars_ctx List.rev_app_distr /= shiftnP0. + rewrite alli_shift. setoid_rewrite Nat.add_comm. setoid_rewrite <- shiftnP_add. + move/andP=> [] hx hΔ. + rewrite alli_app /= andb_true_r Nat.add_0_r; len. + rewrite Nat.add_comm. + rewrite addnP_shiftnP. + specialize (IHΔ (shiftnP 1 P) (Γ ,, x)). + forward IHΔ. + * simpl. apply (on_ctx_free_vars_concat _ _ [x]) => //. + simpl. + now rewrite on_ctx_free_vars_tip {1}/shiftnP /= addnP_shiftnP. + * specialize (IHΔ hΔ). + rewrite shiftnPS /= hx andb_true_r. + rewrite /on_ctx_free_vars in IHΔ. + rewrite -(Nat.add_1_r #|Δ|). + setoid_rewrite <-(shiftnP_add). + now setoid_rewrite <- (shiftnP_add _ _ _ _). +Qed. + +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 -> + on_free_vars_ctx P (fix_context mfix). +Proof. + intros a. + assert (All (fun x => on_free_vars P x.(dtype)) mfix). + { solve_all. now move/andP: H=> []. } clear a. + induction mfix using rev_ind; simpl; auto. + rewrite /fix_context /= mapi_app List.rev_app_distr /=. + rewrite /on_free_vars_ctx /= alli_app. len. + rewrite andb_true_r. + eapply All_app in X as [X Hx]. + depelim Hx. clear Hx. + specialize (IHmfix X). + rewrite /on_free_vars_ctx in IHmfix. + rewrite IHmfix /= /on_free_vars_decl /test_decl /= /=. + apply on_free_vars_lift0. + now rewrite addnP_shiftnP. +Qed. + +Lemma test_context_k_on_free_vars_ctx P ctx : + test_context_k (fun k => on_free_vars (shiftnP k P)) 0 ctx = + on_free_vars_ctx P ctx. +Proof. + now rewrite test_context_k_eq. +Qed. + +(** This shows preservation by reduction of closed/noccur_between predicates + necessary to prove exchange and strengthening lemmas. *) +Lemma red1_on_free_vars {cf} {P : nat -> bool} {Σ Γ u v} {wfΣ : wf Σ} : + on_free_vars P u -> + on_ctx_free_vars P Γ -> + red1 Σ Γ u v -> + on_free_vars P v. +Proof. + intros hav hctx h. + induction h using red1_ind_all in P, hav, hctx |- *. + all: try solve [ + simpl ; constructor ; eapply IHh ; + try (simpl in hav; rtoProp); + try eapply urenaming_vass ; + try eapply urenaming_vdef ; + assumption + ]. + all:simpl in hav |- *; try toAll. + all:try move/and3P: hav => [h1 h2 h3]. + all:try (move/andP: hav => [] /andP [] h1 h2 h3). + all:try move/andP: hav => [h1 h2]. + all:try move/andP: h3 => [] h3 h4. + all:try move/andP: h4 => [] h4 h5. + all:try rewrite ?h1 // ?h2 // ?h3 // ?h4 // ?IHh /= // ?andb_true_r. + all:try eapply on_free_vars_subst1; eauto. + - destruct (nth_error Γ i) eqn:hnth => //. + simpl in H. noconf H. + epose proof (nth_error_on_free_vars_ctx P 0 Γ i c). + forward H0. { now rewrite addnP0. } + specialize (H0 hav hnth). simpl in H0. + rewrite /test_decl H in H0. + rewrite on_free_vars_lift0 //. + now move/andP: H0 => [] /=. + - rewrite /iota_red. + rename h5 into hbrs. + move: h4. rewrite on_free_vars_mkApps => /andP [] /= _ hargs. + apply on_free_vars_subst. + { rewrite forallb_rev forallb_skipn //. } + len. + rewrite H0. + rewrite /expand_lets /expand_lets_k /=. + eapply forallb_nth_error in hbrs. + erewrite H in hbrs; simpl in hbrs. + move/andP: hbrs => [] hbr hbody. + eapply on_free_vars_subst. + * eapply foron_free_vars_extended_subst; eauto. + now rewrite test_context_k_on_free_vars_ctx in hbr. + * rewrite extended_subst_length. + rewrite shiftnP_add. + eapply on_free_vars_lift_impl in hbody. + now rewrite Nat.add_comm. + - rewrite !on_free_vars_mkApps in hav |- *. + rtoProp. + 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. + now rewrite hcofix. + - move: hav; rewrite !on_free_vars_mkApps => /andP [] hcofix ->. + eapply on_free_vars_unfold_cofix in H as ->; eauto. + - eapply closed_on_free_vars. rewrite closedn_subst_instance. + eapply declared_constant_closed_body; eauto. + - move: hav; rewrite on_free_vars_mkApps /=. + now move/(nth_error_forallb H). + - rewrite (on_ctx_free_vars_concat _ _ [_]) // /= + on_ctx_free_vars_tip /= addnP_shiftnP /on_free_vars_decl + /test_decl /= //. + - rewrite (on_ctx_free_vars_concat _ _ [_]) // + on_ctx_free_vars_tip /= addnP_shiftnP /on_free_vars_decl /test_decl /= h2 /= + /foroptb /= h1 //. + - solve_all. + eapply OnOne2_impl_All_r; eauto. solve_all. + - erewrite <-(len X); rewrite h2 /= h5 andb_true_r. + eapply OnOne2_local_env_test_context_k; tea; auto. + { clear -hctx. intros. eapply on_one_decl_test_decl; tea; simpl; + intuition eauto. eapply H1 => //. + rewrite Nat.add_0_r. eapply on_ctx_free_vars_extend => //. + now rewrite test_context_k_on_free_vars_ctx in H. } + - eapply on_ctx_free_vars_extend => //. + now rewrite test_context_k_on_free_vars_ctx in h3. + - toAll. + clear -hctx X h5. + eapply OnOne2_All_mix_left in X; tea. + toAll. eapply OnOne2_impl_All_r in X; tea; solve_all; rewrite -?b0 //. + * eapply b1 => //. + rewrite test_context_k_on_free_vars_ctx in H0. + eapply on_ctx_free_vars_extend => //. + * eapply OnOne2_local_env_test_context_k; tea; auto. + clear -hctx. intros. eapply on_one_decl_test_decl; tea; simpl; + intuition eauto. eapply H1 => //. + rewrite Nat.add_0_r. eapply on_ctx_free_vars_extend => //. + now rewrite test_context_k_on_free_vars_ctx in H. + * now rewrite -(length_of a). + - rewrite (on_ctx_free_vars_concat _ _ [_]) // /= + on_ctx_free_vars_tip /= addnP_shiftnP /on_free_vars_decl /test_decl /= h1 /= //. + - toAll. eapply OnOne2_impl_All_r; eauto; solve_all. + - toAll. unfold test_def. + rewrite -(OnOne2_length X). + eapply OnOne2_impl_All_r; eauto; solve_all. + destruct x, y; noconf b; simpl in *. rtoProp; solve_all. + - toAll. unfold test_def in *. rewrite -(OnOne2_length X). + eapply OnOne2_impl_All_r; eauto; solve_all; + destruct x, y; noconf b; simpl in *; rtoProp; solve_all. + apply b0 => //. + rewrite -(fix_context_length mfix0). + eapply on_ctx_free_vars_extend => //. + now apply on_free_vars_fix_context. + - toAll. unfold test_def. + rewrite -(OnOne2_length X). + eapply OnOne2_impl_All_r; eauto; solve_all. + destruct x, y; noconf b; simpl in *. rtoProp; solve_all. + - toAll. unfold test_def in *. rewrite -(OnOne2_length X). + eapply OnOne2_impl_All_r; eauto; solve_all; + destruct x, y; noconf b; simpl in *; rtoProp; solve_all. + apply b0 => //. + rewrite -(fix_context_length mfix0). + eapply on_ctx_free_vars_extend => //. + now apply on_free_vars_fix_context. +Qed. + +(* Not necessary for the above lemma, but still useful at some point presumably, + e.g. for strenghtening *) + +Lemma on_free_vars_case_predicate_context {cf} {Σ} {wfΣ : wf Σ} {P ci mdecl idecl p} : + let pctx := case_predicate_context ci mdecl idecl p in + declared_inductive Σ ci mdecl idecl -> + wf_predicate mdecl idecl p -> + forallb (on_free_vars P) (pparams p) -> + on_free_vars (shiftnP #|pcontext p| P) (preturn p) -> + on_free_vars_ctx P pctx. +Proof. + intros pctx decli wfp wfb havp. + rewrite /pctx /case_predicate_context /case_predicate_context_gen + /pre_case_predicate_context_gen. + set (ibinder := {| decl_name := _ |}). + rewrite -on_free_vars_map2_cstr_args /=; len. + { eapply (wf_predicate_length_pcontext wfp). } + rewrite alli_app; len; rewrite andb_true_r. + apply andb_true_iff. split. + - rewrite -/(on_free_vars_ctx P _). + rewrite (on_free_vars_ctx_all_term _ _ Universe.type0). + rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). + apply on_free_vars_subst. + { rewrite forallb_rev => //. } + rewrite -on_free_vars_ctx_all_term. + rewrite on_free_vars_subst_instance_context. + rewrite (on_free_vars_ctx_all_term _ _ (Universe.type0)). + rewrite -(expand_lets_it_mkProd_or_LetIn _ _ 0 (tSort _)). + eapply on_free_vars_expand_lets_k; len. + * rewrite (wf_predicate_length_pars wfp). + apply (declared_minductive_ind_npars decli). + * eapply closed_ctx_on_free_vars. + apply (declared_inductive_closed_params decli). + * eapply on_free_vars_impl; cycle 1. + { rewrite <- on_free_vars_ctx_all_term. + instantiate (1 := closedP #|mdecl.(ind_params)| xpredT). + eapply closedn_ctx_on_free_vars. + move: (declared_inductive_closed_pars_indices wfΣ decli). + now rewrite closedn_ctx_app => /andP []. } + intros i'. + rewrite /substP /= /closedP /shiftnP. len. + now repeat nat_compare_specs => /= //. + - rewrite /on_free_vars_decl /ibinder /test_decl /= /foroptb /=. + rewrite on_free_vars_mkApps /= forallb_app /=. + rewrite on_free_vars_to_extended_list /= andb_true_r. + rewrite -/(is_true _). + rewrite forallb_map. unshelve eapply (forallb_impl _ _ _ _ wfb). + 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 -> + wf_predicate mdecl idecl p -> + wf_branch cdecl br -> + forallb (on_free_vars P) (pparams p) -> + on_free_vars_ctx P brctx. +Proof. + intros brctx decli wfp wfb havp. + rewrite /brctx /case_branch_context /case_branch_context_gen. + rewrite (on_free_vars_ctx_all_term _ _ Universe.type0). + rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). + apply on_free_vars_subst => //. + { rewrite forallb_rev //. } + rewrite -(expand_lets_it_mkProd_or_LetIn _ _ 0 (tSort _)). + eapply on_free_vars_expand_lets_k; len. + * rewrite (wf_predicate_length_pars wfp). + apply (declared_minductive_ind_npars decli). + * eapply closed_ctx_on_free_vars. + rewrite closedn_subst_instance_context. + apply (declared_inductive_closed_params decli). + * rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). + eapply on_free_vars_impl; cycle 1. + + eapply (on_free_vars_subst_gen _ P). + { eapply on_free_vars_terms_inds. } + rewrite -on_free_vars_ctx_all_term. + rewrite on_free_vars_subst_instance_context. + rewrite -on_free_vars_map2_cstr_args. + { len. apply (wf_branch_length wfb). } + instantiate (1 := closedP (#|mdecl.(ind_bodies)| + #|mdecl.(ind_params)|) xpredT). + eapply closedn_ctx_on_free_vars. + now move/andP: (declared_constructor_closed wfΣ decli) => [] /andP []. + + intros i'. + rewrite /substP /= /closedP /shiftnP. len. + now repeat nat_compare_specs => /= //. +Qed. + + +(* +Lemma typing_on_free_vars : env_prop + (fun Σ Γ t A => + forall P, + on_free_vars (closedP #|Γ| P) t -> + ∑ Af, (red Σ Γ A Af * on_free_vars (closedP #|Γ| P) Af)) + (fun Σ Γ => + All_local_env + (lift_typing (fun (Σ : global_env_ext) (Γ : context) (t T : term) + => + forall P, + on_free_vars (closedP #|Γ| P) t -> + ∑ Af, (red1 Σ Γ T Af * on_free_vars (closedP #|Γ| P) Af)) Σ) Γ). +Proof. + + apply typing_ind_env. + 7:{ + - intros Σ wfΣ Γ wfΓ t na A B a u X hty ihty ht iht hu ihu P. + simpl. move/andP=> [havt havs]. + destruct (iht _ havt) as [ty [redty hav]]. + eapply invert_red_prod in redty as [A' [B' [[eq redA] redB]]]. subst ty. + move: hav => /= /andP [hA' hB']. + eexists (B' {0 := a}); split. 1:admit. + eapply on_free_vars_subst=> /=; rewrite ?havs //. } + 2:{ - intros Σ wfΣ Γ wfΓ n decl isdecl ihΓ P. + simpl in * => hn. + eexists; split; eauto. + eapply (nth_error_All_local_env (n:=n)) in ihΓ. + 2:{ eapply nth_error_Some_length in isdecl; eauto. } + rewrite isdecl in ihΓ. simpl in ihΓ. rewrite /closedP in hn. + move: hn; nat_compare_specs => //. intros pn. + move: ihΓ. unfold on_local_decl. + destruct decl_body eqn:db; + unfold lift_typing; simpl. + * intros ih. specialize (ih P). + rewrite skipn_length // in ih. + rewrite on_free_vars_lift0 //. + admit. + * admit. } + + 13:{ + - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht htB ihB cum P hav. + specialize (iht _ hav) as [Af [redAf havaf]]. + admit. (* certainly provable *) + } +Admitted.*) + +(* +Lemma typing_rename_prop' : env_prop + (fun Σ Γ t A => + forall Δ f, + renaming (closedP #|Γ| xpredT) Σ Δ Γ f -> + Σ ;;; Δ |- rename f t : rename f A) + (fun Σ Γ => + All_local_env + (lift_typing (fun (Σ : global_env_ext) (Γ : context) (t T : term) + => + forall P (Δ : PCUICEnvironment.context) (f : nat -> nat), + renaming (closedP #|Γ| P) Σ Δ Γ f -> + Σ;;; Δ |- rename f t : rename f T) Σ) Γ). +Proof. + red. intros. + destruct (typing_rename_prop Σ wfΣ Γ t T ty) as [? []]. + split. + - eapply on_global_env_impl. 2:eapply f. + intros. + red in X0. destruct T0; red. + * intros. + eapply (X0 xpredT). + + + + destruct X. *) \ No newline at end of file diff --git a/pcuic/theories/PCUICParallelReduction.v b/pcuic/theories/PCUICParallelReduction.v index db1043884..10ccefc01 100644 --- a/pcuic/theories/PCUICParallelReduction.v +++ b/pcuic/theories/PCUICParallelReduction.v @@ -1,157 +1,22 @@ (* Distributed under the terms of the MIT license. *) -Require Import CRelationClasses. +Require Import RelationClasses CRelationClasses. From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICUtils PCUICAst PCUICSize - PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICWeakening PCUICSubstitution. +From MetaCoq.PCUIC Require Import PCUICUtils PCUICAst PCUICAstUtils PCUICSize PCUICCases + PCUICLiftSubst PCUICUnivSubst PCUICReduction PCUICTyping + PCUICSigmaCalculus PCUICWeakeningEnv PCUICInduction + PCUICRename PCUICInst + PCUICWeakening PCUICSubstitution. -Require Import ssreflect. +Require Import ssreflect ssrbool. From Equations Require Import Equations. - Local Set Keyed Unification. -Derive NoConfusion for term. -Derive Subterm for term. -Derive Signature NoConfusion for All All2. - Ltac simplify_IH_hyps := repeat match goal with [ H : _ |- _ ] => eqns_specialize_eqs H end. -Lemma size_lift n k t : size (lift n k t) = size t. -Proof. - revert n k t. - fix size_list 3. - destruct t; simpl; rewrite ?list_size_map_hom; try lia. - intros. auto. - now rewrite !size_list. - now rewrite !size_list. - now rewrite !size_list. - now rewrite !size_list. - intros. - destruct x. simpl. now rewrite size_list. - now rewrite !size_list. - now rewrite !size_list. - unfold mfixpoint_size. - rewrite list_size_map_hom. intros. - simpl. destruct x. simpl. unfold def_size. simpl. - now rewrite !size_list. - reflexivity. - unfold mfixpoint_size. - rewrite list_size_map_hom. intros. - simpl. destruct x. unfold def_size; simpl. - now rewrite !size_list. - reflexivity. -Qed. - -Require Import RelationClasses. - -Arguments All {A} P%type _. - -Lemma All_pair {A} (P Q : A -> Type) l : - All (fun x => P x * Q x)%type l <~> (All P l * All Q l). -Proof. - split. induction 1; intuition auto. - move=> [] Hl Hl'. induction Hl; depelim Hl'; intuition auto. -Qed. - -Definition on_local_decl (P : context -> term -> Type) - (Γ : context) (t : term) (T : option term) := - match T with - | Some T => (P Γ t * P Γ T)%type - | None => P Γ t - end. - -(* TODO: remove List.rev *) -Lemma list_size_rev {A} size (l : list A) - : list_size size (List.rev l) = list_size size l. -Proof. - induction l; simpl. reflexivity. - rewrite list_size_app IHl; cbn; lia. -Qed. - -Lemma term_forall_ctx_list_ind : - forall (P : context -> term -> Type), - - (forall Γ (n : nat), P Γ (tRel n)) -> - (forall Γ (i : ident), P Γ (tVar i)) -> - (forall Γ (n : nat) (l : list term), All (P Γ) l -> P Γ (tEvar n l)) -> - (forall Γ s, P Γ (tSort s)) -> - (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P (vass n t :: Γ) t0 -> P Γ (tProd n t t0)) -> - (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), 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 Γ (p : inductive * nat) (t : term), - P Γ t -> forall t0 : term, P Γ t0 -> forall l : list (nat * term), - tCaseBrsProp (P Γ) l -> P Γ (tCase p t t0 l)) -> - (forall Γ (s : projection) (t : term), P Γ t -> P Γ (tProj s t)) -> - (forall Γ (m : mfixpoint term) (n : nat), - All_local_env (on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) -> - tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tFix m n)) -> - (forall Γ (m : mfixpoint term) (n : nat), - All_local_env (on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) -> - tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tCoFix m n)) -> - (forall Γ p, P Γ (tPrim p)) -> - forall Γ (t : term), P Γ t. -Proof. - intros. - revert Γ t. set(foo:=CoreTactics.the_end_of_the_section). intros. - Subterm.rec_wf_rel aux t (precompose lt size). simpl. clear H1. - assert (auxl : forall Γ {A} (l : list A) (f : A -> term), list_size (fun x => size (f x)) l < size pr0 -> - All (fun x => P Γ (f x)) l). - { induction l; constructor. eapply aux. red. simpl in H. lia. apply IHl. simpl in H. lia. } - assert (forall mfix, context_size size (fix_context mfix) <= mfixpoint_size size mfix). - { induction mfix. simpl. auto. simpl. unfold fix_context. - unfold context_size. - rewrite list_size_rev /=. cbn. - rewrite size_lift. unfold context_size in IHmfix. - epose (list_size_mapi_rec_le (def_size size) (decl_size size) mfix - (fun (i : nat) (d : def term) => vass (dname d) ((lift0 i) (dtype d))) 1). - forward l. intros. destruct x; cbn; rewrite size_lift. lia. - unfold def_size, mfixpoint_size. lia. } - assert (auxl' : forall Γ mfix, - mfixpoint_size size mfix < size pr0 -> - All_local_env (on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context mfix)). - { move=> Γ mfix H0. - move: (fix_context mfix) {H0} (le_lt_trans _ _ _ (H mfix) H0). - induction fix_context; cbn. - - constructor. - - case: a => [na [b|] ty] /=; rewrite {1}/decl_size /context_size /= => Hlt; constructor; auto. - + eapply IHfix_context. unfold context_size. lia. - + simpl. apply aux. red. lia. - + simpl. split. - * apply aux. red. lia. - * apply aux; red; lia. - + apply IHfix_context; unfold context_size; lia. - + apply aux. red. lia. } - assert (forall m, list_size (fun x : def term => size (dtype x)) m < S (mfixpoint_size size m)). - { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } - assert (forall m, list_size (fun x : def term => size (dbody x)) m < S (mfixpoint_size size m)). - { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } - - move aux at top. move auxl at top. move auxl' at top. - - !destruct pr0; eauto; - try match reverse goal with - |- context [tFix _ _] => idtac - | H : _ |- _ => solve [apply H; (eapply aux || eapply auxl); red; simpl; try lia] - end. - - eapply X12; try (apply aux; red; simpl; lia). - apply auxl'. simpl. lia. - red. apply All_pair. split; apply auxl; simpl; auto. - - eapply X13; try (apply aux; red; simpl; lia). - apply auxl'. simpl. lia. - red. apply All_pair. split; apply auxl; simpl; auto. - -Defined. - (** All2 lemmas *) Definition All2_prop_eq Γ Γ' {A B} (f : A -> term) (g : A -> B) (rel : forall (Γ Γ' : context) (t t' : term), Type) := @@ -172,6 +37,17 @@ Proof. apply aux; apply r. apply IHAll2. Defined. +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) -> + All2 (Q par par') l l'. +Proof. + intros H aux. + induction H; constructor. unfold on_Trel in *. + apply aux; apply r. apply IHAll2. +Defined. + Lemma All2_All2_prop_eq {A B} {P Q : context -> context -> term -> term -> Type} {par par'} {f : A -> term} {g : A -> B} {l l' : list A} : All2 (on_Trel_eq (P par par') f g) l l' -> @@ -213,93 +89,84 @@ Defined. (* apply aux. destruct r. apply p. apply aux. apply r. apply IHAll2. *) (* Defined. *) -Section All2_local_env. +Section All2_fold. - Definition on_decl_over (P : context -> context -> term -> term -> Type) Γ Γ' := + Definition on_decls_over (P : context -> context -> term -> term -> Type) Γ Γ' := fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ'). - Definition All2_local_env_over P Γ Γ' := All2_local_env (on_decl (on_decl_over P Γ Γ')). + Definition All2_fold_over P Γ Γ' := All2_fold (on_decls (on_decls_over P Γ Γ')). - Lemma All2_local_env_impl {P Q : context -> context -> term -> term -> Type} {par par'} : - All2_local_env (on_decl P) par par' -> + (** Do not change this definition as it is used in a raw fixpoint so should preserve + the guard condition. *) + Lemma All2_fold_impl {P Q : context -> context -> term -> term -> Type} {par par'} : + on_contexts P par par' -> (forall par par' x y, P par par' x y -> Q par par' x y) -> - All2_local_env (on_decl Q) par par'. + on_contexts Q par par'. Proof. intros H aux. - induction H; constructor. auto. red in p. assumption. apply aux, p. - apply IHAll2_local_env. red. assumption. split. - apply aux. apply p. apply aux. apply p. + induction H; constructor; tas. + destruct p; constructor. + apply aux, p. apply aux, p. apply aux, p0. Defined. - Lemma All2_local_env_app_inv : + Lemma All2_fold_impl_ind {P Q : context -> context -> term -> term -> Type} {par par'} : + on_contexts P par par' -> + (forall par par' x y, + on_contexts Q par par' -> + P par par' x y -> Q par par' x y) -> + on_contexts Q par par'. + Proof. + intros H aux. + induction H; constructor; auto. eapply All_decls_impl; tea. eauto. + Qed. + + Lemma All2_fold_app : forall P (Γ Γ' Γl Γr : context), - All2_local_env (on_decl P) Γ Γl -> - All2_local_env (on_decl (on_decl_over P Γ Γl)) Γ' Γr -> - All2_local_env (on_decl P) (Γ ,,, Γ') (Γl ,,, Γr). + on_contexts P Γ Γl -> + on_contexts (on_decls_over P Γ Γl) Γ' Γr -> + on_contexts P (Γ ,,, Γ') (Γl ,,, Γr). Proof. - induction 2; auto. - - simpl. constructor; auto. - - simpl. constructor; auto. + induction 2; auto. simpl. constructor; auto. Qed. - Lemma All2_local_env_length {P l l'} : @All2_local_env P l l' -> #|l| = #|l'|. - Proof. induction 1; simpl; auto. Qed. + Lemma All2_fold_length {P l l'} : All2_fold P l l' -> #|l| = #|l'|. + Proof. induction 1; simpl; auto; lia. Qed. + Global Instance All2_fold_has_length P l l' : + HasLen (All2_fold P l l') #|l| #|l'|. + Proof. red. apply All2_fold_length. Qed. Hint Extern 20 (#|?X| = #|?Y|) => match goal with - [ H : All2_local_env _ ?X ?Y |- _ ] => apply (All2_local_env_length H) - | [ H : All2_local_env _ ?Y ?X |- _ ] => symmetry; apply (All2_local_env_length H) - | [ H : All2_local_env_over _ _ _ ?X ?Y |- _ ] => apply (All2_local_env_length H) - | [ H : All2_local_env_over _ _ _ ?Y ?X |- _ ] => symmetry; apply (All2_local_env_length H) + [ H : All2_fold _ ?X ?Y |- _ ] => apply (All2_fold_length H) + | [ H : All2_fold _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H) + | [ H : All2_fold_over _ _ _ ?X ?Y |- _ ] => apply (All2_fold_length H) + | [ H : All2_fold_over _ _ _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H) end : pcuic. Ltac pcuic := eauto with pcuic. - Derive Signature for All2_local_env. + Derive Signature for All2_fold. - Lemma All2_local_env_app': + Lemma All2_fold_app': forall P (Γ Γ' Γ'' : context), - All2_local_env (on_decl P) (Γ ,,, Γ') Γ'' -> + on_contexts P (Γ ,,, Γ') Γ'' -> ∑ Γl Γr, (Γ'' = Γl ,,, Γr) /\ #|Γ'| = #|Γr| /\ #|Γ| = #|Γl|. Proof. intros *. revert Γ''. induction Γ'. simpl. intros. - exists Γ'', []. intuition auto. eapply (All2_local_env_length X). + exists Γ'', []. intuition auto. eapply (All2_fold_length X). intros. unfold app_context in X. depelim X. destruct (IHΓ' _ X) as [Γl [Γr [Heq HeqΓ]]]. subst Γ'0. - eexists Γl, (Γr,, vass _ t'). simpl. intuition eauto. - destruct (IHΓ' _ X) as [Γl [Γr [Heq HeqΓ]]]. subst Γ'0. - eexists Γl, (Γr,, vdef _ b' t'). simpl. intuition eauto. + eexists Γl, (Γr,, d'). simpl. intuition eauto. lia. Qed. - Lemma app_inj_length_r {A} (l l' r r' : list A) : - app l r = app l' r' -> #|r| = #|r'| -> l = l' /\ r = r'. - Proof. - induction r in l, l', r' |- *. destruct r'; intros; simpl in *; intuition auto; try discriminate. - now rewrite !app_nil_r in H. - intros. destruct r'; try discriminate. - simpl in H. - change (l ++ a :: r) with (l ++ [a] ++ r) in H. - change (l' ++ a0 :: r') with (l' ++ [a0] ++ r') in H. - rewrite !app_assoc in H. destruct (IHr _ _ _ H). now noconf H0. - subst. now apply app_inj_tail in H1 as [-> ->]. - Qed. - - Lemma app_inj_length_l {A} (l l' r r' : list A) : - app l r = app l' r' -> #|l| = #|l'| -> l = l' /\ r = r'. - Proof. - induction l in r, r', l' |- *. destruct l'; intros; simpl in *; intuition auto; try discriminate. - intros. destruct l'; try discriminate. simpl in *. noconf H. - specialize (IHl _ _ _ H). forward IHl; intuition congruence. - Qed. - - Lemma All2_local_env_app_ex: + Lemma All2_fold_app_ex: forall P (Γ Γ' Γ'' : context), - All2_local_env (on_decl P) (Γ ,,, Γ') Γ'' -> + on_contexts P (Γ ,,, Γ') Γ'' -> ∑ Γl Γr, (Γ'' = Γl ,,, Γr) * - All2_local_env - (on_decl P) - Γ Γl * All2_local_env (on_decl (fun Δ Δ' => P (Γ ,,, Δ) (Γl ,,, Δ'))) Γ' Γr. + All2_fold + (on_decls P) + Γ Γl * All2_fold (on_decls (fun Δ Δ' => P (Γ ,,, Δ) (Γl ,,, Δ'))) Γ' Γr. Proof. intros *. revert Γ''. induction Γ'. simpl. intros. @@ -308,76 +175,94 @@ Section All2_local_env. destruct (IHΓ' _ X) as [Γl [Γr [[HeqΓ H2] H3]]]. subst. eexists _, _. intuition eauto. unfold snoc, app_context. now rewrite app_comm_cons. constructor; auto. - destruct (IHΓ' _ X) as [Γl [Γr [[HeqΓ H2] H3]]]. subst. - eexists _, _. intuition eauto. unfold snoc, app_context. - now rewrite app_comm_cons. constructor; auto. Qed. - Lemma All2_local_env_app : + Lemma All2_fold_app_inv : forall P (Γ Γ' Γl Γr : context), - All2_local_env (on_decl P) (Γ ,,, Γ') (Γl ,,, Γr) -> + on_contexts P (Γ ,,, Γ') (Γl ,,, Γr) -> #|Γ| = #|Γl| -> - All2_local_env (on_decl P) Γ Γl * All2_local_env (on_decl (fun Δ Δ' => P (Γ ,,, Δ) (Γl ,,, Δ'))) Γ' Γr. + on_contexts P Γ Γl * + on_contexts (fun Δ Δ' => P (Γ ,,, Δ) (Γl ,,, Δ')) Γ' Γr. Proof. intros *. intros. pose proof X as X'. - apply All2_local_env_app' in X as [Γl' [Γr' ?]]. + apply All2_fold_app' in X as [Γl' [Γr' ?]]. destruct a as [? [? ?]]. - apply All2_local_env_app_ex in X' as [Γl2' [Γr2' [[? ?] ?]]]. + apply All2_fold_app_ex in X' as [Γl2' [Γr2' [[? ?] ?]]]. subst; rename_all_hyps. unfold app_context in heq_app_context. eapply app_inj_length_r in heq_app_context; try lia. destruct heq_app_context. subst. unfold app_context in heq_app_context0. eapply app_inj_length_r in heq_app_context0; try lia. intuition subst; auto. - pose proof (All2_local_env_length a). lia. + pose proof (All2_fold_length a). lia. Qed. - + Lemma nth_error_pred1_ctx {P} {Γ Δ} i body' : - All2_local_env (on_decl P) Γ Δ -> + on_contexts P Γ Δ -> option_map decl_body (nth_error Δ i) = Some (Some body') -> { body & (option_map decl_body (nth_error Γ i) = Some (Some body)) * P (skipn (S i) Γ) (skipn (S i) Δ) body body' }%type. Proof. intros Hpred. revert i body'. induction Hpred; destruct i; try discriminate; auto; !intros. - simpl in heq_option_map. specialize (IHHpred _ _ heq_option_map) as [body [Heq Hpred']]. - intuition eauto. - noconf heq_option_map. exists b. intuition eauto. cbv. apply p. - simpl in heq_option_map. specialize (IHHpred _ _ heq_option_map) as [body [Heq Hpred']]. + simpl in heq_option_map. depelim p => //. + noconf heq_option_map. exists b. intuition eauto. + specialize (IHHpred _ _ heq_option_map) as [body [Heq Hpred']]. intuition eauto. Qed. Lemma nth_error_pred1_ctx_l {P} {Γ Δ} i body : - All2_local_env (on_decl P) Γ Δ -> + on_contexts P Γ Δ -> option_map decl_body (nth_error Γ i) = Some (Some body) -> { body' & (option_map decl_body (nth_error Δ i) = Some (Some body')) * P (skipn (S i) Γ) (skipn (S i) Δ) body body' }%type. Proof. intros Hpred. revert i body. induction Hpred; destruct i; try discriminate; auto; !intros. - simpl in heq_option_map. specialize (IHHpred _ _ heq_option_map) as [body' [Heq Hpred']]. - intuition eauto. - noconf heq_option_map. exists b'. intuition eauto. cbv. apply p. + depelim p => //. + noconf heq_option_map. exists b'. intuition eauto. simpl in heq_option_map. specialize (IHHpred _ _ heq_option_map) as [body' [Heq Hpred']]. intuition eauto. Qed. - Lemma All2_local_env_over_app P {Γ0 Δ Γ'' Δ''} : - All2_local_env (on_decl P) Γ0 Δ -> - All2_local_env_over P Γ0 Δ Γ'' Δ'' -> - All2_local_env (on_decl P) (Γ0 ,,, Γ'') (Δ ,,, Δ''). + Lemma All2_fold_over_app P {Γ0 Δ Γ'' Δ''} : + on_contexts P Γ0 Δ -> + All2_fold_over P Γ0 Δ Γ'' Δ'' -> + on_contexts P (Γ0 ,,, Γ'') (Δ ,,, Δ''). Proof. intros. induction X0; pcuic; constructor; pcuic. Qed. - Lemma All2_local_env_app_left {P Γ Γ' Δ Δ'} : - All2_local_env (on_decl P) (Γ ,,, Δ) (Γ' ,,, Δ') -> #|Γ| = #|Γ'| -> - All2_local_env (on_decl P) Γ Γ'. + Lemma All2_fold_app_inv_left {P Γ Γ' Δ Δ'} : + on_contexts P (Γ ,,, Δ) (Γ' ,,, Δ') -> #|Γ| = #|Γ'| -> + on_contexts P Γ Γ'. Proof. - intros. eapply All2_local_env_app in X; intuition auto. + intros. eapply All2_fold_app_inv in X; intuition auto. Qed. -End All2_local_env. + Lemma All2_fold_mapi P Γ Δ f g : + All2_fold (on_decls + (fun Γ Γ' t t' => + P (mapi_context f Γ) (mapi_context g Γ') (f #|Γ| t) (g #|Γ'| t'))) Γ Δ -> + on_contexts P (mapi_context f Γ) (mapi_context g Δ). + Proof. + induction 1; rewrite /=; constructor; auto. + depelim p; constructor; auto. + Qed. + + Lemma All2_fold_mapi_inv P Γ Δ f g : + on_contexts P (mapi_context f Γ) (mapi_context g Δ) -> + 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. + Qed. + +End All2_fold. Section ParallelReduction. Context (Σ : global_env). @@ -392,6 +277,9 @@ Section ParallelReduction. | _ => false end. + Reserved Notation "'pred1_ctx'" (at level 8). + Reserved Notation "'pred1_ctx_over' Γ Γ'" (at level 200, Γ, Γ' at level 9). + Inductive pred1 (Γ Γ' : context) : term -> term -> Type := (** Reductions *) (** Beta *) @@ -408,26 +296,31 @@ Section ParallelReduction. (** Local variables *) | pred_rel_def_unfold i body : - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> option_map decl_body (nth_error Γ' i) = Some (Some body) -> pred1 Γ Γ' (tRel i) (lift0 (S i) body) | pred_rel_refl i : - All2_local_env (on_decl pred1) Γ Γ' -> - pred1 Γ Γ' (tRel i) (tRel i) + pred1_ctx Γ Γ' -> + pred1 Γ Γ' (tRel i) (tRel i) (** Case *) - | pred_iota ind pars c u args0 args1 p brs0 brs1 : - All2_local_env (on_decl pred1) Γ Γ' -> + | pred_iota ci c u args0 args1 p0 brs0 brs1 br : + pred1_ctx Γ Γ' -> All2 (pred1 Γ Γ') args0 args1 -> - All2 (on_Trel_eq (pred1 Γ Γ') snd fst) brs0 brs1 -> - pred1 Γ Γ' (tCase (ind, pars) p (mkApps (tConstruct ind c u) args0) brs0) - (iota_red pars c args1 brs1) + nth_error brs1 c = Some br -> + #|skipn (ci_npar ci) args1| = context_assumptions br.(bcontext) -> + All2 (fun br br' => + on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (pred1 (Γ ,,, br.(bcontext)) (Γ' ,,, br'.(bcontext))) + bbody br br') brs0 brs1 -> + pred1 Γ Γ' (tCase ci p0 (mkApps (tConstruct ci.(ci_ind) c u) args0) brs0) + (iota_red ci.(ci_npar) args1 br) (** Fix unfolding, with guard *) | pred_fix mfix0 mfix1 idx args0 args1 narg fn : - All2_local_env (on_decl pred1) Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx Γ Γ' -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) pred1 mfix0 mfix1 -> unfold_fix mfix1 idx = Some (narg, fn) -> @@ -436,22 +329,28 @@ Section ParallelReduction. pred1 Γ Γ' (mkApps (tFix mfix0 idx) args0) (mkApps fn args1) (** CoFix-case unfolding *) - | pred_cofix_case ip p0 p1 mfix0 mfix1 idx args0 args1 narg fn brs0 brs1 : - All2_local_env (on_decl pred1) Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + | pred_cofix_case ci p0 p1 mfix0 mfix1 idx args0 args1 narg fn brs0 brs1 : + pred1_ctx Γ Γ' -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) pred1 mfix0 mfix1 -> unfold_cofix mfix1 idx = Some (narg, fn) -> All2 (pred1 Γ Γ') args0 args1 -> - pred1 Γ Γ' p0 p1 -> - All2 (on_Trel_eq (pred1 Γ Γ') snd fst) brs0 brs1 -> - pred1 Γ Γ' (tCase ip p0 (mkApps (tCoFix mfix0 idx) args0) brs0) - (tCase ip p1 (mkApps fn args1) brs1) + All2 (pred1 Γ Γ') p0.(pparams) p1.(pparams) -> + p0.(puinst) = p1.(puinst) -> + on_Trel (pred1_ctx_over Γ Γ') pcontext p0 p1 -> + pred1 (Γ ,,, p0.(pcontext)) (Γ' ,,, p1.(pcontext)) p0.(preturn) p1.(preturn) -> + All2 (fun br br' => + on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (pred1 (Γ ,,, br.(bcontext)) (Γ' ,,, br'.(bcontext))) + bbody br br') brs0 brs1 -> + pred1 Γ Γ' (tCase ci p0 (mkApps (tCoFix mfix0 idx) args0) brs0) + (tCase ci p1 (mkApps fn args1) brs1) (** CoFix-proj unfolding *) | pred_cofix_proj p mfix0 mfix1 idx args0 args1 narg fn : - All2_local_env (on_decl pred1) Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx Γ Γ' -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) pred1 mfix0 mfix1 -> unfold_cofix mfix1 idx = Some (narg, fn) -> @@ -462,17 +361,17 @@ Section ParallelReduction. (** Constant unfolding *) | pred_delta c decl body (isdecl : declared_constant Σ c decl) u : - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> decl.(cst_body) = Some body -> - pred1 Γ Γ' (tConst c u) (subst_instance_constr u body) + pred1 Γ Γ' (tConst c u) (subst_instance u body) | pred_const c u : - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> pred1 Γ Γ' (tConst c u) (tConst c u) (** Proj *) | pred_proj i pars narg u args0 args1 arg1 : - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> All2 (pred1 Γ Γ') args0 args1 -> nth_error args1 (pars + narg) = Some arg1 -> pred1 Γ Γ' (tProj (i, pars, narg) (mkApps (tConstruct i 0 u) args0)) arg1 @@ -490,25 +389,40 @@ Section ParallelReduction. pred1 Γ Γ' d0 d1 -> pred1 Γ Γ' t0 t1 -> pred1 (Γ ,, vdef na d0 t0) (Γ' ,, vdef na d1 t1) b0 b1 -> pred1 Γ Γ' (tLetIn na d0 t0 b0) (tLetIn na d1 t1 b1) - | pred_case ind p0 p1 c0 c1 brs0 brs1 : - pred1 Γ Γ' p0 p1 -> + | pred_case ci p0 p1 c0 c1 brs0 brs1 : + pred1_ctx Γ Γ' -> + All2 (pred1 Γ Γ') p0.(pparams) p1.(pparams) -> + p0.(puinst) = p1.(puinst) -> + on_Trel (pred1_ctx_over Γ Γ') pcontext p0 p1 -> + pred1 (Γ ,,, p0.(pcontext)) (Γ' ,,, p1.(pcontext)) p0.(preturn) p1.(preturn) -> + All2 (fun br br' => + on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (pred1 (Γ ,,, br.(bcontext)) (Γ' ,,, br'.(bcontext))) + bbody br br') brs0 brs1 -> pred1 Γ Γ' c0 c1 -> - All2 (on_Trel_eq (pred1 Γ Γ') snd fst) brs0 brs1 -> - pred1 Γ Γ' (tCase ind p0 c0 brs0) (tCase ind p1 c1 brs1) + pred1 Γ Γ' (tCase ci p0 c0 brs0) (tCase ci p1 c1 brs1) + + (* | pred_case_refl ci p c brs : + (** We add a specific trivial reflexivity rule for tCase to ensure the relation + is reflexive on *any* term (even ill-formed ones), to simplify the + development. Otherwise we would have to reason on the shapes of the + case_predicate_context/case_branch_context everywhere. *) + pred1_ctx Γ Γ' -> + pred1 Γ Γ' (tCase ci p c brs) (tCase ci p c brs) *) | pred_proj_congr p c c' : pred1 Γ Γ' c c' -> pred1 Γ Γ' (tProj p c) (tProj p c') | pred_fix_congr mfix0 mfix1 idx : - All2_local_env (on_decl pred1) Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx Γ Γ' -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) pred1 mfix0 mfix1 -> pred1 Γ Γ' (tFix mfix0 idx) (tFix mfix1 idx) | pred_cofix_congr mfix0 mfix1 idx : - All2_local_env (on_decl pred1) Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx Γ Γ' -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) pred1 mfix0 mfix1 -> pred1 Γ Γ' (tCoFix mfix0 idx) (tCoFix mfix1 idx) @@ -517,14 +431,14 @@ Section ParallelReduction. pred1 Γ Γ' (tProd na M0 N0) (tProd na M1 N1) | evar_pred ev l l' : - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> All2 (pred1 Γ Γ') l l' -> pred1 Γ Γ' (tEvar ev l) (tEvar ev l') | pred_atom_refl t : - All2_local_env (on_decl pred1) Γ Γ' -> - pred_atom t -> pred1 Γ Γ' t t. - - Notation pred1_ctx Γ Γ' := (All2_local_env (on_decl pred1) Γ Γ'). + pred1_ctx Γ Γ' -> + pred_atom t -> pred1 Γ Γ' t t + where "'pred1_ctx'" := (All2_fold (on_decls pred1)) + and "'pred1_ctx_over' Γ Γ'" := (All2_fold (on_decls (on_decls_over pred1 Γ Γ'))). Ltac my_rename_hyp h th := match th with @@ -541,11 +455,24 @@ Section ParallelReduction. intros. split. apply X. apply aux. apply X. Defined. + Definition extend_over {P Q: context -> context -> term -> term -> Type} + (aux : forall Γ Γ' t t', P Γ Γ' t t' -> Q Γ Γ' t t') Γ Γ' : + (forall Δ Δ' t t', P (Γ ,,, Δ) (Γ' ,,, Δ') t t' -> Q (Γ ,,, Δ) (Γ' ,,, Δ') t t'). + Proof. + intros. apply aux. apply X. + Defined. + Lemma pred1_ind_all_ctx : forall (P : forall (Γ Γ' : context) (t t0 : term), Type) - (Pctx : forall (Γ Γ' : context), Type), + (Pctx : forall (Γ Γ' : context), Type) + (Pctxover : forall (Γ Γ' Δ Δ' : context), Type), let P' Γ Γ' x y := ((pred1 Γ Γ' x y) * P Γ Γ' x y)%type in - (forall Γ Γ', All2_local_env (on_decl pred1) Γ Γ' -> All2_local_env (on_decl P) Γ Γ' -> Pctx Γ Γ') -> + (forall Γ Γ', pred1_ctx Γ Γ' -> on_contexts P Γ Γ' -> Pctx Γ Γ') -> + (forall Γ Γ' Δ Δ', pred1_ctx Γ Γ' -> on_contexts P Γ Γ' -> + Pctx Γ Γ' -> + pred1_ctx_over Γ Γ' Δ Δ' -> + All2_fold_over P Γ Γ' Δ Δ' -> + Pctxover Γ Γ' Δ Δ') -> (forall (Γ Γ' : context) (na : aname) (t0 t1 b0 b1 a0 a1 : term), pred1 (Γ ,, vass na t0) (Γ' ,, vass na t1) b0 b1 -> P (Γ ,, vass na t0) (Γ' ,, vass na t1) b0 b1 -> pred1 Γ Γ' t0 t1 -> P Γ Γ' t0 t1 -> @@ -556,71 +483,88 @@ Section ParallelReduction. 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) (b1 {0 := d1})) -> (forall (Γ Γ' : context) (i : nat) (body : term), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> option_map decl_body (nth_error Γ' i) = Some (Some body) -> P Γ Γ' (tRel i) (lift0 (S i) body)) -> (forall (Γ Γ' : context) (i : nat), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> P Γ Γ' (tRel i) (tRel i)) -> - (forall (Γ Γ' : context) (ind : inductive) (pars c : nat) (u : Instance.t) (args0 args1 : list term) - (p : term) (brs0 brs1 : list (nat * term)), - All2_local_env (on_decl pred1) Γ Γ' -> + (forall Γ Γ' ci c u args0 args1 p0 brs0 brs1 br, + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> All2 (P' Γ Γ') args0 args1 -> - All2_prop_eq Γ Γ' snd fst P' brs0 brs1 -> - P Γ Γ' (tCase (ind, pars) p (mkApps (tConstruct ind c u) args0) brs0) (iota_red pars c args1 brs1)) -> + All2 (fun br br' => + (on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (Pctxover Γ Γ') bcontext br br') × + on_Trel (P' (Γ ,,, br.(bcontext)) (Γ' ,,, br'.(bcontext))) + bbody br br') brs0 brs1 -> + nth_error brs1 c = Some br -> + #|skipn (ci_npar ci) args1| = context_assumptions br.(bcontext) -> + P Γ Γ' (tCase ci p0 (mkApps (tConstruct ci.(ci_ind) c u) args0) brs0) + (iota_red ci.(ci_npar) args1 br)) -> + (forall (Γ Γ' : context) (mfix0 mfix1 : mfixpoint term) (idx : nat) (args0 args1 : list term) (narg : nat) (fn : term), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> - All2_local_env (on_decl (on_decl_over P Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> + Pctxover Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) P' mfix0 mfix1 -> unfold_fix mfix1 idx = Some (narg, fn) -> is_constructor narg args0 = true -> All2 (P' Γ Γ') args0 args1 -> P Γ Γ' (mkApps (tFix mfix0 idx) args0) (mkApps fn args1)) -> - (forall (Γ Γ' : context) (ip : inductive * nat) (p0 p1 : term) (mfix0 mfix1 : mfixpoint term) (idx : nat) - (args0 args1 : list term) (narg : nat) (fn : term) (brs0 brs1 : list (nat * term)), - All2_local_env (on_decl pred1) Γ Γ' -> + + (forall (Γ Γ' : context) ci p0 p1 mfix0 mfix1 idx args0 args1 narg fn brs0 brs1, + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> - All2_local_env (on_decl (on_decl_over P Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> - All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody - (fun x => (dname x, rarg x)) P' mfix0 mfix1 -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> + Pctxover Γ Γ' (fix_context mfix0) (fix_context mfix1) -> + All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) + dtype dbody (fun x => (dname x, rarg x)) P' mfix0 mfix1 -> unfold_cofix mfix1 idx = Some (narg, fn) -> All2 (P' Γ Γ') args0 args1 -> - pred1 Γ Γ' p0 p1 -> - P Γ Γ' p0 p1 -> - All2_prop_eq Γ Γ' snd fst P' brs0 brs1 -> - P Γ Γ' (tCase ip p0 (mkApps (tCoFix mfix0 idx) args0) brs0) (tCase ip p1 (mkApps fn args1) brs1)) -> + All2 (P' Γ Γ') p0.(pparams) p1.(pparams) -> + p0.(puinst) = p1.(puinst) -> + on_Trel (pred1_ctx_over Γ Γ') pcontext p0 p1 -> + on_Trel (Pctxover Γ Γ') pcontext p0 p1 -> + pred1 (Γ ,,, p0.(pcontext)) (Γ' ,,, p1.(pcontext)) p0.(preturn) p1.(preturn) -> + P (Γ ,,, p0.(pcontext)) (Γ' ,,, p1.(pcontext)) p0.(preturn) p1.(preturn) -> + All2 (fun br br' => + (on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (Pctxover Γ Γ') bcontext br br') × + on_Trel (P' (Γ ,,, br.(bcontext)) (Γ' ,,, br'.(bcontext))) + bbody br br') brs0 brs1 -> + P Γ Γ' (tCase ci p0 (mkApps (tCoFix mfix0 idx) args0) brs0) + (tCase ci p1 (mkApps fn args1) brs1)) -> + (forall (Γ Γ' : context) (p : projection) (mfix0 mfix1 : mfixpoint term) (idx : nat) (args0 args1 : list term) (narg : nat) (fn : term), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> - All2_local_env (on_decl (on_decl_over P Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> + Pctxover Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) P' mfix0 mfix1 -> unfold_cofix mfix1 idx = Some (narg, fn) -> All2 (P' Γ Γ') args0 args1 -> P Γ Γ' (tProj p (mkApps (tCoFix mfix0 idx) args0)) (tProj p (mkApps fn args1))) -> (forall (Γ Γ' : context) c (decl : constant_body) (body : term), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> declared_constant Σ c decl -> forall u : Instance.t, cst_body decl = Some body -> - P Γ Γ' (tConst c u) (subst_instance_constr u body)) -> + P Γ Γ' (tConst c u) (subst_instance u body)) -> (forall (Γ Γ' : context) c (u : Instance.t), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> P Γ Γ' (tConst c u) (tConst c u)) -> (forall (Γ Γ' : context) (i : inductive) (pars narg : nat) (u : Instance.t) (args0 args1 : list term) (arg1 : term), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> All2 (pred1 Γ Γ') args0 args1 -> All2 (P Γ Γ') args0 args1 -> @@ -640,28 +584,41 @@ 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) (ind : inductive * nat) (p0 p1 c0 c1 : term) (brs0 brs1 : list (nat * term)), - pred1 Γ Γ' p0 p1 -> - P Γ Γ' p0 p1 -> + + (forall (Γ Γ' : context) ci p0 p1 c0 c1 brs0 brs1, + pred1_ctx Γ Γ' -> + Pctx Γ Γ' -> + All2 (P' Γ Γ') p0.(pparams) p1.(pparams) -> + p0.(puinst) = p1.(puinst) -> + on_Trel (pred1_ctx_over Γ Γ') pcontext p0 p1 -> + on_Trel (Pctxover Γ Γ') pcontext p0 p1 -> + pred1 (Γ ,,, p0.(pcontext)) (Γ' ,,, p1.(pcontext)) p0.(preturn) p1.(preturn) -> + P (Γ ,,, p0.(pcontext)) (Γ' ,,, p1.(pcontext)) p0.(preturn) p1.(preturn) -> + All2 (fun br br' => + (on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (Pctxover Γ Γ') bcontext br br') × + on_Trel (P' (Γ ,,, br.(bcontext)) (Γ' ,,, br'.(bcontext))) + bbody br br') brs0 brs1 -> pred1 Γ Γ' c0 c1 -> - P Γ Γ' c0 c1 -> All2_prop_eq Γ Γ' snd fst P' brs0 brs1 -> - P Γ Γ' (tCase ind p0 c0 brs0) (tCase ind p1 c1 brs1)) -> + P Γ Γ' c0 c1 -> + P Γ Γ' (tCase ci p0 c0 brs0) (tCase ci p1 c1 brs1)) -> + (forall (Γ Γ' : context) (p : projection) (c c' : term), pred1 Γ Γ' c c' -> P Γ Γ' c c' -> P Γ Γ' (tProj p c) (tProj p c')) -> (forall (Γ Γ' : context) (mfix0 : mfixpoint term) (mfix1 : list (def term)) (idx : nat), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> - All2_local_env (on_decl (on_decl_over P Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> + Pctxover Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) P' mfix0 mfix1 -> P Γ Γ' (tFix mfix0 idx) (tFix mfix1 idx)) -> (forall (Γ Γ' : context) (mfix0 : mfixpoint term) (mfix1 : list (def term)) (idx : nat), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> - All2_local_env (on_decl (on_decl_over pred1 Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> - All2_local_env (on_decl (on_decl_over P Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> + pred1_ctx_over Γ Γ' (fix_context mfix0) (fix_context mfix1) -> + Pctxover Γ Γ' (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody (fun x => (dname x, rarg x)) P' mfix0 mfix1 -> P Γ Γ' (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> (forall (Γ Γ' : context) (na : aname) (M0 M1 N0 N1 : term), @@ -669,16 +626,17 @@ Section ParallelReduction. P Γ Γ' M0 M1 -> pred1 (Γ,, vass na M0) (Γ' ,, vass na M1) N0 N1 -> P (Γ,, vass na M0) (Γ' ,, vass na M1) N0 N1 -> P Γ Γ' (tProd na M0 N0) (tProd na M1 N1)) -> (forall (Γ Γ' : context) (ev : nat) (l l' : list term), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> All2 (P' Γ Γ') l l' -> P Γ Γ' (tEvar ev l) (tEvar ev l')) -> (forall (Γ Γ' : context) (t : term), - All2_local_env (on_decl pred1) Γ Γ' -> + pred1_ctx Γ Γ' -> Pctx Γ Γ' -> pred_atom t -> P Γ Γ' t t) -> forall (Γ Γ' : context) (t t0 : term), pred1 Γ Γ' t t0 -> P Γ Γ' t t0. - Proof. - intros P Pctx P' Hctx. intros. revert Γ Γ' t t0 X20. + Proof using Σ. + intros P Pctx Pctxover P' Hctx Hctxover. intros. + rename X20 into pr. revert Γ Γ' t t0 pr. fix aux 5. intros Γ Γ' t t'. move aux at top. destruct 1; match goal with @@ -689,132 +647,202 @@ Section ParallelReduction. | |- P _ _ (tProj _ (mkApps (tCoFix _ _) _)) _ => idtac | |- P _ _ (tRel _) _ => idtac | |- P _ _ (tConst _ _) _ => idtac + | |- P _ _ (tCase _ _ ?c _) (tCase _ _ ?c _) => idtac | H : _ |- _ => eapply H; eauto end. - - simpl. apply X1; auto. apply Hctx. - apply (All2_local_env_impl a). intros. eapply X20. - apply (All2_local_env_impl a). intros. eapply (aux _ _ _ _ X20). + - simpl. apply X1; auto. + clear X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15 X16 X17 X18 X19. + apply Hctx. + apply (All2_fold_impl a). intros. eapply X1. + apply (All2_fold_impl a). intros. eapply (aux _ _ _ _ X1). - simpl. apply X2; auto. - apply Hctx, (All2_local_env_impl a). exact a. intros. apply (aux _ _ _ _ X20). - - apply Hctx, (All2_local_env_impl a). exact a. intros. apply (aux _ _ _ _ X20). + apply Hctx, (All2_fold_impl a). exact a. intros. apply (aux _ _ _ _ X20). + - apply Hctx, (All2_fold_impl a). exact a. intros. apply (aux _ _ _ _ X20). - eapply (All2_All2_prop (P:=pred1) (Q:=P') a0 ((extendP aux) Γ Γ')). - - eapply (All2_All2_prop_eq (P:=pred1) (Q:=P') (f:=snd) (g:=fst) a1 (extendP aux Γ Γ')). + - eapply (All2_branch_prop + (P:=fun Γ Γ' br br' => + on_Trel (pred1_ctx_over Γ Γ') bcontext br br' * + on_Trel (pred1 (Γ,,, bcontext br) (Γ',,, bcontext br')) bbody br br') + (Q:=fun Γ Γ' br br' => + (on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (Pctxover Γ Γ') bcontext br br') * + on_Trel (P' (Γ,,, bcontext br) (Γ',,, bcontext br')) bbody br br') + a1). + intros x y []. split; auto. split => //. + * apply Hctxover => //. + apply (All2_fold_impl a aux). + apply (Hctx _ _ a), (All2_fold_impl a aux). + apply (All2_fold_impl o (extend_over aux Γ Γ')). + * apply (extendP aux _ _). exact o0. - eapply X4; eauto. - apply Hctx, (All2_local_env_impl a). exact a. intros. apply (aux _ _ _ _ X20). - eapply (All2_local_env_impl a0). intros. red. red in X20. apply (aux _ _ _ _ X20). - eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). - eapply (All2_All2_prop (P:=pred1) (Q:=P') a2 (extendP aux Γ Γ')). + * apply (Hctx _ _ a), (All2_fold_impl a aux). + * apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) a0 (All2_fold_impl a0 (extend_over aux Γ Γ'))). + * eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). + * eapply (All2_All2_prop (P:=pred1) (Q:=P') a2 (extendP aux Γ Γ')). - eapply X5; eauto. - apply Hctx, (All2_local_env_impl a). exact a. intros. apply (aux _ _ _ _ X21). - eapply (All2_local_env_impl a0). intros. red. red in X21. apply (aux _ _ _ _ X21). - eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). - eapply (All2_All2_prop (P:=pred1) (Q:=P') a2 (extendP aux Γ Γ')). - eapply (All2_All2_prop_eq (P:=pred1) (Q:=P') (f:=snd) a3 (extendP aux Γ Γ')). + * apply Hctx, (All2_fold_impl a) => //. + * apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) a0 (All2_fold_impl a0 (extend_over aux Γ Γ'))). + * eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). + * 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 (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) + o (All2_fold_impl o (extend_over aux Γ Γ'))). + * eapply (All2_branch_prop + (P:=fun Γ Γ' br br' => + on_Trel (pred1_ctx_over Γ Γ') bcontext br br' * + on_Trel (pred1 (Γ,,, bcontext br) (Γ',,, bcontext br')) bbody br br') + (Q:=fun Γ Γ' br br' => + (on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (Pctxover Γ Γ') bcontext br br') * + on_Trel (P' (Γ,,, bcontext br) (Γ',,, bcontext br')) bbody br br') + a4). + intros x y []. + split; auto. split => //. + + apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) o0 (All2_fold_impl o0 (extend_over aux Γ Γ'))). + + apply (extendP aux _ _). exact o1. - eapply X6; eauto. - apply Hctx, (All2_local_env_impl a). exact a. intros. apply (aux _ _ _ _ X20). - eapply (All2_local_env_impl a0). intros. red. red in X20. apply (aux _ _ _ _ X20). - eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). - eapply (All2_All2_prop (P:=pred1) (Q:=P') a2 (extendP aux Γ Γ')). + * apply (Hctx _ _ a), (All2_fold_impl a aux). + * apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) a0 (All2_fold_impl a0 (extend_over aux Γ Γ'))). + * eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). + * eapply (All2_All2_prop (P:=pred1) (Q:=P') a2 (extendP aux Γ Γ')). - eapply X7; eauto. - apply Hctx, (All2_local_env_impl a). intros. exact a. intros. apply (aux _ _ _ _ X20). + apply (Hctx _ _ a), (All2_fold_impl a aux). - eapply X8; eauto. - apply Hctx, (All2_local_env_impl a). exact a. intros. apply (aux _ _ _ _ X20). - - apply Hctx, (All2_local_env_impl a). exact a. intros. apply (aux _ _ _ _ X20). + apply (Hctx _ _ a), (All2_fold_impl a aux). + - apply (Hctx _ _ a), (All2_fold_impl a aux). - eapply (All2_All2_prop (P:=pred1) (Q:=P) a0). intros. apply (aux _ _ _ _ X20). - - eapply (All2_All2_prop_eq (P:=pred1) (Q:=P') (f:=snd) a (extendP aux Γ Γ')). - - eapply X15. - eapply (All2_local_env_impl a). intros. apply X20. - eapply (Hctx _ _ a), (All2_local_env_impl a). intros. apply (aux _ _ _ _ X20). - eapply (All2_local_env_impl a0). intros. red. exact X20. - eapply (All2_local_env_impl a0). intros. red. apply (aux _ _ _ _ X20). - eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). - - eapply X16. - eapply (All2_local_env_impl a). intros. apply X20. - eapply (Hctx _ _ a), (All2_local_env_impl a). intros. apply (aux _ _ _ _ X20). - eapply (All2_local_env_impl a0). intros. red. exact X20. - eapply (All2_local_env_impl a0). intros. red. apply (aux _ _ _ _ X20). - eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). - - eapply (Hctx _ _ a), (All2_local_env_impl a). intros. apply (aux _ _ _ _ X20). + - apply (Hctx _ _ a), (All2_fold_impl a aux). + - apply (All2_All2_prop (P:=pred1) (Q:=P') a0 (extendP aux _ _)). + - apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) o (All2_fold_impl o (extend_over aux Γ Γ'))). + - eapply (All2_branch_prop + (P:=fun Γ Γ' br br' => + on_Trel (pred1_ctx_over Γ Γ') bcontext br br' * + on_Trel (pred1 (Γ,,, bcontext br) (Γ',,, bcontext br')) bbody br br') + (Q:=fun Γ Γ' br br' => + (on_Trel (pred1_ctx_over Γ Γ') bcontext br br' × + on_Trel (Pctxover Γ Γ') bcontext br br') * + on_Trel (P' (Γ,,, bcontext br) (Γ',,, bcontext br')) bbody br br') + a1). + intros x y []. + split; auto. split => //. + + apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) o0 (All2_fold_impl o0 (extend_over aux Γ Γ'))). + + apply (extendP aux _ _). exact o1. + - eapply X15 => //. + * eapply (Hctx _ _ a), (All2_fold_impl a aux). + * apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) a0 (All2_fold_impl a0 (extend_over aux Γ Γ'))). + * eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). + - eapply X16; tas. + * eapply (Hctx _ _ a), (All2_fold_impl a aux). + * apply (Hctxover _ _ _ _ a (All2_fold_impl a aux) + (Hctx _ _ a (All2_fold_impl a aux)) a0 (All2_fold_impl a0 (extend_over aux Γ Γ'))). + * eapply (All2_All2_prop2_eq (Q:=P') (f:=dtype) (g:=dbody) a1 (extendP aux)). + - eapply (Hctx _ _ a), (All2_fold_impl a aux). - eapply (All2_All2_prop (P:=pred1) (Q:=P') a0 (extendP aux Γ Γ')). - - eapply (Hctx _ _ a), (All2_local_env_impl a). intros. apply (aux _ _ _ _ X20). + - eapply (Hctx _ _ a), (All2_fold_impl a aux). Defined. + Lemma pred1_pred1_ctx {Γ Δ t u} : pred1 Γ Δ t u -> pred1_ctx Γ Δ. + Proof. + intros H; revert Γ Δ t u H. + refine (pred1_ind_all_ctx _ (fun Γ Γ' => pred1_ctx Γ Γ') + (fun Γ Γ' Δ Δ' => True) + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *. + all:try intros **; rename_all_hyps; + try solve [specialize (forall_Γ _ X3); eauto]; eauto; + try solve [eexists; split; constructor; eauto]. + Qed. + + Lemma onctx_rel_pred1_refl Γ Δ : + forall Γ', + pred1_ctx Γ Γ' -> + onctx_rel + (fun (Γ : context) (t : term) => + forall Γ' : context, pred1_ctx Γ Γ' -> pred1 Γ Γ' t t) Γ Δ -> + pred1_ctx_over Γ Γ' Δ Δ. + Proof. + intros Γ' pred onc. + induction onc; simpl; constructor; auto. + constructor. + red in t0 |- *. eapply t0. + apply All2_fold_app => //. + destruct t1. + constructor; red; [eapply p|eapply p0]; + apply All2_fold_app => //. + Qed. + + Hint Constructors All_decls : pcuic. + Lemma pred1_refl_gen Γ Γ' t : pred1_ctx Γ Γ' -> pred1 Γ Γ' t t. Proof. revert Γ'. - unshelve einduction Γ, t using term_forall_ctx_list_ind; + revert Γ t. + apply: term_forall_ctx_list_ind; intros; try solve [(apply pred_atom; reflexivity) || constructor; auto]; try solve [try red in X; constructor; unfold All2_prop2_eq, All2_prop2, on_Trel in *; solve_all]; intros. - - constructor; eauto. eapply IHt0_2. + - constructor; eauto. eapply X0. constructor; try red; eauto with pcuic. - - constructor; eauto. eapply IHt0_2. + - constructor; eauto. eapply X0. constructor; try red; eauto with pcuic. - - constructor; eauto. eapply IHt0_3. + - constructor; eauto. eapply X1. constructor; try red; eauto with pcuic. - - assert (All2_local_env (on_decl (fun Δ Δ' : context => pred1 (Γ0 ,,, Δ) (Γ' ,,, Δ'))) - (fix_context m) (fix_context m)). - { revert X. clear -X1. generalize (fix_context m). - intros c H1. induction H1; constructor; auto. - - red in t0. red. eapply t0. eapply All2_local_env_app_inv; auto. - - red in t1. red. split. - + eapply t1. eapply All2_local_env_app_inv; auto. - + eapply t1. eapply All2_local_env_app_inv; auto. - } - constructor; auto. red. + - red in X, X1; econstructor; solve_all. + * apply onctx_rel_pred1_refl => //. + * eapply b0. + eapply All2_fold_app => //. + eapply onctx_rel_pred1_refl => //. + * eapply All_All2; tea; solve_all. + + apply onctx_rel_pred1_refl => //. + + eapply b. + now eapply All2_fold_app => //; eapply onctx_rel_pred1_refl. + - constructor; auto. + apply onctx_rel_pred1_refl => //. + unfold All2_prop_eq, on_Trel in *. + eapply All_All2; eauto. simpl; intros. solve_all. + eapply a; tas. + eapply b. eapply All2_fold_app; auto. + now eapply onctx_rel_pred1_refl. + - constructor; auto. + apply onctx_rel_pred1_refl => //. unfold All2_prop_eq, on_Trel in *. - eapply All_All2; eauto. simpl; intros. - split; eauto. eapply X3; auto. - split. eapply X3. eapply All2_local_env_app_inv; auto. auto. - - assert (All2_local_env (on_decl (fun Δ Δ' : context => pred1 (Γ0 ,,, Δ) (Γ' ,,, Δ'))) - (fix_context m) (fix_context m)). - { revert X. clear -X1. generalize (fix_context m). - intros c H1. induction H1; constructor; auto. - - red in t0. red. eapply t0. eapply All2_local_env_app_inv; auto. - - red in t1. red. split. - + eapply t1. eapply All2_local_env_app_inv; auto. - + eapply t1. eapply All2_local_env_app_inv; auto. - } - constructor; auto. red. - eapply All_All2; eauto. simpl; intros. - split; eauto. eapply X3; auto. - split. eapply X3. eapply All2_local_env_app_inv; auto. auto. + eapply All_All2; eauto. simpl; intros. solve_all. + eapply a; tas. + eapply b. eapply All2_fold_app; auto. + now eapply onctx_rel_pred1_refl. Qed. Lemma pred1_ctx_refl Γ : pred1_ctx Γ Γ. Proof. induction Γ. constructor. - destruct a as [na [b|] ty]; constructor; try red; simpl; auto with pcuic. - split; now apply pred1_refl_gen. apply pred1_refl_gen, IHΓ. + destruct a as [na [b|] ty]; constructor; try red; simpl; auto with pcuic; + constructor; now apply pred1_refl_gen. Qed. Hint Resolve pred1_ctx_refl : pcuic. Lemma pred1_refl Γ t : pred1 Γ Γ t t. Proof. apply pred1_refl_gen, pred1_ctx_refl. Qed. - Lemma pred1_pred1_ctx {Γ Δ t u} : pred1 Γ Δ t u -> pred1_ctx Γ Δ. - Proof. - intros H; revert Γ Δ t u H. - refine (pred1_ind_all_ctx _ (fun Γ Γ' => pred1_ctx Γ Γ') _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *. - all:try intros **; rename_all_hyps; - try solve [specialize (forall_Γ _ X3); eauto]; eauto; - try solve [eexists; split; constructor; eauto]. - Qed. - - Lemma pred1_ctx_over_refl Γ Δ : All2_local_env (on_decl (on_decl_over pred1 Γ Γ)) Δ Δ. + Lemma pred1_ctx_over_refl Γ Δ : All2_fold (on_decls (on_decls_over pred1 Γ Γ)) Δ Δ. Proof. induction Δ as [|[na [b|] ty] Δ]; constructor; auto. - red. split; red; apply pred1_refl. - red. apply pred1_refl. + all:constructor; apply pred1_refl. Qed. End ParallelReduction. Hint Constructors pred1 : pcuic. -Hint Unfold All2_prop2_eq All2_prop2 on_decl on_decl_over on_rel on_Trel snd on_snd : pcuic. +Hint Unfold All2_prop2_eq All2_prop2 on_decls_over on_rel on_Trel snd on_snd : pcuic. Hint Resolve All2_same: pcuic. -Hint Constructors All2_local_env : pcuic. +Hint Constructors All2_fold : pcuic. Hint Resolve pred1_ctx_refl : pcuic. @@ -823,22 +851,23 @@ Ltac pcuic_simplify := Hint Extern 10 => progress pcuic_simplify : pcuic. -Notation pred1_ctx Σ Γ Γ' := (All2_local_env (on_decl (pred1 Σ)) Γ Γ'). +Notation pred1_ctx Σ Γ Γ' := (All2_fold (on_decls (pred1 Σ)) Γ Γ'). +Notation pred1_ctx_over Σ Γ Γ' := (All2_fold (on_decls (on_decls_over (pred1 Σ) Γ Γ'))). Hint Extern 4 (pred1 _ _ _ ?t _) => tryif is_evar t then fail 1 else eapply pred1_refl_gen : pcuic. Hint Extern 4 (pred1 _ _ _ ?t _) => tryif is_evar t then fail 1 else eapply pred1_refl : pcuic. Hint Extern 20 (#|?X| = #|?Y|) => match goal with - [ H : All2_local_env _ ?X ?Y |- _ ] => apply (All2_local_env_length H) -| [ H : All2_local_env _ ?Y ?X |- _ ] => symmetry; apply (All2_local_env_length H) -| [ H : All2_local_env_over _ _ _ ?X ?Y |- _ ] => apply (All2_local_env_length H) -| [ H : All2_local_env_over _ _ _ ?Y ?X |- _ ] => symmetry; apply (All2_local_env_length H) + [ H : All2_fold _ ?X ?Y |- _ ] => apply (All2_fold_length H) +| [ H : All2_fold _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H) +| [ H : All2_fold_over _ _ _ ?X ?Y |- _ ] => apply (All2_fold_length H) +| [ H : All2_fold_over _ _ _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H) end : pcuic. Hint Extern 4 (pred1_ctx ?Σ ?Γ ?Γ') => match goal with - | [ H : pred1_ctx Σ (Γ ,,, _) (Γ' ,,, _) |- _ ] => apply (All2_local_env_app_left H) + | [ H : pred1_ctx Σ (Γ ,,, _) (Γ' ,,, _) |- _ ] => apply (All2_fold_app_inv_left H) | [ H : pred1 Σ Γ Γ' _ _ |- _ ] => apply (pred1_pred1_ctx _ H) end : pcuic. @@ -852,110 +881,21 @@ Ltac my_rename_hyp h th := Ltac rename_hyp h ht ::= my_rename_hyp h ht. -Lemma All2_local_env_over_refl {Σ Γ Δ Γ'} : - pred1_ctx Σ Γ Δ -> All2_local_env_over (pred1 Σ) Γ Δ Γ' Γ'. +Lemma All2_fold_over_refl {Σ Γ Δ Γ'} : + pred1_ctx Σ Γ Δ -> All2_fold_over (pred1 Σ) Γ Δ Γ' Γ'. Proof. intros X0. red. induction Γ'. constructor. - pose proof IHΓ'. apply All2_local_env_over_app in IHΓ'; auto. + pose proof IHΓ'. apply All2_fold_over_app in IHΓ'; auto. + constructor; auto. destruct a as [na [b|] ty]; constructor; pcuic. Qed. -Hint Extern 4 (All2_local_env_over _ _ _ ?X) => - tryif is_evar X then fail 1 else eapply All2_local_env_over_refl : pcuic. +Hint Extern 4 (All2_fold_over _ _ _ ?X) => + tryif is_evar X then fail 1 else eapply All2_fold_over_refl : pcuic. Section ParallelWeakening. Context {cf : checker_flags}. - (* Lemma All2_local_env_over_app_inv {Σ Γ0 Δ Γ'' Δ''} : *) - (* pred1_ctx Σ (Γ0 ,,, Γ'') (Δ ,,, Δ'') -> *) - (* pred1_ctx Σ Γ0 Δ -> *) - (* All2_local_env_over (pred1 Σ) Γ0 Δ Γ'' Δ'' -> *) - - (* Proof. *) - (* intros. induction X0; pcuic; constructor; pcuic. *) - (* Qed. *) - - Lemma All2_local_env_weaken_pred_ctx {Σ Γ0 Γ'0 Δ Δ' Γ'' Δ''} : - #|Γ0| = #|Δ| -> - pred1_ctx Σ Γ0 Δ -> - All2_local_env_over (pred1 Σ) Γ0 Δ Γ'' Δ'' -> - All2_local_env - (on_decl - (fun (Γ Γ' : context) (t t0 : term) => - forall Γ1 Γ'1 : context, - Γ = Γ1 ,,, Γ'1 -> - forall Δ0 Δ'0 : context, - Γ' = Δ0 ,,, Δ'0 -> - #|Γ1| = #|Δ0| -> - forall Γ''0 Δ''0 : context, - All2_local_env_over (pred1 Σ) Γ1 Δ0 Γ''0 Δ''0 -> - pred1 Σ (Γ1 ,,, Γ''0 ,,, lift_context #|Γ''0| 0 Γ'1) (Δ0 ,,, Δ''0 ,,, lift_context #|Δ''0| 0 Δ'0) - (lift #|Γ''0| #|Γ'1| t) (lift #|Δ''0| #|Δ'0| t0))) (Γ0 ,,, Γ'0) (Δ ,,, Δ') -> - - pred1_ctx Σ (Γ0 ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ'0) (Δ ,,, Δ'' ,,, lift_context #|Δ''| 0 Δ'). - Proof. - intros. - pose proof (All2_local_env_length X0). - eapply All2_local_env_app in X1 as [Xl Xr]; auto. - induction Xr; simpl; auto. apply All2_local_env_over_app; pcuic. - rewrite !lift_context_snoc. simpl. constructor. auto. assumption. red in p. - specialize (p _ _ eq_refl _ _ eq_refl). forward p by auto. simpl. - rewrite !Nat.add_0_r. simpl. specialize (p Γ'' Δ''). - forward p. auto. pose proof (All2_local_env_length X0). - rewrite H0 in p. congruence. - - destruct p. - specialize (p _ _ eq_refl _ _ eq_refl H _ _ X0). - specialize (p0 _ _ eq_refl _ _ eq_refl H _ _ X0). - rewrite !lift_context_snoc. simpl. constructor; auto. - red. split; auto. - rewrite !Nat.add_0_r. rewrite H0 in p. simpl. congruence. - rewrite !Nat.add_0_r. rewrite H0 in p0. simpl. congruence. - Qed. - - Lemma All2_local_env_weaken_pred_ctx' {Σ Γ0 Γ'0 Δ Δ' Γ'' Δ''} ctx ctx' : - #|Γ0| = #|Δ| -> #|Γ0 ,,, Γ'0| = #|Δ ,,, Δ'| -> - pred1_ctx Σ Γ0 Δ -> - All2_local_env_over (pred1 Σ) Γ0 Δ Γ'' Δ'' -> - All2_local_env - (on_decl - (on_decl_over - (fun (Γ Γ' : context) (t t0 : term) => - forall Γ1 Γ'1 : context, - Γ = Γ1 ,,, Γ'1 -> - forall Δ0 Δ'0 : context, - Γ' = Δ0 ,,, Δ'0 -> - #|Γ1| = #|Δ0| -> - forall Γ''0 Δ''0 : context, - All2_local_env_over (pred1 Σ) Γ1 Δ0 Γ''0 Δ''0 -> - pred1 Σ (Γ1 ,,, Γ''0 ,,, lift_context #|Γ''0| 0 Γ'1) (Δ0 ,,, Δ''0 ,,, lift_context #|Δ''0| 0 Δ'0) - (lift #|Γ''0| #|Γ'1| t) (lift #|Δ''0| #|Δ'0| t0)) (Γ0 ,,, Γ'0) (Δ ,,, Δ'))) - ctx ctx' -> - All2_local_env - (on_decl - (on_decl_over (pred1 Σ) (Γ0 ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ'0) (Δ ,,, Δ'' ,,, lift_context #|Δ''| 0 Δ'))) - (lift_context #|Γ''| #|Γ'0| ctx) (lift_context #|Δ''| #|Δ'| ctx'). - Proof. - intros. - pose proof (All2_local_env_length X0). - induction X1; simpl; rewrite ?lift_context_snoc0; constructor; auto. - - red in p. red in p. red. red. simpl. - specialize (p Γ0 (Γ'0,,, Γ)). - rewrite app_context_assoc in p. forward p by auto. - specialize (p Δ (Δ',,, Γ')). - rewrite app_context_assoc in p. forward p by auto. - specialize (p H _ _ X0). - rewrite !app_context_length !lift_context_app !app_context_assoc !Nat.add_0_r in p. - congruence. - - destruct p. - specialize (o Γ0 (Γ'0,,, Γ) ltac:(now rewrite app_context_assoc) Δ (Δ',,, Γ') - ltac:(now rewrite app_context_assoc) H _ _ X0). - rewrite !app_context_length !lift_context_app !app_context_assoc !Nat.add_0_r in o. - specialize (o0 Γ0 (Γ'0,,, Γ) ltac:(now rewrite app_context_assoc) Δ (Δ',,, Γ') - ltac:(now rewrite app_context_assoc) H _ _ X0). - rewrite !app_context_length !lift_context_app !app_context_assoc !Nat.add_0_r in o0. - red. split; auto. - Qed. Lemma map_cofix_subst f mfix : (forall n, tCoFix (map (map_def (f 0) (f #|mfix|)) mfix) n = f 0 (tCoFix mfix n)) -> @@ -976,11 +916,41 @@ 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. + + Lemma lift_iota_red n k pars args br : + #|skipn pars args| = context_assumptions br.(bcontext) -> + lift n k (iota_red pars args br) = + iota_red pars (List.map (lift n k) args) (map_branch_k (lift n) k br). + Proof. + intros hctx. rewrite !lift_rename'. rewrite rename_iota_red //. + f_equal; try setoid_rewrite <-lift_rename => //. + unfold map_branch_k, rename_branch, map_branch_shift. + f_equal. + * rewrite /shiftf. setoid_rewrite lift_rename'. + now setoid_rewrite shiftn_lift_renaming. + * simpl. now rewrite lift_rename' shiftn_lift_renaming. + Qed. + + Lemma mapi_context_lift n k ctx : + mapi_context (shiftf (lift n) k) ctx = lift_context n k ctx. + Proof. + now rewrite mapi_context_fold. + Qed. + + 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 weakening_pred1 Σ Γ Γ' Γ'' Δ Δ' Δ'' M N : wf Σ -> pred1 Σ (Γ ,,, Γ') (Δ ,,, Δ') M N -> #|Γ| = #|Δ| -> - All2_local_env_over (pred1 Σ) Γ Δ Γ'' Δ'' -> + All2_fold_over (pred1 Σ) Γ Δ Γ'' Δ'' -> pred1 Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (Δ ,,, Δ'' ,,, lift_context #|Δ''| 0 Δ') (lift #|Γ''| #|Γ'| M) (lift #|Δ''| #|Δ'| N). @@ -1001,18 +971,37 @@ Section ParallelWeakening. Δ0 = Δ ,,, Δ' -> #|Γ| = #|Δ| -> forall Γ'' Δ'' : context, - All2_local_env_over (pred1 Σ) Γ Δ Γ'' Δ'' -> + All2_fold_over (pred1 Σ) Γ Δ Γ'' Δ'' -> pred1_ctx Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (Δ ,,, Δ'' ,,, lift_context #|Δ''| 0 Δ')). - refine (pred1_ind_all_ctx Σ _ Pctx _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *; intros; subst Pctx; - rename_all_hyps; try subst Γ Γ'; simplify_IH_hyps; cbn -[iota_red]; + set (Pctxover := + fun (Γ0 Δ0 : context) (ctx ctx' : context) => + forall Γ Γ' : context, + Γ0 = Γ ,,, Γ' -> + forall Δ Δ' : context, + Δ0 = Δ ,,, Δ' -> + #|Γ| = #|Δ| -> + forall Γ'' Δ'' : context, + All2_fold_over (pred1 Σ) Γ Δ Γ'' Δ'' -> + pred1_ctx_over Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') + (Δ ,,, Δ'' ,,, lift_context #|Δ''| 0 Δ') + (lift_context #|Γ''| #|Γ'| ctx) + (lift_context #|Δ''| #|Δ'| ctx')). + + refine (pred1_ind_all_ctx Σ _ Pctx Pctxover _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *; intros; subst Pctx + Pctxover; + rename_all_hyps; try subst Γ Γ'; + lazymatch goal with + | |- context [tCase _ _ _ _] => idtac + | |- _ => simplify_IH_hyps + end; cbn -[iota_red]; match goal with - |- context [iota_red _ _ _ _] => idtac + |- context [iota_red _ _ _] => idtac | |- _ => autorewrite with lift end; try specialize (forall_Γ _ _ Γ'' eq_refl _ _ Δ'' eq_refl heq_length); try specialize (forall_Γ0 _ _ Γ'' eq_refl _ _ Δ'' eq_refl heq_length); - try pose proof (All2_local_env_length X0); + try pose proof (All2_fold_length X0); try specialize (X0 _ _ eq_refl _ _ eq_refl heq_length _ _ ltac:(eauto)); simpl; try solve [ econstructor; eauto; try apply All2_map; unfold All2_prop_eq, All2_prop, on_Trel, id in *; solve_all]; @@ -1020,19 +1009,31 @@ Section ParallelWeakening. - (* Contexts *) intros. subst. - eapply All2_local_env_over_app. - + eapply All2_local_env_over_app; pcuic. - + eapply All2_local_env_app in X0; auto. + eapply All2_fold_over_app. + + eapply All2_fold_over_app; pcuic. + + eapply All2_fold_app_inv in X0; auto. destruct X0. induction a0; rewrite ?lift_context_snoc0; cbn; constructor; pcuic. * apply IHa0. -- depelim predΓ'. ++ assumption. -- unfold ",,,". lia. - * now rewrite !Nat.add_0_r. - * apply IHa0; auto. depelim predΓ'. - assumption. - * split; red; now rewrite !Nat.add_0_r. + * rewrite !Nat.add_0_r. + eapply All_decls_map, All_decls_impl; tea. + intuition auto. unfold on_decls_over. + eapply X0 => //. + + - intros. + rewrite - !mapi_context_lift. + apply All2_fold_mapi. simpl. clear X0 X1 X2. + eapply All2_fold_impl; tea. + intros. red in X0. + rewrite !mapi_context_lift /shiftf. + subst Γ Γ'. + rewrite - !app_context_assoc in X0. + specialize (X0 _ _ eq_refl _ _ eq_refl H2 _ _ X). + red. + now rewrite !lift_context_app in X0; len in X0; rewrite !app_context_assoc in X0. - (* Beta *) specialize (forall_Γ _ (Γ'0,, vass na t0) eq_refl _ (Δ' ,, vass na t1) eq_refl heq_length _ _ X5). @@ -1051,8 +1052,8 @@ Section ParallelWeakening. + destruct nth_error eqn:Heq; noconf heq_option_map. pose proof (nth_error_Some_length Heq). rewrite !app_context_length in H1. - assert (#|Γ'0| = #|Δ'|). pcuic. eapply All2_local_env_app in predΓ' as [? ?]. - now eapply All2_local_env_length in a0. auto. + assert (#|Γ'0| = #|Δ'|). pcuic. eapply All2_fold_app_inv in predΓ' as [? ?]. + now eapply All2_fold_length in a0. auto. rewrite simpl_lift; try lia. rewrite - {2}H0. assert (#|Γ''| + S i = S (#|Γ''| + i)) as -> by lia. @@ -1062,14 +1063,14 @@ Section ParallelWeakening. lia. + (* Local variable *) - pose proof (All2_local_env_length predΓ'). rewrite !app_context_length in H0. + pose proof (All2_fold_length predΓ'). rewrite !app_context_length in H0. rewrite <- lift_simpl; pcuic. econstructor; auto. rewrite (weaken_nth_error_lt); try lia. now rewrite option_map_decl_body_map_decl heq_option_map. - (* Rel refl *) - pose proof (All2_local_env_length predΓ'). + pose proof (All2_fold_length predΓ'). assert(#|Γ''| = #|Δ''|). red in X1. pcuic. rewrite !app_context_length in H. assert (#|Γ'0| = #|Δ'|) by lia. rewrite H1. @@ -1078,18 +1079,30 @@ Section ParallelWeakening. eapply X0; eauto. now constructor. - - assert(#|Γ''| = #|Δ''|). red in X3; pcuic. - pose proof (All2_local_env_length predΓ'). + - (* iota reduction *) + assert(#|Γ''| = #|Δ''|). pcuic. + simplify_IH_hyps. + pose proof (All2_fold_length predΓ'). + specialize (X0 heq_length0). rewrite !app_context_length in H0. assert (#|Γ'0| = #|Δ'|) by lia. - rewrite lift_iota_red. - autorewrite with lift. - constructor; auto. - apply All2_map. solve_all. - apply All2_map. solve_all. - + rewrite lift_mkApps /=. + rewrite lift_iota_red //. + specialize (X0 _ _ X3). + eapply (pred_iota _ _ _ _ _ _ _ _ _ _ + (map_branches_k (lift #|Δ''|) #|Δ'| brs1)); solve_all. + * now rewrite nth_error_map heq_nth_error. + * now len. + * red. simpl. + specialize (b0 _ _ eq_refl _ _ eq_refl heq_length0 _ _ X3). + now rewrite !mapi_context_lift. + * specialize (b1 Γ0 (Γ'0 ,,, bcontext x) ltac:(rewrite app_context_assoc //)). + specialize (b1 Δ (Δ' ,,, bcontext y) ltac:(rewrite app_context_assoc //) heq_length0 _ _ X3). + len in b1. red. simpl. rewrite !mapi_context_lift. + now rewrite !lift_context_app in b1; len in b1; rewrite !app_context_assoc in b1. + - assert(#|Γ''| = #|Δ''|) by pcuic. - pose proof (All2_local_env_length predΓ'). + pose proof (All2_fold_length predΓ'). rewrite !app_context_length in H0. assert (#|Γ'0| = #|Δ'|) by lia. unfold unfold_fix in heq_unfold_fix. @@ -1097,7 +1110,7 @@ Section ParallelWeakening. econstructor; pcuic. rewrite !lift_fix_context. erewrite lift_fix_context. - eapply All2_local_env_weaken_pred_ctx'; pcuic. + eapply X2 => //. apply All2_map. clear X4. red in X3. unfold on_Trel, id in *. solve_all. rename_all_hyps. @@ -1115,34 +1128,58 @@ Section ParallelWeakening. eapply All2_map. solve_all. - assert(#|Γ''| = #|Δ''|) by pcuic. - pose proof (All2_local_env_length predΓ'). + pose proof (All2_fold_length predΓ'). rewrite !app_context_length in H0. assert (#|Γ'0| = #|Δ'|) by lia. unfold unfold_cofix in heq_unfold_cofix. - destruct (nth_error mfix1 idx) eqn:Hnth; noconf heq_unfold_cofix. simpl. - econstructor; pcuic. - rewrite !lift_fix_context. - erewrite lift_fix_context. - eapply All2_local_env_weaken_pred_ctx'; pcuic. - apply All2_map. clear X2. red in X3. - unfold on_Trel, id in *. - solve_all. rename_all_hyps. - specialize (forall_Γ0 Γ0 (Γ'0 ,,, fix_context mfix0) - ltac:(now rewrite app_context_assoc)). - specialize (forall_Γ0 Δ (Δ' ,,, fix_context mfix1) - ltac:(now rewrite app_context_assoc) heq_length _ _ ltac:(eauto)). - rewrite !lift_context_app !Nat.add_0_r !app_context_length !fix_context_length - !app_context_assoc in forall_Γ0. - now rewrite !lift_fix_context. - unfold unfold_cofix. rewrite nth_error_map. rewrite Hnth. simpl. - f_equal. f_equal. - rewrite distr_lift_subst. rewrite cofix_subst_length. f_equal. - now rewrite (map_cofix_subst (fun k => lift #|Δ''| (k + #|Δ'|))). - eapply All2_map. solve_all. - eapply All2_map. solve_all. + destruct (nth_error mfix1 idx) eqn:Hnth; noconf heq_unfold_cofix. + simpl. + econstructor. all:try solve [pcuic]. + * simplify_IH_hyps. simpl in *. + rewrite !lift_fix_context. + erewrite lift_fix_context. + now eapply X2. + * apply All2_map. clear X2 X6 X5 X4. simpl. red in X3. + unfold on_Trel, id in *. + solve_all. rename_all_hyps. + specialize (forall_Γ2 Γ0 (Γ'0 ,,, fix_context mfix0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ2 Δ (Δ' ,,, fix_context mfix1) + ltac:(now rewrite app_context_assoc) heq_length _ _ ltac:(eauto)). + rewrite !lift_context_app !Nat.add_0_r !app_context_length !fix_context_length + !app_context_assoc in forall_Γ2. + now rewrite !lift_fix_context. + * unfold unfold_cofix. rewrite nth_error_map. rewrite Hnth. simpl. + f_equal. f_equal. + rewrite distr_lift_subst. rewrite cofix_subst_length. f_equal. + now rewrite (map_cofix_subst (fun k => lift #|Δ''| (k + #|Δ'|))). + * eapply All2_map. solve_all. + * eapply All2_map. solve_all. + * red. simpl. rewrite !mapi_context_lift /shiftf. + now eapply X7. + * simpl. + rewrite !mapi_context_lift. + specialize (forall_Γ Γ0 + (Γ'0 ,,, pcontext p0) + ltac:(now rewrite app_context_assoc) + Δ (Δ' ,,, pcontext p1) + ltac:(now rewrite app_context_assoc) heq_length _ _ X11). + rewrite !lift_context_app Nat.add_0_r !app_context_assoc in forall_Γ. + now len in forall_Γ. + * solve_all; red; cbn. + + rewrite !mapi_context_lift. + now eapply b0. + + rewrite !mapi_context_lift. + specialize (b1 Γ0 + (Γ'0 ,,, bcontext x) + ltac:(now rewrite app_context_assoc) + Δ (Δ' ,,, bcontext y) + ltac:(now rewrite app_context_assoc) heq_length _ _ X11). + rewrite !lift_context_app Nat.add_0_r !app_context_assoc in b1. + now len in b1. - assert(#|Γ''| = #|Δ''|) by pcuic. - pose proof (All2_local_env_length predΓ'). + pose proof (All2_fold_length predΓ'). rewrite !app_context_length in H0. assert (#|Γ'0| = #|Δ'|) by lia. unfold unfold_cofix in heq_unfold_cofix. @@ -1150,7 +1187,7 @@ Section ParallelWeakening. econstructor; pcuic. rewrite !lift_fix_context. erewrite lift_fix_context. - eapply All2_local_env_weaken_pred_ctx'; pcuic. + now eapply X2. apply All2_map. clear X2. red in X3. unfold on_Trel, id in *. solve_all. rename_all_hyps. @@ -1167,8 +1204,9 @@ Section ParallelWeakening. now rewrite (map_cofix_subst (fun k => lift #|Δ''| (k + #|Δ'|))). eapply All2_map. solve_all. - - assert(Hlen:#|Γ''| = #|Δ''|). eapply All2_local_env_length in X1; pcuic. + - assert(Hlen:#|Γ''| = #|Δ''|). eapply All2_fold_length in X1; pcuic. pose proof (lift_declared_constant _ _ _ #|Δ''| #|Δ'| wfΣ H). + rewrite -subst_instance_lift. econstructor; eauto. rewrite H0. now rewrite - !map_cst_body heq_cst_body. @@ -1185,35 +1223,57 @@ Section ParallelWeakening. rewrite !lift_context_snoc0 !Nat.add_0_r in forall_Γ1. econstructor; eauto. + - assert(Hlen:#|Γ''| = #|Δ''|). eapply All2_fold_length in X9; pcuic. + assert(Hlen':#|Γ'0| = #|Δ'|). + { eapply All2_fold_length in predΓ'; pcuic. + len in predΓ'; pcuic. } + econstructor; pcuic. + * eapply All2_map; solve_all. + * simpl. now rewrite !mapi_context_lift. + * specialize (forall_Γ Γ0 (Γ'0 ,,, pcontext p0) ltac:(rewrite app_context_assoc //)). + specialize (forall_Γ Δ (Δ' ,,, pcontext p1) ltac:(rewrite app_context_assoc //) + heq_length _ _ X9). + rewrite !lift_context_app !Nat.add_0_r !app_context_assoc in forall_Γ. + rewrite !mapi_context_lift. + simpl. now len in forall_Γ. + * solve_all. + + red; simpl. rewrite !mapi_context_lift. + now eapply b0. + + rewrite !mapi_context_lift. + specialize (b1 Γ0 (Γ'0 ,,, bcontext x) ltac:(rewrite app_context_assoc //)). + specialize (b1 Δ (Δ' ,,, bcontext y) ltac:(rewrite app_context_assoc //) + heq_length _ _ X9). + rewrite !lift_context_app !Nat.add_0_r !app_context_assoc in b1. + now len in b1. + + - assert(Hlen:#|Γ''| = #|Δ''|). eapply All2_fold_length in X4; pcuic. + constructor; eauto. + * rewrite !lift_fix_context. now eapply X2. + * apply All2_map. clear X2. red in X3. + unfold on_Trel, id in *. + solve_all. rename_all_hyps. + specialize (forall_Γ _ _ eq_refl _ _ eq_refl heq_length _ _ X4). + specialize (forall_Γ0 Γ0 (Γ'0 ,,, fix_context mfix0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ0 Δ (Δ' ,,, fix_context mfix1) + ltac:(now rewrite app_context_assoc) heq_length _ _ X4). + rewrite !lift_context_app !Nat.add_0_r !app_context_length !fix_context_length + !app_context_assoc in forall_Γ0. + now rewrite !lift_fix_context. + - econstructor; pcuic. - rewrite !lift_fix_context. revert X2. - eapply All2_local_env_weaken_pred_ctx'; pcuic. - apply All2_map. clear X2. red in X3. - unfold on_Trel, id in *. - solve_all. rename_all_hyps. - specialize (forall_Γ _ _ eq_refl _ _ eq_refl heq_length _ _ X4). - specialize (forall_Γ0 Γ0 (Γ'0 ,,, fix_context mfix0) - ltac:(now rewrite app_context_assoc)). - specialize (forall_Γ0 Δ (Δ' ,,, fix_context mfix1) - ltac:(now rewrite app_context_assoc) heq_length _ _ X4). - rewrite !lift_context_app !Nat.add_0_r !app_context_length !fix_context_length - !app_context_assoc in forall_Γ0. - now rewrite !lift_fix_context. - - - econstructor; pcuic. - rewrite !lift_fix_context. revert X2. - eapply All2_local_env_weaken_pred_ctx'; pcuic. - apply All2_map. clear X2. red in X3. - unfold on_Trel, id in *. - solve_all. rename_all_hyps. - specialize (forall_Γ _ _ eq_refl _ _ eq_refl heq_length _ _ X4). - specialize (forall_Γ0 Γ0 (Γ'0 ,,, fix_context mfix0) - ltac:(now rewrite app_context_assoc)). - specialize (forall_Γ0 Δ (Δ' ,,, fix_context mfix1) - ltac:(now rewrite app_context_assoc) heq_length _ _ X4). - rewrite !lift_context_app !Nat.add_0_r !app_context_length !fix_context_length - !app_context_assoc in forall_Γ0. - now rewrite !lift_fix_context. + * rewrite !lift_fix_context. now eapply X2. + * apply All2_map. clear X2. red in X3. + unfold on_Trel, id in *. + solve_all. rename_all_hyps. + specialize (forall_Γ _ _ eq_refl _ _ eq_refl heq_length _ _ X4). + specialize (forall_Γ0 Γ0 (Γ'0 ,,, fix_context mfix0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ0 Δ (Δ' ,,, fix_context mfix1) + ltac:(now rewrite app_context_assoc) heq_length _ _ X4). + rewrite !lift_context_app !Nat.add_0_r !app_context_length !fix_context_length + !app_context_assoc in forall_Γ0. + now rewrite !lift_fix_context. - specialize (forall_Γ0 Γ0 (Γ'0 ,, _) eq_refl _ (_ ,, _) eq_refl heq_length _ _ X3). rewrite !lift_context_snoc0 !Nat.add_0_r in forall_Γ0. @@ -1224,7 +1284,7 @@ Section ParallelWeakening. Qed. Lemma weakening_pred1_pred1 Σ Γ Δ Γ' Δ' M N : wf Σ -> - All2_local_env_over (pred1 Σ) Γ Δ Γ' Δ' -> + All2_fold_over (pred1 Σ) Γ Δ Γ' Δ' -> pred1 Σ Γ Δ M N -> pred1 Σ (Γ ,,, Γ') (Δ ,,, Δ') (lift0 #|Γ'| M) (lift0 #|Δ'| N). Proof. @@ -1239,47 +1299,41 @@ Section ParallelWeakening. intros; apply (weakening_pred1 Σ Γ [] Γ' Δ [] Γ' M N); eauto. eapply pred1_pred1_ctx in X0. pcuic. eapply pred1_pred1_ctx in X0. - apply All2_local_env_over_refl; auto. + apply All2_fold_over_refl; auto. Qed. - Lemma All2_local_env_over_pred1_ctx Σ Γ Γ' Δ Δ' : + Lemma All2_fold_over_pred1_ctx Σ Γ Γ' Δ Δ' : #|Δ| = #|Δ'| -> pred1_ctx Σ (Γ ,,, Δ) (Γ' ,,, Δ') -> - All2_local_env - (on_decl (on_decl_over (pred1 Σ) Γ Γ')) Δ Δ'. + All2_fold + (on_decls (on_decls_over (pred1 Σ) Γ Γ')) Δ Δ'. Proof. - intros. pose proof (All2_local_env_length X). - apply All2_local_env_app in X. + intros. pose proof (All2_fold_length X). + apply All2_fold_app_inv in X. intuition. auto. rewrite !app_context_length in H0. pcuic. Qed. - Hint Resolve All2_local_env_over_pred1_ctx : pcuic. + Hint Resolve All2_fold_over_pred1_ctx : pcuic. Lemma nth_error_pred1_ctx_all_defs {P} {Γ Δ} : - All2_local_env (on_decl P) Γ Δ -> + on_contexts P Γ Δ -> forall i body body', option_map decl_body (nth_error Γ i) = Some (Some body) -> option_map decl_body (nth_error Δ i) = Some (Some body') -> P (skipn (S i) Γ) (skipn (S i) Δ) body body'. Proof. - induction 1; destruct i; simpl; try discriminate. - intros. apply IHX; auto. - intros ? ? [= ->] [= ->]. apply p. - intros ? ? ? ?. apply IHX; auto. + induction 1; destruct i; simpl; try discriminate; depelim p => //; + intros; noconf H; noconf H0; auto. Qed. - Lemma All2_local_env_over_firstn_skipn: + Lemma All2_fold_over_firstn_skipn: forall (Σ : global_env) (i : nat) (Δ' R : context), pred1_ctx Σ Δ' R -> - All2_local_env_over (pred1 Σ) (skipn i Δ') (skipn i R) (firstn i Δ') (firstn i R). + All2_fold_over (pred1 Σ) (skipn i Δ') (skipn i R) (firstn i Δ') (firstn i R). Proof. intros Σ i Δ' R redr. induction redr in i |- *; simpl. - destruct i; constructor; pcuic. - destruct i; simpl; constructor; pcuic. apply IHredr. - repeat red. now rewrite /app_context !firstn_skipn. - repeat red. red in p. - destruct i; simpl; constructor; pcuic. apply IHredr. - repeat red. destruct p. - split; red; now rewrite /app_context !firstn_skipn. + * destruct i; constructor; pcuic. + * destruct i; simpl; constructor; pcuic. apply IHredr. + depelim p; constructor; auto; repeat red; now rewrite /app_context !firstn_skipn. Qed. End ParallelWeakening. @@ -1305,12 +1359,12 @@ Section ParallelSubstitution. Lemma psubst_length {Σ Γ Δ Γ' Δ' s s'} : psubst Σ Γ Δ s s' Γ' Δ' -> #|s| = #|Γ'| /\ #|s'| = #|Δ'| /\ #|s| = #|s'|. Proof. - induction 1; simpl; intuition auto with arith. + induction 1; simpl; intuition lia. Qed. Lemma psubst_length' {Σ Γ Δ Γ' Δ' s s'} : psubst Σ Γ Δ s s' Γ' Δ' -> #|s'| = #|Γ'|. Proof. - induction 1; simpl; auto with arith. + induction 1; simpl; lia. Qed. Lemma psubst_nth_error Σ Γ Δ Γ' Δ' s s' n t : @@ -1395,16 +1449,16 @@ Section ParallelSubstitution. eapply app_inj_length_l in Hr as [Hl' Hr]; auto. Qed. - Lemma All2_local_env_subst_ctx : + Lemma All2_fold_subst_ctx : forall (Σ : global_env) c c0 (Γ0 Δ : context) (Γ'0 : list context_decl) (Γ1 Δ1 : context) (Γ'1 : list context_decl) (s s' : list term), psubst Σ Γ0 Γ1 s s' Δ Δ1 -> #|Γ'0| = #|Γ'1| -> #|Γ0| = #|Γ1| -> - All2_local_env_over (pred1 Σ) Γ0 Γ1 Δ Δ1 -> - All2_local_env - (on_decl - (on_decl_over + All2_fold_over (pred1 Σ) Γ0 Γ1 Δ Δ1 -> + All2_fold + (on_decls + (on_decls_over (fun (Γ Γ' : context) (t t0 : term) => forall (Γ2 Δ0 : context) (Γ'2 : list context_decl), Γ = Γ2 ,,, Δ0 ,,, Γ'2 -> @@ -1413,44 +1467,38 @@ Section ParallelSubstitution. Γ' = Γ3 ,,, Δ2 ,,, Γ'3 -> #|Γ2| = #|Γ3| -> #|Γ'2| = #|Γ'3| -> - All2_local_env_over (pred1 Σ) Γ2 Γ3 Δ0 Δ2 -> + All2_fold_over (pred1 Σ) Γ2 Γ3 Δ0 Δ2 -> pred1 Σ (Γ2 ,,, subst_context s0 0 Γ'2) (Γ3 ,,, subst_context s'0 0 Γ'3) (subst s0 #|Γ'2| t) (subst s'0 #|Γ'3| t0)) (Γ0 ,,, Δ ,,, Γ'0) (Γ1 ,,, Δ1 ,,, Γ'1))) c c0 -> - All2_local_env (on_decl (on_decl_over (pred1 Σ) (Γ0 ,,, subst_context s 0 Γ'0) (Γ1 ,,, subst_context s' 0 Γ'1))) + All2_fold (on_decls (on_decls_over (pred1 Σ) (Γ0 ,,, subst_context s 0 Γ'0) (Γ1 ,,, subst_context s' 0 Γ'1))) (subst_context s #|Γ'0| c) (subst_context s' #|Γ'1| c0). Proof. intros. - pose proof (All2_local_env_length X1). + pose proof (All2_fold_length X1). induction X1; simpl; rewrite ?subst_context_snoc; constructor; auto; rename_all_hyps. - - red in p. red in p. rename_all_hyps. - specialize (forall_Γ2 _ _ (Γ'0 ,,, Γ) - ltac:(now rewrite app_context_assoc) _ _ (Γ'1,,, Γ') _ _ X - ltac:(now rewrite app_context_assoc) heq_length0 - ltac:(now rewrite !app_context_length; auto) X0). - simpl in *. - rewrite !subst_context_app !app_context_length !app_context_assoc !Nat.add_0_r in forall_Γ2. - simpl. red. - congruence. - - destruct p. red in o, o0. - specialize (o _ _ (Γ'0 ,,, Γ) - ltac:(now rewrite app_context_assoc) _ _ (Γ'1,,, Γ') _ _ X - ltac:(now rewrite app_context_assoc) heq_length0 - ltac:(now rewrite !app_context_length; auto) X0). - specialize (o0 _ _ (Γ'0 ,,, Γ) - ltac:(now rewrite app_context_assoc) _ _ (Γ'1,,, Γ') _ _ X - ltac:(now rewrite app_context_assoc) heq_length0 - ltac:(now rewrite !app_context_length; auto) X0). - simpl in *. - unfold on_decl_over. - rewrite !subst_context_app !app_context_length !app_context_assoc !Nat.add_0_r in o, o0. - simpl in *. split; congruence. + eapply All_decls_map, All_decls_impl; tea => /=. + unfold on_decls_over. intros; rename_all_hyps. + simpl in heq_length1. + specialize (forall_Γ2 _ _ (Γ'0 ,,, Γ) + ltac:(now rewrite app_context_assoc) _ _ (Γ'1,,, Γ') _ _ X + ltac:(now rewrite app_context_assoc) heq_length0 + ltac:(now rewrite !app_context_length; len; lia) X0). + simpl in *. + rewrite !subst_context_app !app_context_length !app_context_assoc !Nat.add_0_r in forall_Γ2. + simpl. congruence. + Qed. + + Lemma mapi_context_subst s k ctx : + mapi_context (shiftf (subst s) k) ctx = subst_context s k ctx. + Proof. + now rewrite mapi_context_fold. Qed. (** Parallel reduction is substitutive. *) Lemma substitution_let_pred1 Σ Γ Δ Γ' Γ1 Δ1 Γ'1 s s' M N : wf Σ -> psubst Σ Γ Γ1 s s' Δ Δ1 -> #|Γ| = #|Γ1| -> #|Γ'| = #|Γ'1| -> - All2_local_env_over (pred1 Σ) Γ Γ1 Δ Δ1 -> + All2_fold_over (pred1 Σ) Γ Γ1 Δ Δ1 -> pred1 Σ (Γ ,,, Δ ,,, Γ') (Γ1 ,,, Δ1 ,,, Γ'1) M N -> pred1 Σ (Γ ,,, subst_context s 0 Γ') (Γ1 ,,, subst_context s' 0 Γ'1) (subst s #|Γ'| M) (subst s' #|Γ'1| N). Proof. @@ -1462,60 +1510,87 @@ Section ParallelSubstitution. revert Γ Δ Γ'. revert Γl Γr M N HΓ. set(P' := - fun (Γl Γr : context) => - forall (Γ Δ : context) (Γ' : list context_decl), - Γl = Γ ,,, Δ ,,, Γ' -> - forall (Γ1 : list context_decl) (Δ1 : context) (Γ'1 : list context_decl) (s s' : list term), - psubst Σ Γ Γ1 s s' Δ Δ1 -> - Γr = Γ1 ,,, Δ1 ,,, Γ'1 -> - #|Γ| = #|Γ1| -> - All2_local_env_over (pred1 Σ) Γ Γ1 Δ Δ1 -> - pred1_ctx Σ (Γ ,,, subst_context s 0 Γ') (Γ1 ,,, subst_context s' 0 Γ'1)). - refine (pred1_ind_all_ctx Σ _ P' _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *; !intros; - try subst Γ Γ'; simplify_IH_hyps; cbn -[iota_red]; + fun (Γl Γr : context) => + forall (Γ Δ : context) (Γ' : list context_decl), + Γl = Γ ,,, Δ ,,, Γ' -> + forall (Γ1 : list context_decl) (Δ1 : context) (Γ'1 : list context_decl) (s s' : list term), + psubst Σ Γ Γ1 s s' Δ Δ1 -> + Γr = Γ1 ,,, Δ1 ,,, Γ'1 -> + #|Γ| = #|Γ1| -> + All2_fold_over (pred1 Σ) Γ Γ1 Δ Δ1 -> + pred1_ctx Σ (Γ ,,, subst_context s 0 Γ') (Γ1 ,,, subst_context s' 0 Γ'1)). + set(Pover := + fun (Γl Γr : context) (Δl Δr : context) => + forall (Γ Δ : context) (Γ' : list context_decl), + Γl = Γ ,,, Δ ,,, Γ' -> + forall (Γ1 : list context_decl) (Δ1 : context) (Γ'1 : list context_decl) (s s' : list term), + psubst Σ Γ Γ1 s s' Δ Δ1 -> + Γr = Γ1 ,,, Δ1 ,,, Γ'1 -> + #|Γ| = #|Γ1| -> + All2_fold_over (pred1 Σ) Γ Γ1 Δ Δ1 -> + pred1_ctx_over Σ (Γ ,,, subst_context s 0 Γ') (Γ1 ,,, subst_context s' 0 Γ'1) + (subst_context s #|Γ'| Δl) + (subst_context s' #|Γ'1| Δr)). + + refine (pred1_ind_all_ctx Σ _ P' Pover _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *; !intros; + try subst Γ Γ'; + lazymatch goal with + | |- context [tCase _ _ _ _] => idtac + | |- _ => simplify_IH_hyps + end; cbn -[iota_red]; match goal with |- context [iota_red _ _ _ _] => idtac | |- _ => autorewrite with lift end; - try specialize (forall_Γ _ _ _ eq_refl _ _ _ + try + + specialize (forall_Γ _ _ _ eq_refl _ _ _ _ _ Hs eq_refl heq_length heq_length0 HΔ); try specialize (forall_Γ0 _ _ _ eq_refl _ _ _ _ _ Hs eq_refl heq_length heq_length0 HΔ); try specialize (forall_Γ1 _ _ _ eq_refl _ _ _ _ _ Hs eq_refl heq_length heq_length0 HΔ); - try pose proof (All2_local_env_length X0); + try pose proof (All2_fold_length X0); simpl; try solve [ econstructor; eauto; try apply All2_map; unfold All2_prop_eq, All2_prop, on_Trel, id in *; solve_all]; unfold All2_prop_eq, All2_prop, on_Trel, id in *. - (* Contexts *) red. intros. subst. - pose proof (All2_local_env_length X1). + pose proof (All2_fold_length X1). rewrite !app_context_length in H |- *. assert (#|Γ'0| = #|Γ'1|) by lia. - eapply All2_local_env_over_app. eapply All2_local_env_app in predΓ'. + eapply All2_fold_over_app. eapply All2_fold_app_inv in predΓ'. subst P'. intuition auto. typeclasses eauto with pcuic. now rewrite !app_context_length. - eapply All2_local_env_app in X0 as [Xl Xr]. + eapply All2_fold_app_inv in X0 as [Xl Xr]. 2:{ rewrite !app_context_length. lia. } induction Xr; rewrite ?subst_context_snoc; constructor; pcuic. apply IHXr. + depelim predΓ'. all: hnf in H, H0. all: noconf H. noconf H0. auto. + depelim predΓ'. all: hnf in H, H0. all: noconf H. noconf H0. auto. + simpl in *. lia. + simpl in *. - repeat red. rewrite !Nat.add_0_r. eapply p; eauto. - + depelim predΓ'. all: hnf in H, H0. all: noconf H. - noconf H0. - auto. - simpl in *. - repeat red. apply IHXr. simpl in *. pcuic. lia. lia. - + depelim predΓ'. all: hnf in H, H0. all: noconf H. - noconf H0. - auto. - simpl in *. destruct p. - split; repeat red. - rewrite !Nat.add_0_r. simpl. eapply p; eauto. - rewrite !Nat.add_0_r. simpl. eapply p0; eauto. + repeat red. rewrite !Nat.add_0_r. + eapply All_decls_map, All_decls_impl; tea => /=. + rewrite /on_decls_over. intros. + eapply X0; eauto. + + - (* Reduction over *) + subst Pover; simpl; intros. + pose proof (length_of X4). + assert (#|Γ'0| = #|Γ'1|) by (subst; len in H; lia). + clear X0 X1 X2. + rewrite - !mapi_context_subst. + eapply All2_fold_mapi, All2_fold_impl_ind; tea. + unfold on_decls_over; simpl. intros. + pose proof (length_of X0). + rewrite !mapi_context_subst /shiftf. + subst Γ Γ'. rewrite - app_context_assoc in X1. + specialize (X1 _ _ _ eq_refl). + rewrite - app_context_assoc in X1. + specialize (X1 _ _ _ _ _ X eq_refl H2). + rewrite !subst_context_app !app_context_assoc in X1. + len in X1; eapply X1. len in H. lia. exact X4. - (* Beta *) specialize (forall_Γ _ _ (_ ,, _) eq_refl _ _ (_ ,, _) @@ -1546,7 +1621,7 @@ Section ParallelSubstitution. pose proof (nth_error_Some_length heq_nth_error1). rewrite -> nth_error_app_context_lt by lia. rewrite - heq_length0 heq_nth_error1 => [= <-]. - eapply weakening_pred1_pred1 in b0. 2:eauto. 2:eapply All2_local_env_app. 2:eapply X0. + eapply weakening_pred1_pred1 in b0. 2:eauto. 2:eapply All2_fold_app_inv. 2:eapply X0. rewrite !subst_context_length in b0. rewrite <- subst_skipn'; try lia. now replace (S i - #|Γ'0|) with (S (i - #|Γ'0|)) by lia. lia. @@ -1590,7 +1665,7 @@ Section ParallelSubstitution. rewrite - heq_length0 e. rewrite - {1}(subst_context_length s 0 Γ'0). rewrite {1}heq_length0 -(subst_context_length s' 0 Γ'1). - eapply weakening_pred1_pred1; auto. eapply All2_local_env_over_pred1_ctx. + eapply weakening_pred1_pred1; auto. eapply All2_fold_over_pred1_ctx. now rewrite !subst_context_length. auto. ++ eapply psubst_nth_error_None in Heq; eauto. intuition; rename_all_hyps. @@ -1600,99 +1675,137 @@ Section ParallelSubstitution. eauto with pcuic. + constructor. auto. - - rewrite subst_iota_red. + - rewrite subst_iota_red //. autorewrite with subst. - econstructor. eauto. - apply All2_map. solve_all. unfold on_Trel. solve_all. + econstructor; eauto. + * apply All2_map. solve_all. + * now erewrite nth_error_map, heq_nth_error. + * now len. + * solve_all; red; cbn. + { now rewrite !mapi_context_subst. } + specialize (b1 Γ0 Δ (Γ'0 ,,, bcontext x) ltac:(rewrite app_context_assoc //)). + specialize (b1 Γ1 Δ1 (Γ'1 ,,, bcontext y) _ _ Hs ltac:(rewrite app_context_assoc //) + heq_length0). + forward b1. { now len; rewrite (length_of a0). } + len in b1. rewrite !mapi_context_subst. + now rewrite !subst_context_app in b1; len in b1; rewrite !app_context_assoc in b1. - autorewrite with subst. simpl. unfold unfold_fix in heq_unfold_fix. destruct (nth_error mfix1 idx) eqn:Hnth; noconf heq_unfold_fix. - econstructor; auto with pcuic. eapply X0; eauto with pcuic. - rewrite !subst_fix_context. - erewrite subst_fix_context. - eapply All2_local_env_subst_ctx; pcuic. - apply All2_map. clear X2. red in X3. - unfold on_Trel, id in *. - solve_all. rename_all_hyps. - specialize (forall_Γ0 _ _ (Γ'0 ,,, fix_context mfix0) - ltac:(now rewrite app_context_assoc)). - specialize (forall_Γ0 _ _ (Γ'1 ,,, fix_context mfix1) _ _ Hs - ltac:(now rewrite app_context_assoc) heq_length). - rewrite !app_context_length - in forall_Γ0. pose proof (All2_local_env_length X1). - forward forall_Γ0. lia. specialize (forall_Γ0 HΔ). - rewrite !subst_fix_context. - now rewrite !fix_context_length !subst_context_app - !Nat.add_0_r !app_context_assoc in forall_Γ0. - unfold unfold_fix. rewrite nth_error_map. rewrite Hnth. simpl. - f_equal. f_equal. - rewrite (map_fix_subst (fun k => subst s' (k + #|Γ'1|))). - intros. reflexivity. simpl. - now rewrite (distr_subst_rec _ _ _ _ 0) fix_subst_length. - apply subst_is_constructor; auto. - eapply All2_map. solve_all. + econstructor; auto with pcuic. + * eapply X0; eauto with pcuic. + * rewrite !subst_fix_context. + erewrite subst_fix_context. + now eapply X2. + * apply All2_map. clear X2. red in X3. + unfold on_Trel, id in *. + solve_all. rename_all_hyps. + specialize (forall_Γ0 _ _ (Γ'0 ,,, fix_context mfix0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ0 _ _ (Γ'1 ,,, fix_context mfix1) _ _ Hs + ltac:(now rewrite app_context_assoc) heq_length). + rewrite !app_context_length + in forall_Γ0. pose proof (All2_fold_length X1). + forward forall_Γ0. lia. specialize (forall_Γ0 HΔ). + rewrite !subst_fix_context. + now rewrite !fix_context_length !subst_context_app + !Nat.add_0_r !app_context_assoc in forall_Γ0. + * unfold unfold_fix. rewrite nth_error_map. rewrite Hnth. simpl. + f_equal. f_equal. + rewrite (map_fix_subst (fun k => subst s' (k + #|Γ'1|))). + intros. reflexivity. simpl. + now rewrite (distr_subst_rec _ _ _ _ 0) fix_subst_length. + * apply subst_is_constructor; auto. + * eapply All2_map. solve_all. - autorewrite with subst. simpl. unfold unfold_cofix in heq_unfold_cofix. destruct (nth_error mfix1 idx) eqn:Hnth; noconf heq_unfold_cofix. econstructor; eauto. - rewrite !subst_fix_context. - erewrite subst_fix_context. - eapply All2_local_env_subst_ctx; pcuic. - apply All2_map. clear X2. red in X3. - unfold on_Trel, id in *. - solve_all. rename_all_hyps. - specialize (forall_Γ0 _ _ (Γ'0 ,,, fix_context mfix0) - ltac:(now rewrite app_context_assoc)). - specialize (forall_Γ0 _ _ (Γ'1 ,,, fix_context mfix1) _ _ Hs - ltac:(now rewrite app_context_assoc) heq_length). - rewrite !app_context_length in forall_Γ0. - pose proof (All2_local_env_length X1). - forward forall_Γ0. lia. specialize (forall_Γ0 HΔ). - rewrite !subst_fix_context. - now rewrite !fix_context_length !subst_context_app - !Nat.add_0_r !app_context_assoc in forall_Γ0. - unfold unfold_cofix. rewrite nth_error_map. rewrite Hnth. simpl. - f_equal. f_equal. - rewrite (map_cofix_subst (fun k => subst s' (k + #|Γ'1|))). - intros. reflexivity. simpl. - now rewrite (distr_subst_rec _ _ _ _ 0) cofix_subst_length. - - eapply All2_map. solve_all. - eapply All2_map. solve_all. + * rewrite !subst_fix_context. + erewrite subst_fix_context. + now eapply X2. + * apply All2_map. clear X2. red in X3. + unfold on_Trel, id in *. + solve_all. rename_all_hyps. + specialize (forall_Γ1 _ _ (Γ'0 ,,, fix_context mfix0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ1 _ _ (Γ'1 ,,, fix_context mfix1) _ _ Hs + ltac:(now rewrite app_context_assoc) heq_length). + rewrite !app_context_length in forall_Γ1. + pose proof (All2_fold_length X1). + forward forall_Γ1. lia. specialize (forall_Γ1 HΔ). + rewrite !subst_fix_context. + now rewrite !fix_context_length !subst_context_app + !Nat.add_0_r !app_context_assoc in forall_Γ1. + * unfold unfold_cofix. rewrite nth_error_map. rewrite Hnth. simpl. + f_equal. f_equal. + rewrite (map_cofix_subst (fun k => subst s' (k + #|Γ'1|))). + intros. reflexivity. simpl. + now rewrite (distr_subst_rec _ _ _ _ 0) cofix_subst_length. + + * eapply All2_map. solve_all. + * eapply All2_map. solve_all. + * red; cbn. rewrite !mapi_context_subst. + now eapply X7. + * cbn. rewrite !mapi_context_subst. + have lenpctx := length_of X6. + have len' := length_of predΓ'. len in len'. + clear -heq_length lenpctx len' forall_Γ Hs HΔ. + specialize (forall_Γ _ _ (Γ'0 ,,, pcontext p0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ _ _ (Γ'1 ,,, pcontext p1) _ _ Hs + ltac:(now rewrite app_context_assoc) heq_length). + rewrite !subst_context_app !app_context_assoc in forall_Γ; len in forall_Γ. + eapply forall_Γ. + { move: (length_of HΔ). lia. } + exact HΔ. + + * solve_all; red; cbn; rewrite !mapi_context_subst. + + now eapply b0. + + rename_all_hyps. + have lenbctx := length_of a0. + have len' := length_of predΓ'. len in len'. + clear -heq_length lenbctx len' forall_Γ0 Hs HΔ. + specialize (forall_Γ0 _ _ (Γ'0 ,,, bcontext x) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ0 _ _ (Γ'1 ,,, bcontext y) _ _ Hs + ltac:(now rewrite app_context_assoc) heq_length). + rewrite !subst_context_app !app_context_assoc in forall_Γ0; len in forall_Γ0. + eapply forall_Γ0. + { move: (length_of HΔ). lia. } + exact HΔ. - autorewrite with subst. simpl. unfold unfold_cofix in heq_unfold_cofix. destruct (nth_error mfix1 idx) eqn:Hnth; noconf heq_unfold_cofix. simpl. - econstructor. red in X0. eauto 1 with pcuic. unshelve eapply X0. - shelve. shelve. eauto. eauto. eauto. - eauto. eauto. - pcuic. - rewrite !subst_fix_context. - erewrite subst_fix_context. - eapply All2_local_env_subst_ctx. eapply Hs. auto. auto. auto. - eapply X2. - apply All2_map. clear X2. red in X3. - unfold on_Trel, id in *. - solve_all. rename_all_hyps. - specialize (forall_Γ0 _ _ (Γ'0 ,,, fix_context mfix0) - ltac:(now rewrite app_context_assoc)). - specialize (forall_Γ0 _ _ (Γ'1 ,,, fix_context mfix1) _ _ Hs - ltac:(now rewrite app_context_assoc) heq_length). - rewrite !app_context_length in forall_Γ0. pose proof (All2_local_env_length X1). - forward forall_Γ0. lia. specialize (forall_Γ0 HΔ). - rewrite !subst_fix_context. - now rewrite !fix_context_length !subst_context_app - !Nat.add_0_r !app_context_assoc in forall_Γ0. - unfold unfold_cofix. rewrite nth_error_map. rewrite Hnth. simpl. - f_equal. f_equal. - rewrite (map_cofix_subst (fun k => subst s' (k + #|Γ'1|))). - intros. reflexivity. simpl. - now rewrite (distr_subst_rec _ _ _ _ 0) cofix_subst_length. - eapply All2_map. solve_all. - - - pose proof (subst_declared_constant _ _ _ s' #|Γ'0| u wfΣ H). + econstructor. + * red in X0. eauto 1 with pcuic. unshelve eapply X0. 1-2:shelve. + all:eauto. + * rewrite !subst_fix_context. + erewrite subst_fix_context. + now eapply X2. + * apply All2_map. clear X2. red in X3. + unfold on_Trel, id in *. + solve_all. rename_all_hyps. + specialize (forall_Γ0 _ _ (Γ'0 ,,, fix_context mfix0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ0 _ _ (Γ'1 ,,, fix_context mfix1) _ _ Hs + ltac:(now rewrite app_context_assoc) heq_length). + rewrite !app_context_length in forall_Γ0. pose proof (All2_fold_length X1). + forward forall_Γ0. lia. specialize (forall_Γ0 HΔ). + rewrite !subst_fix_context. + now rewrite !fix_context_length !subst_context_app + !Nat.add_0_r !app_context_assoc in forall_Γ0. + * unfold unfold_cofix. rewrite nth_error_map. rewrite Hnth. simpl. + f_equal. f_equal. + rewrite (map_cofix_subst (fun k => subst s' (k + #|Γ'1|))). + intros. reflexivity. simpl. + now rewrite (distr_subst_rec _ _ _ _ 0) cofix_subst_length. + * eapply All2_map. solve_all. + + - pose proof (subst_declared_constant (empty_ext Σ) _ _ s' #|Γ'0| u wfΣ H). apply (f_equal cst_body) in H0. rewrite <- !map_cst_body in H0. rewrite heq_cst_body in H0. simpl in H0. noconf H0. simpl in H0. rewrite heq_length0 in H0. rewrite H0. @@ -1714,9 +1827,37 @@ Section ParallelSubstitution. econstructor; eauto. - econstructor; eauto. - { rewrite !subst_fix_context. eapply All2_local_env_subst_ctx; eauto. } + * eapply All2_map; solve_all. + * red; cbn; rewrite !mapi_context_subst. + now eapply X3. + * cbn; rewrite !mapi_context_subst. + have lenpctx := length_of X2. + have len' := length_of predΓ'. len in len'. + clear -heq_length lenpctx len' forall_Γ Hs HΔ. + specialize (forall_Γ _ _ (Γ'0 ,,, pcontext p0) + ltac:(now rewrite app_context_assoc)). + specialize (forall_Γ _ _ (Γ'1 ,,, pcontext p1) _ _ Hs + ltac:(now rewrite app_context_assoc) heq_length). + rewrite !subst_context_app !app_context_assoc in forall_Γ; len in forall_Γ. + eapply forall_Γ. + { move: (length_of HΔ). lia. } + exact HΔ. + * eapply All2_map; solve_all; red; cbn; rewrite !mapi_context_subst. + + now eapply b0. + + have lenbctx := length_of a0. + have len' := length_of predΓ'. len in len'. + clear -heq_length lenbctx len' b1 Hs HΔ. + specialize (b1 _ _ (Γ'0 ,,, bcontext x) + ltac:(now rewrite app_context_assoc) + _ _ (Γ'1 ,,, bcontext y) _ _ Hs + ltac:(now rewrite app_context_assoc) heq_length). + rewrite !subst_context_app !app_context_assoc in b1; len in b1. + eapply b1. { move: (length_of HΔ); lia. } + exact HΔ. + - econstructor; eauto. + { rewrite !subst_fix_context. now eapply X2. } apply All2_map. red in X0. unfold on_Trel, id in *. - pose proof (All2_length _ _ X3). + pose proof (All2_length X3). eapply All2_impl; eauto. simpl. intros. destruct X. destruct o, p. destruct p. rename_all_hyps. specialize (forall_Γ1 _ _ (_ ,,, fix_context mfix0) ltac:(now rewrite - app_context_assoc) @@ -1733,9 +1874,9 @@ Section ParallelSubstitution. app_context_assoc in forall_Γ1. auto. - econstructor; eauto. - { rewrite !subst_fix_context. eapply All2_local_env_subst_ctx; eauto. } + { rewrite !subst_fix_context. now eapply X2. } apply All2_map. red in X0. unfold on_Trel, id in *. - pose proof (All2_length _ _ X3). + pose proof (All2_length X3). eapply All2_impl; eauto. simpl. intros. destruct X. destruct o, p. destruct p. rename_all_hyps. specialize (forall_Γ1 _ _ (_ ,,, fix_context mfix0) ltac:(now rewrite - app_context_assoc) @@ -1775,11 +1916,11 @@ Section ParallelSubstitution. - constructor; auto with pcuic. forward H by pcuic. + constructor; pcuic. apply pred1_pred1_ctx in redN. - depelim redN. pcuic. + depelim redN. pcuic. now depelim a. + simpl in H |- *. apply pred1_pred1_ctx in redN; pcuic. - depelim redN; pcuic. + depelim redN; pcuic. now depelim a. - pose proof (pred1_pred1_ctx _ redN). depelim X. - apply H; pcuic. auto. constructor; pcuic. + apply H; pcuic. Qed. Lemma substitution0_let_pred1 {Σ Γ Δ na na' M M' A A' N N'} : wf Σ -> @@ -1789,13 +1930,12 @@ Section ParallelSubstitution. Proof. intros wfΣ redM redN. pose proof (substitution_let_pred1 Σ Γ [vdef na M A] [] Δ [vdef na' M' A'] [] [M] [M'] N N' wfΣ) as H. - pose proof (pred1_pred1_ctx _ redN). depelim X. - simpl in o. + pose proof (pred1_pred1_ctx _ redN). depelim X. depelim a. forward H. - - pose proof (psubst_vdef Σ Γ Δ [] [] [] [] na na' M M' A A'). + - pose proof (psubst_vdef Σ Γ Δ [] [] [] [] na na M M' A A'). rewrite !subst_empty in X0. apply X0; pcuic. - apply H; pcuic. - econstructor; auto with pcuic. + econstructor; auto with pcuic. constructor; auto. Qed. End ParallelSubstitution. diff --git a/pcuic/theories/PCUICParallelReductionConfluence.v b/pcuic/theories/PCUICParallelReductionConfluence.v index f12427caa..c7d1da8aa 100644 --- a/pcuic/theories/PCUICParallelReductionConfluence.v +++ b/pcuic/theories/PCUICParallelReductionConfluence.v @@ -1,15 +1,21 @@ (* Distributed under the terms of the MIT license. *) +From Coq Require CMorphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICSize PCUICLiftSubst PCUICSigmaCalculus PCUICUnivSubst PCUICTyping PCUICReduction PCUICSubstitution - PCUICReflect PCUICClosed PCUICParallelReduction. + PCUICReflect PCUICInduction PCUICClosed + PCUICRename PCUICInst PCUICParallelReduction PCUICWeakening. Require Import ssreflect ssrbool. Require Import Morphisms CRelationClasses. From Equations Require Import Equations. +Add Search Blacklist "pred1_rect". +Add Search Blacklist "_equation_". -Derive Signature for pred1 All2_local_env. +Derive Signature for pred1 All2_fold. + +Local Open Scope sigma_scope. Local Set Keyed Unification. @@ -42,6 +48,51 @@ Proof. funelim (map_In l g) => //; simpl; rewrite (H f0); trivial. Qed. +Equations mapi_context_In (ctx : context) (f : nat -> forall (x : context_decl), In x ctx -> context_decl) : context := +mapi_context_In nil _ := nil; +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) : + mapi_context_In ctx (fun n (x : context_decl) (_ : In x ctx) => map_decl (f n) x) = + mapi_context f ctx. +Proof. + remember (fun n (x : context_decl) (_ : In x ctx) => map_decl (f n) x) as g. + funelim (mapi_context_In ctx g) => //; simpl; rewrite (H f0); trivial. +Qed. + +Equations fold_context_In (ctx : context) (f : context -> forall (x : context_decl), In x ctx -> context_decl) : context := +fold_context_In nil _ := nil; +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 -> context_decl -> context_decl) (ctx : context) : context := + fold_context f nil := nil; + 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. + now apply_funelim (fold_context f Γ); intros; simpl; auto; f_equal. +Qed. +Hint Rewrite fold_context_length : len. + +Lemma fold_context_In_spec (f : context -> context_decl -> context_decl) (ctx : context) : + fold_context_In ctx (fun n (x : context_decl) (_ : In x ctx) => f n x) = + fold_context f ctx. +Proof. + remember (fun n (x : context_decl) (_ : In x ctx) => f n x) as g. + funelim (fold_context_In ctx g) => //; simpl; rewrite (H f0); trivial. +Qed. + +Instance fold_context_Proper : Proper (`=2` ==> `=1`) fold_context. +Proof. + intros f f' Hff' x. + funelim (fold_context f x); simpl; auto. simp fold_context. + now rewrite (H f' Hff'). +Qed. + Section list_size. Context {A : Type} (f : A -> nat). @@ -51,21 +102,10 @@ Section list_size. intros. induction xs. destruct H. * destruct H. simpl; subst. lia. - specialize (IHxs H). simpl. lia. + specialize (IHxs H). simpl. lia. Qed. End list_size. -Lemma size_mkApps f l : size (mkApps f l) = size f + list_size size l. -Proof. - induction l in f |- *; simpl; try lia. - rewrite IHl. simpl. lia. -Qed. - -Lemma list_size_app (l l' : list term) : list_size size (l ++ l') = list_size size l + list_size size l'. -Proof. - induction l; simpl; auto. - rewrite IHl. lia. -Qed. Lemma mfixpoint_size_In {mfix d} : In d mfix -> @@ -217,62 +257,6 @@ Equations view_construct0_cofix (t : term) : construct0_cofix_view t := | tCoFix mfix idx => construct0_cofix_cofix mfix idx; | t => construct0_cofix_other t _ }. -(** This induction principle gives a general induction hypothesis for applications, - allowing to apply the induction to their head. *) -Lemma term_ind_size_app : - forall (P : term -> Type), - (forall (n : nat), P (tRel n)) -> - (forall (i : ident), P (tVar i)) -> - (forall (n : nat) (l : list term), All (P) l -> P (tEvar n l)) -> - (forall s, P (tSort s)) -> - (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> P (tProd n t t0)) -> - (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', size t' < size (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 (p : inductive * nat) (t : term), - P t -> forall t0 : term, P t0 -> forall l : list (nat * term), - tCaseBrsProp (P) l -> P (tCase p t t0 l)) -> - (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)) -> - (forall p, P (tPrim p)) -> - forall (t : term), P t. -Proof. - intros. - revert t. set(foo:=CoreTactics.the_end_of_the_section). intros. - Subterm.rec_wf_rel aux t (precompose lt size). simpl. clear H0. - assert (auxl : forall {A} (l : list A) (f : A -> term), list_size (fun x => size (f x)) l < size pr1 -> - All (fun x => P (f x)) l). - { induction l; constructor. eapply aux. red. simpl in H. lia. apply IHl. simpl in H. lia. } - assert (forall m, list_size (fun x : def term => size (dtype x)) m < S (mfixpoint_size size m)). - { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } - assert (forall m, list_size (fun x : def term => size (dbody x)) m < S (mfixpoint_size size m)). - { clear. unfold mfixpoint_size, def_size. induction m. simpl. auto. simpl. lia. } - - move aux at top. move auxl at top. - - !destruct pr1; eauto; - try match reverse goal with - |- context [tFix _ _] => idtac - | H : _ |- _ => solve [apply H; (eapply aux || eapply auxl); red; simpl; try lia] - end. - - eapply X12; try (apply aux; red; simpl; lia). - red. apply All_pair. split; apply auxl; simpl; auto. - - eapply X13; try (apply aux; red; simpl; lia). - red. apply All_pair. split; apply auxl; simpl; auto. -Defined. - Lemma fix_context_gen_assumption_context k Γ : assumption_context (fix_context_gen k Γ). Proof. rewrite /fix_context_gen. revert k. @@ -656,15 +640,121 @@ Section Rho. eapply (In_list_size size) in H. lia. Qed. - #[program] Definition map_brs {t} (rho : context -> forall x, size x < size t -> term) Γ (l : list (nat * term)) - (H : list_size (fun x : nat * term => size x.2) l < size t) := - (map_In l (fun x (H : In x l) => (x.1, rho Γ x.2 _))). + Section rho_ctx. + Context (Γ : context). + Context (rho : context -> forall x, size x <= context_size size Γ -> term). + + Program Definition rho_ctx_over_wf := + fold_context_In Γ (fun Γ' d hin => + match d with + | {| decl_name := na; decl_body := None; decl_type := T |} => + vass na (rho Γ' T _) + | {| decl_name := na; decl_body := Some b; decl_type := T |} => + vdef na (rho Γ' b _) (rho Γ' T _) + end). + + Next Obligation. + eapply (In_list_size (decl_size size)) in hin. + unfold decl_size at 1 in hin. simpl in *. unfold context_size. lia. + Qed. + + Next Obligation. + eapply (In_list_size (decl_size size)) in hin. + unfold decl_size at 1 in hin. simpl in *. unfold context_size. lia. + Qed. + Next Obligation. + eapply (In_list_size (decl_size size)) in hin. + unfold decl_size at 1 in hin. simpl in *. unfold context_size. lia. + Qed. + End rho_ctx. + + Notation fold_context_term f := (fold_context (fun Γ' => map_decl (f Γ'))). + + 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. + rewrite /rho_ctx_over_wf fold_context_In_spec. + apply fold_context_Proper. intros n x. + 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, size x < size t -> term) Γ + (br : branch term) (H : branch_size size br < size t) := + let bcontext' := rho_ctx_over_wf br.(bcontext) + (fun Γ' x Hx => rho (Γ ,,, Γ') x _) in + {| bcontext := bcontext'; + bbody := rho (Γ ,,, bcontext') br.(bbody) _ |}. + Solve Obligations with intros; unfold branch_size in *; lia. + + Definition map_br_gen (rho : context -> term -> term) Γ (br : branch term) := + let bcontext' := fold_context_term (fun Γ' => rho (Γ ,,, Γ')) br.(bcontext) in + {| bcontext := bcontext'; + bbody := rho (Γ ,,, bcontext') br.(bbody) |}. + + Lemma map_br_map (rho : context -> term -> term) t Γ l H : + @map_br_wf t (fun Γ x Hx => rho Γ x) Γ l H = map_br_gen rho Γ l. + Proof. + unfold map_br_wf, map_br_gen. now f_equal; autorewrite with rho. + Qed. + Hint Rewrite map_br_map : rho. + + #[program] Definition map_brs_wf {t} (rho : context -> forall x, size x < size t -> term) Γ + (l : list (branch term)) + (H : list_size (branch_size size) l < size t) := + map_In l (fun br (H : In br l) => map_br_wf rho Γ br _). Next Obligation. - eapply (In_list_size (fun x => size x.2)) in H. simpl in *. lia. + eapply (In_list_size (branch_size size)) in H. lia. + Qed. + + Lemma map_brs_map (rho : context -> term -> term) t Γ l H : + @map_brs_wf t (fun Γ x Hx => rho Γ x) Γ l H = map (map_br_gen rho Γ) l. + Proof. + unfold map_brs_wf, map_br_wf. rewrite map_In_spec. + apply map_ext => x. now autorewrite with rho. + Qed. + Hint Rewrite map_brs_map : rho. + + #[program] Definition rho_predicate_wf {t} (rho : context -> forall x, size x < size t -> term) Γ + (p : PCUICAst.predicate term) (H : predicate_size size p < size t) := + let pcontext' := rho_ctx_over_wf p.(pcontext) (fun Γ' x Hx => rho (Γ ,,, Γ') x _) in + {| pparams := map_terms rho Γ p.(pparams) _; + puinst := p.(puinst) ; + pcontext := pcontext' ; + preturn := rho (Γ ,,, pcontext') p.(preturn) _ |}. + + Solve Obligations with intros; unfold predicate_size in H; lia. + + Definition rho_predicate_gen (rho : context -> term -> term) Γ + (p : PCUICAst.predicate term) := + let pcontext' := fold_context_term (fun Γ' => rho (Γ ,,, Γ')) p.(pcontext) in + {| pparams := map (rho Γ) p.(pparams); + puinst := p.(puinst) ; + pcontext := 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. + unfold map_terms. now rewrite map_In_spec. + Qed. + Hint Rewrite map_terms_map : rho. + + Lemma rho_predicate_map_predicate {t} (rho : context -> term -> term) Γ p (H : predicate_size size p < size t) : + rho_predicate_wf (fun Γ x H => rho Γ x) Γ p H = + rho_predicate_gen rho Γ p. + Proof. + rewrite /rho_predicate_gen /rho_predicate_wf. + f_equal; simp rho => //. Qed. + Hint Rewrite @rho_predicate_map_predicate : rho. - Definition inspect {A} (x : A) : { y : A | y = x } := exist x eq_refl. + Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. + (** Needs well-founded recursion on the size of terms as we should reduce + strings of applications in one go. *) Equations? rho (Γ : context) (t : term) : term by wf (size t) := rho Γ (tApp t u) with view_lambda_fix_app t u := { | fix_lambda_app_lambda na T b [] u' := @@ -690,35 +780,48 @@ Section Rho. | Some None => tRel i; | None => tRel i }; - rho Γ (tCase (ind, pars) p x brs) with inspect (decompose_app x) := + 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 ind ind' := - { | true => - let p' := rho Γ p in - let args' := map_terms rho Γ args _ in - let brs' := map_brs rho Γ brs _ in - iota_red pars c args' brs'; + { | 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 #|skipn (ci_npar ci) args| + (context_assumptions (bcontext br)) then + let p' := rho_predicate_wf rho Γ p _ in + let args' := map_terms rho Γ args _ in + let br' := map_br_wf rho Γ br _ in + iota_red ci.(ci_npar) args' br' + else + let p' := rho_predicate_wf rho Γ p _ in + let brs' := map_brs_wf rho Γ brs _ in + let x' := rho Γ x in + tCase ci p' x' brs'; + | exist None eqbr => + let p' := rho_predicate_wf rho Γ p _ in + let brs' := map_brs_wf rho Γ brs _ in + let x' := rho Γ x in + tCase ci p' x' brs' }; | false => - let p' := rho Γ p in + let p' := rho_predicate_wf rho Γ p _ in let x' := rho Γ x in - let brs' := map_brs rho Γ brs _ in - tCase (ind, pars) p' x' brs' }; + let brs' := map_brs_wf rho Γ brs _ in + tCase ci p' x' brs' }; | construct_cofix_cofix mfix idx := - let p' := rho Γ p in + let p' := rho_predicate_wf rho Γ p _ in let args' := map_terms rho Γ args _ in - let brs' := map_brs rho Γ brs _ in + let brs' := map_brs_wf rho Γ brs _ in let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in - let mfix' := map_fix_rho (t:=tCase (ind, pars) p x brs) rho Γ mfixctx mfix _ 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 (ind, pars) p' (mkApps (subst0 (cofix_subst mfix') (dbody d)) args') brs' - | None => tCase (ind, pars) p' (rho Γ x) brs' + tCase ci p' (mkApps (subst0 (cofix_subst mfix') (dbody d)) args') brs' + | None => tCase ci p' (rho Γ x) brs' end; | construct_cofix_other t nconscof => - let p' := rho Γ p in + let p' := rho_predicate_wf rho Γ p _ in let x' := rho Γ x in - let brs' := map_brs rho Γ brs _ in - tCase (ind, pars) p' x' brs' } }; + let brs' := map_brs_wf rho Γ brs _ in + tCase ci p' x' brs' } }; rho Γ (tProj (i, pars, narg) x) with inspect (decompose_app x) := { | exist (f, args) eqx with view_construct0_cofix f := @@ -738,7 +841,7 @@ Section Rho. | construct0_cofix_other t nconscof => tProj (i, pars, narg) (rho Γ x) } ; rho Γ (tConst c u) with lookup_env Σ c := { | Some (ConstantDecl decl) with decl.(cst_body) := { - | Some body => subst_instance_constr u 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); @@ -762,45 +865,58 @@ Section Rho. - clear; abstract (rewrite size_mkApps /=; lia). - clear; abstract (rewrite size_mkApps /=; lia). - clear; abstract (rewrite list_size_app size_mkApps /=; lia). - - clear -eqx; eapply symmetry, decompose_app_inv in eqx. subst x. + - clear -eqx; eapply decompose_app_inv in eqx. subst x. abstract (rewrite size_mkApps /=; lia). - - clear; abstract (lia). - - clear -eqx; eapply symmetry, decompose_app_inv in eqx. subst x. + - clear -eqbr. + abstract (eapply (nth_error_size (branch_size size)) in eqbr; lia). + - clear -eqx; eapply decompose_app_inv in eqx. subst x. abstract (rewrite size_mkApps /=; lia). - clear. abstract lia. - - clear -eqx Hx. eapply symmetry, decompose_app_inv in eqx; subst x0. + - clear -eqx Hx. eapply decompose_app_inv in eqx; subst x0. abstract (rewrite size_mkApps /=; lia). - - clear -eqx. eapply symmetry, decompose_app_inv in eqx; subst x. + - clear -eqx. eapply decompose_app_inv in eqx; subst x. abstract (rewrite size_mkApps /=; lia). - - clear -eqx. eapply symmetry, decompose_app_inv in eqx; subst x. + - clear -eqx. eapply decompose_app_inv in eqx; subst x. abstract (rewrite size_mkApps /=; lia). - - clear -eqx. eapply symmetry, decompose_app_inv in eqx; subst x. + - clear -eqx. eapply decompose_app_inv in eqx; subst x. abstract (rewrite size_mkApps /=; lia). - - clear -eqx. eapply symmetry, decompose_app_inv in eqx; subst x. + - clear -eqx. eapply decompose_app_inv in eqx; subst x. abstract (rewrite size_mkApps /=; lia). - - clear -eqx Hx. eapply symmetry, decompose_app_inv in eqx; subst x0. + - clear -eqx Hx. eapply decompose_app_inv in eqx; subst x0. abstract (rewrite size_mkApps /=; lia). - - clear -eqx. eapply symmetry, decompose_app_inv in eqx; subst x. + - clear -eqx. eapply decompose_app_inv in eqx; subst x. abstract (rewrite size_mkApps /=; lia). Defined. - + + Notation rho_predicate := (rho_predicate_gen rho). + Notation rho_br := (map_br_gen rho). + Notation rho_ctx_over Γ := + (fold_context (fun Δ => map_decl (rho (Γ ,,, Δ)))). + Notation rho_ctx := (fold_context_term rho). + + Lemma rho_ctx_over_length Δ Γ : #|rho_ctx_over Δ Γ| = #|Γ|. + Proof. + now len. + Qed. + Definition rho_fix_context Γ mfix := fold_fix_context rho Γ [] mfix. Lemma rho_fix_context_length Γ mfix : #|rho_fix_context Γ mfix| = #|mfix|. Proof. 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. + (* 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. - Hint Rewrite map_terms_map : rho. + 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. + (* 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. - Hint Rewrite map_brs_map : rho. + Hint Rewrite map_brs_map : rho. *) Definition map_fix (rho : context -> term -> term) Γ mfixctx (mfix : mfixpoint term) := (map (map_def (rho Γ) (rho (Γ ,,, mfixctx))) mfix). @@ -834,12 +950,13 @@ Section Rho. intros isf. specialize (IHl isf). simpl. rewrite IHl. destruct (mkApps t l); auto. Qed. + Definition isFixLambda (t : term) : bool := - match t with - | tFix _ _ => true - | tLambda _ _ _ => true - | _ => false - end. + match t with + | tFix _ _ => true + | tLambda _ _ _ => true + | _ => false + end. Inductive fix_lambda_view : term -> Type := | fix_lambda_lambda na b t : fix_lambda_view (tLambda na b t) @@ -854,7 +971,7 @@ Section Rho. Lemma isFixLambda_app_mkApps' t l x : isFixLambda t -> isFixLambda_app (tApp (mkApps t l) x). Proof. induction l using rev_ind; simpl; auto. - destruct t; auto. + destruct t; auto. simpl => //. intros isl. specialize (IHl isl). simpl in IHl. now rewrite -mkApps_nested /=. @@ -1026,33 +1143,42 @@ Section Rho. - apply rho_fix_stuck. now rewrite e /=. Qed. - Lemma rho_app_case Γ ind pars p x brs : - rho Γ (tCase (ind, pars) p x brs) = + Lemma rho_app_case Γ ci p x brs : + rho Γ (tCase ci p x brs) = let (f, args) := decompose_app x in match f with | tConstruct ind' c u => - if eq_inductive ind ind' then - let p' := rho Γ p in - let args' := map (rho Γ) args in - let brs' := map (on_snd (rho Γ)) brs in - iota_red pars c args' brs' - else tCase (ind, pars) (rho Γ p) (rho Γ x) (map (on_snd (rho Γ)) brs) + if eq_inductive ci.(ci_ind) ind' then + match nth_error brs c with + | Some br => + if eqb #|skipn (ci_npar ci) args| (context_assumptions (bcontext br)) then + let p' := rho_predicate Γ p in + let args' := map (rho Γ) args in + let br' := rho_br Γ br in + iota_red ci.(ci_npar) args' br' + else tCase ci (rho_predicate Γ p) (rho Γ x) (map (rho_br Γ) brs) + | None => tCase ci (rho_predicate Γ p) (rho Γ x) (map (rho_br Γ) brs) + end + else tCase ci (rho_predicate Γ p) (rho Γ x) (map (rho_br Γ) brs) | tCoFix mfix idx => match nth_error mfix idx with | Some d => let fn := (subst0 (map (rho Γ) (cofix_subst mfix))) (rho (Γ ,,, fold_fix_context rho Γ [] mfix) (dbody d)) in - tCase (ind, pars) (rho Γ p) (mkApps fn (map (rho Γ) args)) (map (on_snd (rho Γ)) brs) - | None => tCase (ind, pars) (rho Γ p) (rho Γ x) (map (on_snd (rho Γ)) brs) + tCase ci (rho_predicate Γ p) (mkApps fn (map (rho Γ) args)) + (map (rho_br Γ) brs) + | None => tCase ci (rho_predicate Γ p) (rho Γ x) (map (rho_br Γ) brs) end - | _ => tCase (ind, pars) (rho Γ p) (rho Γ x) (map (on_snd (rho Γ)) brs) + | _ => tCase ci (rho_predicate Γ p) (rho Γ x) (map (rho_br Γ) brs) end. Proof. autorewrite with rho. set (app := inspect _). destruct app as [[f l] eqapp]. - rewrite -{2}eqapp. autorewrite with rho. + rewrite {2}eqapp. autorewrite with rho. destruct view_construct_cofix; autorewrite with rho. destruct eq_inductive eqn:eqi; simp rho => //. + destruct inspect as [[br|] eqnth]; simp rho; rewrite eqnth //. + simp rho. destruct unfold_cofix as [[rarg fn]|]; simp rho => //. simpl. autorewrite with rho. rewrite /map_fix nth_error_map. destruct nth_error => /=. f_equal. @@ -1065,7 +1191,7 @@ Section Rho. destruct nth_error => /= //. rewrite (map_cofix_subst rho (fun x y => rho (x ,,, y))) //. intros; simp rho; simpl; now simp rho. - simpl. eapply symmetry, decompose_app_inv in eqapp. + simpl. eapply decompose_app_inv in eqapp. subst x. destruct t; simpl in d => //. Qed. @@ -1093,7 +1219,7 @@ Section Rho. autorewrite with rho. set (app := inspect _). destruct app as [[f l] eqapp]. - rewrite -{2}eqapp. autorewrite with rho. + rewrite {2}eqapp. autorewrite with rho. destruct view_construct0_cofix; autorewrite with rho. destruct eq_inductive eqn:eqi; simp rho => //. set (arg' := inspect _). clearbody arg'. @@ -1111,13 +1237,11 @@ Section Rho. f_equal. f_equal. f_equal. rewrite (map_cofix_subst rho (fun x y => rho (x ,,, y))) //. intros. autorewrite with rho. simpl. now autorewrite with rho. - simpl. eapply symmetry, decompose_app_inv in eqapp. + simpl. eapply decompose_app_inv in eqapp. subst x. destruct t; simpl in d => //. now destruct n. Qed. - - Lemma fold_fix_context_rev_mapi {Γ l m} : fold_fix_context rho Γ l m = List.rev (mapi (fun (i : nat) (x : def term) => @@ -1161,96 +1285,81 @@ Section Rho. Section All2i. (** A special notion of All2 just for this proof *) - Inductive All2i {A B : Type} (R : nat -> A -> B -> Type) : list A -> list B -> Type := - All2i_nil : All2i R [] [] - | All2i_cons : forall (x : A) (y : B) (l : list A) (l' : list B), - R (List.length l) x y -> All2i R l l' -> All2i R (x :: l) (y :: l'). - Hint Constructors All2i : core pcuic. + Hint Constructors All2i : pcuic. + + Inductive All2i_ctx {A B : Type} (R : nat -> A -> B -> Type) : list A -> list B -> Type := + All2i_ctx_nil : All2i_ctx R [] [] + | All2i_ctx_cons : forall (x : A) (y : B) (l : list A) (l' : list B), + R (List.length l) x y -> All2i_ctx R l l' -> All2i_ctx R (x :: l) (y :: l'). + Hint Constructors All2i_ctx : core pcuic. - Lemma All2i_app {A B} (P : nat -> A -> B -> Type) l0 l0' l1 l1' : - All2i P l0' l1' -> - All2i (fun n => P (n + #|l0'|)) l0 l1 -> - All2i P (l0 ++ l0') (l1 ++ l1'). + Lemma All2i_ctx_app {A B} (P : nat -> A -> B -> Type) l0 l0' l1 l1' : + All2i_ctx P l0' l1' -> + All2i_ctx (fun n => P (n + #|l0'|)) l0 l1 -> + All2i_ctx P (l0 ++ l0') (l1 ++ l1'). Proof. intros H. induction 1; simpl. apply H. constructor. now rewrite app_length. apply IHX. Qed. - Lemma All2i_length {A B} (P : nat -> A -> B -> Type) l l' : - All2i P l l' -> #|l| = #|l'|. - Proof. induction 1; simpl; auto. Qed. + Lemma All2i_ctx_length {A B} (P : nat -> A -> B -> Type) l l' : + All2i_ctx P l l' -> #|l| = #|l'|. + Proof. induction 1; simpl; lia. Qed. - Lemma All2i_impl {A B} (P Q : nat -> A -> B -> Type) l l' : - All2i P l l' -> (forall n x y, P n x y -> Q n x y) -> All2i Q l l'. + Lemma All2i_ctx_impl {A B} (P Q : nat -> A -> B -> Type) l l' : + All2i_ctx P l l' -> (forall n x y, P n x y -> Q n x y) -> All2i_ctx Q l l'. Proof. induction 1; simpl; auto. Qed. - Lemma All2i_rev {A B} (P : nat -> A -> B -> Type) l l' : - All2i P l l' -> - All2i (fun n => P (#|l| - S n)) (List.rev l) (List.rev l'). + Lemma All2i_ctx_rev {A B} (P : nat -> A -> B -> Type) l l' : + All2i_ctx P l l' -> + All2i_ctx (fun n => P (#|l| - S n)) (List.rev l) (List.rev l'). Proof. induction 1. constructor. simpl List.rev. - apply All2i_app. repeat constructor. simpl. rewrite Nat.sub_0_r. auto. - simpl. eapply All2i_impl; eauto. intros. simpl in X0. now rewrite Nat.add_1_r. + apply All2i_ctx_app. repeat constructor. simpl. rewrite Nat.sub_0_r. auto. + simpl. eapply All2i_ctx_impl; eauto. intros. simpl in X0. now rewrite Nat.add_1_r. Qed. - - Inductive All2i_ctx {A B : Type} (R : nat -> A -> B -> Type) (n : nat) : list A -> list B -> Type := - All2i_ctx_nil : All2i_ctx R n [] [] - | All2i_ctx_cons : forall (x : A) (y : B) (l : list A) (l' : list B), - R n x y -> All2i_ctx R (S n) l l' -> All2i_ctx R n (x :: l) (y :: l'). - Hint Constructors All2i_ctx : core pcuic. - - Lemma All2i_ctx_app {A B} (P : nat -> A -> B -> Type) n l0 l0' l1 l1' : - All2i_ctx P (n + #|l0|) l0' l1' -> - All2i_ctx P n l0 l1 -> - All2i_ctx P n (l0 ++ l0') (l1 ++ l1'). - Proof. - intros H. - induction 1. simpl. now rewrite Nat.add_0_r in H. - simpl. rewrite Nat.add_succ_comm in IHX. specialize (IHX H). - now constructor. - Qed. - + Lemma All2i_rev_ctx {A B} (R : nat -> A -> B -> Type) (n : nat) (l : list A) (l' : list B) : - All2i R l l' -> All2i_ctx R 0 (List.rev l) (List.rev l'). + All2i_ctx R l l' -> All2i R 0 (List.rev l) (List.rev l'). Proof. induction 1. simpl. constructor. - simpl. apply All2i_ctx_app. simpl. rewrite List.rev_length. auto. - auto. + simpl. apply All2i_app => //. simpl. rewrite List.rev_length. pcuic. Qed. Lemma All2i_rev_ctx_gen {A B} (R : nat -> A -> B -> Type) (n : nat) (l : list A) (l' : list B) : - All2i_ctx R n l l' -> All2i (fun m => R (n + m)) (List.rev l) (List.rev l'). + All2i R n l l' -> All2i_ctx (fun m => R (n + m)) (List.rev l) (List.rev l'). Proof. induction 1. simpl. constructor. - simpl. eapply All2i_app. constructor. now rewrite Nat.add_0_r. constructor. - eapply All2i_impl; eauto. intros. + simpl. eapply All2i_ctx_app. constructor. now rewrite Nat.add_0_r. constructor. + eapply All2i_ctx_impl; eauto. intros. simpl in *. rewrite [S _]Nat.add_succ_comm in X0. now rewrite Nat.add_1_r. Qed. Lemma All2i_rev_ctx_inv {A B} (R : nat -> A -> B -> Type) (l : list A) (l' : list B) : - All2i_ctx R 0 l l' -> All2i R (List.rev l) (List.rev l'). + All2i R 0 l l' -> All2i_ctx R (List.rev l) (List.rev l'). Proof. intros. eapply All2i_rev_ctx_gen in X. simpl in X. apply X. Qed. - Lemma All2i_ctx_mapi {A B C D} (R : nat -> A -> B -> Type) + Lemma All2i_mapi_rec {A B C D} (R : nat -> A -> B -> Type) (l : list C) (l' : list D) (f : nat -> C -> A) (g : nat -> D -> B) n : - All2i_ctx (fun n x y => R n (f n x) (g n y)) n l l' -> - All2i_ctx R n (mapi_rec f l n) (mapi_rec g l' n). + All2i (fun n x y => R n (f n x) (g n y)) n l l' -> + All2i R n (mapi_rec f l n) (mapi_rec g l' n). Proof. induction 1; constructor; auto. Qed. - Lemma All2i_ctx_trivial {A B} (R : nat -> A -> B -> Type) (H : forall n x y, R n x y) n l l' : - #|l| = #|l'| -> All2i_ctx R n l l'. + Lemma All2i_trivial {A B} (R : nat -> A -> B -> Type) (H : forall n x y, R n x y) n l l' : + #|l| = #|l'| -> All2i R n l l'. Proof. induction l in n, l' |- *; destruct l'; simpl; try discriminate; intros; constructor; auto. Qed. End All2i. Definition pres_bodies Γ Δ σ := - All2i (fun n decl decl' => (decl_body decl' = option_map (fun x => x.[⇑^n σ]) (decl_body decl))) - Γ Δ. + All2i_ctx + (fun n decl decl' => (decl_body decl' = option_map (fun x => x.[⇑^n σ]) (decl_body decl))) + Γ Δ. Lemma pres_bodies_inst_context Γ σ : pres_bodies Γ (inst_context σ Γ) σ. Proof. @@ -1333,6 +1442,26 @@ Section Rho. Qed. Hint Resolve Upn_ctxmap : pcuic. + Lemma inst_ctxmap Γ Δ Γ' σ : + ctxmap Γ Δ σ -> + ctxmap (Γ ,,, Γ') (Δ ,,, inst_context σ Γ') (⇑^#|Γ'| σ). + Proof. + intros cmap. + apply Upn_ctxmap => //. + apply pres_bodies_inst_context. + Qed. + Hint Resolve inst_ctxmap : pcuic. + + Lemma inst_ctxmap_up Γ Δ Γ' σ : + ctxmap Γ Δ σ -> + ctxmap (Γ ,,, Γ') (Δ ,,, inst_context σ Γ') (up #|Γ'| σ). + Proof. + intros cmap. + eapply ctxmap_ext. rewrite up_Upn. reflexivity. + now apply inst_ctxmap. + Qed. + Hint Resolve inst_ctxmap_up : pcuic. + (** Untyped renamings *) Definition renaming Γ Δ r := forall x, match nth_error Γ x with @@ -1391,7 +1520,7 @@ Section Rho. Qed. Lemma shift_renaming Γ Δ ctx ctx' r : - All2i (fun n decl decl' => (decl_body decl' = option_map (fun x => x.[ren (shiftn n r)]) (decl_body decl))) + All2i_ctx (fun n decl decl' => (decl_body decl' = option_map (fun x => x.[ren (shiftn n r)]) (decl_body decl))) ctx ctx' -> renaming Γ Δ r -> renaming (Γ ,,, ctx) (Δ ,,, ctx') (shiftn #|ctx| r). @@ -1403,6 +1532,27 @@ Section Rho. apply r0. Qed. + Lemma shiftn_renaming Γ Δ ctx r : + renaming Γ Δ r -> + renaming (Γ ,,, ctx) (Δ ,,, rename_context r ctx) (shiftn #|ctx| r). + Proof. + induction ctx; simpl; auto. + * intros. rewrite shiftn0. apply H. + * intros. simpl. + rewrite shiftnS rename_context_snoc /=. + apply shiftn1_renaming. now apply IHctx. + simpl. destruct (decl_body a) => /= //. + now sigma. + Qed. + + Lemma shiftn_renaming_eq Γ Δ ctx r k : + renaming Γ Δ r -> + k = #|ctx| -> + renaming (Γ ,,, ctx) (Δ ,,, rename_context r ctx) (shiftn k r). + Proof. + now intros hr ->; apply shiftn_renaming. + Qed. + Lemma renaming_shift_rho_fix_context: forall (mfix : mfixpoint term) (Γ Δ : list context_decl) (r : nat -> nat), renaming Γ Δ r -> @@ -1414,8 +1564,8 @@ Section Rho. rewrite -{2}(rho_fix_context_length Γ mfix). eapply shift_renaming; auto. rewrite /rho_fix_context !fold_fix_context_rev. - apply All2i_rev_ctx_inv, All2i_ctx_mapi. - simpl. apply All2i_ctx_trivial; auto. now rewrite map_length. + apply All2i_rev_ctx_inv, All2i_mapi. + simpl. apply All2i_trivial; auto. now rewrite map_length. Qed. Lemma map_fix_rho_rename: @@ -1496,6 +1646,136 @@ Section Rho. Proof. destruct t; simpl; try congruence. Qed. + Transparent fold_context. + + Lemma fold_context_mapi_context f g Γ : + fold_context f (mapi_context g Γ) = + fold_context (fun Γ => f Γ ∘ map_decl (g #|Γ|)) Γ. + Proof. + induction Γ. simpl. auto. + simpl. f_equal; auto. + now rewrite -IHΓ; len. + Qed. + + Lemma mapi_context_fold_context f g Γ : + mapi_context f (fold_context (fun Γ => g (mapi_context f Γ)) Γ) = + fold_context (fun Γ => map_decl (f #|Γ|) ∘ g Γ) Γ. + Proof. + induction Γ. simpl. auto. + simpl. f_equal; auto. len. + now rewrite -IHΓ. + Qed. + + Lemma onctx_fold_context_term P Γ (f g : context -> term -> term) : + 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 Γ. + Proof. + intros onc Hp. induction onc; simpl; auto. + f_equal; auto. + eapply map_decl_eq_spec; tea. + intros. now apply Hp. + Qed. + + Lemma rho_ctx_rename Γ r : + fold_context_term (fun Γ' x => rho Γ' (rename (shiftn #|Γ'| r) x)) Γ = + rho_ctx (rename_context r Γ). + Proof. + rewrite /rename_context. + rewrite -mapi_context_fold. + rewrite fold_context_mapi_context. + now setoid_rewrite compose_map_decl. + Qed. + + Lemma rename_rho_ctx {r ctx} : + onctx + (fun t : term => + forall (Γ Δ : list context_decl) (r : nat -> nat), + renaming Γ Δ r -> rename r (rho Γ t) = rho Δ (rename r t)) + ctx -> + rename_context r (rho_ctx ctx) = + rho_ctx (rename_context r ctx). + Proof. + intros onc. + rewrite /rename_context - !mapi_context_fold. + induction onc; simpl; eauto. + f_equal; eauto. + rewrite !compose_map_decl. + eapply map_decl_eq_spec; tea => /= t. + intros IH. + erewrite IH. rewrite -IHonc. len. reflexivity. + rewrite mapi_context_fold. + rewrite -/(rename_context r (rho_ctx l)). + epose proof (shiftn_renaming [] [] (rho_ctx l) r). + rewrite !app_context_nil_l in H. eapply H. + now intros i; rewrite !nth_error_nil. + Qed. + + Lemma rename_rho_ctx_over {ctx} {Γ Δ r} : + renaming Γ Δ r -> + onctx + (fun t : term => + forall (Γ Δ : list context_decl) (r : nat -> nat), + renaming Γ Δ r -> rename r (rho Γ t) = rho Δ (rename r t)) + ctx -> + rename_context r (rho_ctx_over Γ ctx) = + rho_ctx_over Δ (rename_context r ctx). + Proof. + intros Hr onc. + rewrite /rename_context - !mapi_context_fold. + induction onc; simpl; eauto. + f_equal; eauto. + rewrite !compose_map_decl. + eapply map_decl_eq_spec; tea => /= t. + intros IH. + erewrite IH. rewrite -IHonc. len. reflexivity. + rewrite mapi_context_fold. + rewrite -/(rename_context r (rho_ctx l)). + apply (shiftn_renaming _ _ (rho_ctx_over Γ l) r Hr). + Qed. + + Lemma context_assumptions_fold_context_term f Γ : + context_assumptions (fold_context_term f Γ) = context_assumptions Γ. + Proof. + induction Γ => /= //. + destruct (decl_body a) => /= //; f_equal => //. + Qed. + Hint Rewrite context_assumptions_fold_context_term : len. + + Lemma mapi_context_rename r Γ : + mapi_context (fun k : nat => rename (shiftn k r)) Γ = + rename_context r Γ. + Proof. rewrite mapi_context_fold //. Qed. + + Lemma inspect_nth_error_rename {r brs u res} (eq : nth_error brs u = res) : + ∑ prf, + inspect (nth_error (rename_branches r brs) u) = + exist (option_map (rename_branch r) res) prf. + Proof. simpl. + rewrite nth_error_map eq. now exists eq_refl. + Qed. + + Lemma rho_rename_pred Γ Δ p r : + renaming Γ Δ r -> + tCasePredProp + (fun t : term => + forall (Γ Δ : list context_decl) (r : nat -> nat), + renaming Γ Δ r -> rename r (rho Γ t) = rho Δ (rename r t)) + (fun t : term => + forall (Γ Δ : list context_decl) (r : nat -> nat), + renaming Γ Δ r -> rename r (rho Γ t) = rho Δ (rename r t)) p -> + rename_predicate r (rho_predicate Γ p) = rho_predicate Δ (rename_predicate r p). + Proof. + intros Hr [? [? ?]]. + rewrite /rename_predicate /rho_predicate; cbn; f_equal; solve_all. + * rewrite !mapi_context_rename (rename_rho_ctx_over Hr) //. + * rewrite !mapi_context_rename. len. + eapply e. rewrite -(rename_rho_ctx_over Hr) //. + eapply shiftn_renaming_eq; len => //. + Qed. Lemma rho_rename Γ Δ r t : renaming Γ Δ r -> @@ -1534,7 +1814,7 @@ Section Rho. specialize (H _ _ _ H2). specialize (H0 _ _ _ H2). autorewrite with sigma in H, H0, H1. erewrite <- (H1 ((vdef n (rho Γ t) (rho Γ t0) :: Γ))). 2:{ eapply (shift_renaming _ _ [_] [_]). repeat constructor. simpl. - sigma. now rewrite -H shiftn0. auto. } + sigma. now rewrite -H. auto. } sigma. apply inst_ext. rewrite H. rewrite -ren_shiftn. sigma. unfold Up. now sigma. @@ -1575,7 +1855,7 @@ Section Rho. { sigma. eapply inst_ext. rewrite -ren_shiftn. sigma. rewrite Upn_comp ?map_length ?fix_subst_length ?map_length //. - rewrite subst_consn_compose compose_ids_l. apply subst_consn_proper => //. + apply subst_consn_proper => //. rewrite map_fix_subst //. intros n. simp rho. simpl. simp rho. reflexivity. @@ -1662,63 +1942,82 @@ Section Rho. case eb: cst_body => [b|] //; simp rho. rewrite rename_inst inst_closed0 //. apply declared_decl_closed in e => //. - hnf in e. rewrite eb in e. rewrite closedn_subst_instance_constr; auto. + hnf in e. rewrite eb in e. rewrite closedn_subst_instance; auto. now move/andP: e => [-> _]. - (* construct/cofix iota reduction *) simpl; simp rho. destruct p. simp rho. destruct inspect as [[f a] decapp]. destruct inspect as [[f' a'] decapp']. - epose proof (decompose_app_rename (symmetry decapp)). - rewrite <- decapp' in H2. noconf H2. - assert (map (on_snd (rename r)) (map (fun x => (fst x, rho Γ (snd x))) l) = - (map (fun x => (fst x, rho Δ (snd x))) (map (on_snd (rename r)) l))). - { red in X. rewrite !map_map_compose /on_snd. solve_all. } - - simpl. destruct view_construct_cofix; simpl; simp rho. - - * destruct (eq_inductive i ind) eqn:eqi. - simp rho. simpl. rewrite -H2. - (* Reduction *) - rewrite /iota_red /= -map_skipn rename_mkApps !nth_map //. - f_equal. simpl. rewrite !map_skipn. - apply symmetry, decompose_app_inv in decapp. subst t0. - specialize (H0 _ _ _ H1). - rewrite !rho_app_construct !rename_mkApps in H0. - simpl in H0. rewrite rho_app_construct in H0. - apply mkApps_eq_inj in H0 as [_ Heq] => //. congruence. + epose proof (decompose_app_rename decapp). + rewrite -> decapp' in H1. noconf H1. + simpl. + assert (map (rename_branch r) (map (rho_br Γ) brs) = + (map (rho_br Δ) (map (rename_branch r) brs))). + { destruct X as [? [? ?]]. + simpl in *. rewrite !map_map_compose /rename_branch + /PCUICSigmaCalculus.rename_branch /rho_br /=. + simpl. solve_all. len. + rewrite !mapi_context_rename - !(rename_rho_ctx_over H0); tea. + f_equal. + erewrite b. f_equal. + now eapply shiftn_renaming_eq; len. } - simp rho. simpl. - erewrite H, H0; eauto. - now rewrite -H2. + simpl. + destruct X as [? [? ?]]; cbn in *. red in X0. + destruct view_construct_cofix; simpl; simp rho. + + * destruct (eq_inductive ci ind) eqn:eqi. + simp rho. + destruct inspect as [[br|] eqbr]=> //; simp rho; + destruct (inspect_nth_error_rename (r:=r) eqbr) as [prf ->]; simp rho. + set (pred := {| pparams := _ |}). + cbn -[eqb]. autorewrite with len. + case: eqb_spec => // hlen. + + rewrite rename_iota_red //. now len. + f_equal. + { pose proof (decompose_app_inv decapp). subst c. + specialize (H _ _ _ H0). + 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] => //. } + rewrite !map_map_compose in H1. + apply forall_map_spec in H1. + eapply nth_error_forall in H1; tea. + now simpl in H1. + + simpl. f_equal; auto. + erewrite -> rho_rename_pred => //. + + simp rho. simpl. f_equal; eauto. + erewrite -> rho_rename_pred => //. + + simp rho. simpl. f_equal; eauto. + erewrite -> rho_rename_pred => //. * simpl; simp rho. rewrite /map_fix !map_map_compose. - red in X. rewrite /unfold_cofix !nth_error_map. - apply symmetry, decompose_app_inv in decapp. subst t0. - specialize (H0 _ _ _ H1). - simp rho in H0. - rewrite !rename_mkApps in H0. - simpl in H0. simp rho in H0. - apply mkApps_eq_inj in H0 as [Heqcof Heq] => //. - noconf Heqcof. simpl in H0. noconf H0. - autorewrite with len in H0. - rewrite /map_fix !map_map_compose in H0. + apply decompose_app_inv in decapp. subst c. + specialize (H _ _ _ H0). + simp rho in H; rewrite !rename_mkApps /= in H. simp rho in H. + eapply mkApps_eq_inj in H as [Heqcof Heq] => //. + noconf Heqcof. simpl in H. + autorewrite with len in H. + rewrite /map_fix !map_map_compose in H. case efix: (nth_error mfix idx) => [d|] /= //. - + rewrite rename_mkApps !map_map_compose compose_map_def /on_snd. - f_equal. erewrite H; eauto. f_equal => //. + + rewrite rename_mkApps !map_map_compose compose_map_def. + f_equal. erewrite -> rho_rename_pred => //. + rewrite !map_map_compose in Heq. + f_equal => //. rewrite !subst_inst. sigma. - apply map_eq_inj in H0. - epose proof (nth_error_all efix H0). - simpl in H3. apply (f_equal dbody) in H3. - simpl in H3. autorewrite with sigma in H3. - rewrite -H3. sigma. + apply map_eq_inj in H. + epose proof (nth_error_all efix H). + simpl in H2. apply (f_equal dbody) in H2. + simpl in H2. autorewrite with sigma in H2. + rewrite -H2. sigma. apply inst_ext. rewrite -ren_shiftn. sigma. rewrite Upn_comp ?map_length ?fix_subst_length ?map_length //. - rewrite subst_consn_compose compose_ids_l. apply subst_consn_proper => //. + apply subst_consn_proper => //. 2:now autorewrite with len. rewrite map_cofix_subst' //. intros n'; simp rho. simpl; f_equal. now simp rho. @@ -1729,29 +2028,31 @@ Section Rho. apply map_ext => x; apply map_def_eq_spec => //. rewrite !map_map_compose. unfold cofix_subst. generalize #|mfix|. - clear -H0. + clear -H. induction n; simpl; auto. f_equal; auto. simp rho. simpl. simp rho. f_equal. - rewrite /map_fix !map_map_compose. autorewrite with len. - solve_all. - rewrite -H. - apply map_def_eq_spec; simpl. now sigma. sigma. - rewrite -ren_shiftn. rewrite up_Upn. reflexivity. - now rewrite !map_map_compose in Heq. simpl. + rewrite /map_fix !map_map_compose. autorewrite with len. solve_all. - - + rewrite map_map_compose /on_snd. f_equal; auto. - simp rho. - rewrite !rename_mkApps /= !map_map_compose !compose_map_def /=. - simp rho. - f_equal. f_equal. - rewrite /map_fix map_map_compose. rewrite -H0. - autorewrite with len. reflexivity. - now rewrite -Heq !map_map_compose. - simpl. solve_all. - * pose proof (construct_cofix_rename r t1 d). - destruct (view_construct_cofix (rename r t1)); simpl in H3 => //. - simp rho. simpl. rewrite -H2. erewrite H, H0; eauto. + apply (f_equal dtype) in H. simpl in H. + now sigma; sigma in H. sigma. + 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 H1. + + + rewrite map_map_compose. f_equal; auto. + { erewrite -> rho_rename_pred => //. } + { simp rho. rewrite !rename_mkApps /= !map_map_compose !compose_map_def /=. + simp rho. f_equal. f_equal. + rewrite /map_fix map_map_compose. rewrite -H. + autorewrite with len. reflexivity. + now rewrite -Heq !map_map_compose. } + now rewrite !map_map_compose in H1. + * pose proof (construct_cofix_rename r t d). + destruct (view_construct_cofix (rename r t)); simpl in H2 => //. + simp rho. simpl. + f_equal; auto. + erewrite rho_rename_pred => //. - (* Proj construct/cofix reduction *) simpl; simp rho. destruct s as [[ind pars] n]. @@ -1791,7 +2092,7 @@ Section Rho. apply inst_ext. rewrite -ren_shiftn. sigma. rewrite Upn_comp ?map_length ?fix_subst_length ?map_length //. - rewrite subst_consn_compose compose_ids_l. apply subst_consn_proper => //. + apply subst_consn_proper => //. 2:now autorewrite with len. rewrite map_cofix_subst' //. rewrite !map_map_compose. @@ -1800,8 +2101,8 @@ Section Rho. induction n; simpl; auto. f_equal; auto. simp rho. simpl. simp rho. f_equal. rewrite /map_fix !map_map_compose. autorewrite with len. - solve_all. - rewrite -H. + eapply All_map_eq, All_impl; tea => /= //. + intros x <-. apply map_def_eq_spec; simpl. now sigma. sigma. rewrite -ren_shiftn. rewrite up_Upn. reflexivity. @@ -1809,8 +2110,6 @@ Section Rho. simpl; simp rho; simpl; simp rho. f_equal. rewrite /map_fix !map_length !map_map_compose. red in X. solve_all. - rewrite !map_def_map_def. - eapply map_def_eq_spec. eapply a. auto. erewrite b; auto. assert (#|m| = #|fold_fix_context rho Γ [] m|). rewrite fold_fix_context_length /= //. rewrite {2}H0. @@ -1822,8 +2121,6 @@ Section Rho. simpl; simp rho; simpl; simp rho. f_equal. rewrite /map_fix !map_length !map_map_compose. red in X. solve_all. - rewrite !map_def_map_def. - eapply map_def_eq_spec. eapply a. auto. erewrite b; auto. assert (#|m| = #|fold_fix_context rho Γ [] m|). rewrite fold_fix_context_length /= //. rewrite {2}H0. @@ -1845,27 +2142,6 @@ Section Rho. rewrite nth_error_app_ge. lia. now rewrite Nat.add_sub Heq. Qed. - Section rho_ctx. - Context (Δ : context). - Fixpoint rho_ctx_over Γ := - match Γ with - | [] => [] - | {| decl_name := na; decl_body := None; decl_type := T |} :: Γ => - let Γ' := rho_ctx_over Γ in - vass na (rho (Δ ,,, Γ') T) :: Γ' - | {| decl_name := na; decl_body := Some b; decl_type := T |} :: Γ => - let Γ' := rho_ctx_over Γ in - vdef na (rho (Δ ,,, Γ') b) (rho (Δ ,,, Γ') T) :: Γ' - end. - End rho_ctx. - - Definition rho_ctx Γ := (rho_ctx_over [] Γ). - - Lemma rho_ctx_over_length Δ Γ : #|rho_ctx_over Δ Γ| = #|Γ|. - Proof. - induction Γ; simpl; auto. destruct a. destruct decl_body; simpl; auto with arith. - Qed. - Lemma rho_ctx_over_app Γ' Γ Δ : rho_ctx_over Γ' (Γ ,,, Δ) = rho_ctx_over Γ' Γ ,,, rho_ctx_over (Γ' ,,, rho_ctx_over Γ' Γ) Δ. @@ -1879,9 +2155,9 @@ Section Rho. Lemma rho_ctx_app Γ Δ : rho_ctx (Γ ,,, Δ) = rho_ctx Γ ,,, rho_ctx_over (rho_ctx Γ) Δ. Proof. induction Δ; simpl; auto. - destruct a as [na [b|] ty]. simpl. f_equal. - rewrite app_context_nil_l. now rewrite IHΔ. auto. - rewrite app_context_nil_l. now rewrite IHΔ. + destruct a as [na [b|] ty]; simpl; f_equal; auto. + now rewrite -IHΔ. + now rewrite -IHΔ. Qed. Lemma fold_fix_context_over_acc Γ m acc : @@ -2031,47 +2307,61 @@ Section Rho. intros. rewrite - {1}(map_id brs). eapply All2_map, All_All2; eauto. Qed. - Lemma rho_triangle_All_All2_ind_noeq: - forall (Γ Γ' : context) (brs0 brs1 : list (nat * term)), + Lemma rho_triangle_All_All2_ind_terms: + forall (Γ Γ' : context) (args0 args1 : list term), pred1_ctx Σ Γ Γ' -> - All2 (on_Trel_eq (fun x y => (pred1 Σ Γ Γ' x y * pred1 Σ Γ' (rho_ctx Γ) y (rho (rho_ctx Γ) x))%type) snd - fst) brs0 brs1 -> - All2 (on_Trel (pred1 Σ Γ' (rho_ctx Γ)) snd) brs1 (map (fun x => (fst x, rho (rho_ctx Γ) (snd x))) brs0). + All2 (fun x y => + (pred1 Σ Γ Γ' x y * pred1 Σ Γ' (rho_ctx Γ) y (rho (rho_ctx Γ) x))%type) + args0 args1 -> + All2 (pred1 Σ Γ' (rho_ctx Γ)) args1 (map (rho (rho_ctx Γ)) args0). Proof. - intros. rewrite - {1}(map_id brs1). eapply All2_map, All2_sym, All2_impl; pcuic. + intros. rewrite - {1}(map_id args1). + eapply All2_map, All2_sym, All2_impl; pcuic. Qed. - Lemma All2_local_env_pred_fix_ctx P (Γ Γ' : context) (mfix0 : mfixpoint term) (mfix1 : list (def term)) : - All2_local_env - (on_decl - (on_decl_over (fun (Γ0 Γ'0 : context) (t t0 : term) => P Γ'0 (rho_ctx Γ0) t0 (rho (rho_ctx Γ0) t)) Γ Γ')) + (* Lemma rho_triangle_All_All2_ind_brs: + forall (Γ Γ' : context) (brs0 brs1 : list (branch term)), + pred1_ctx Σ Γ Γ' -> + All2 (on_Trel_eq + (fun x y => + (pred1 Σ Γ Γ' x y * pred1 Σ Γ' (rho_ctx Γ) y (rho (rho_ctx Γ) x))%type) + bbody bcontext) brs0 brs1 -> + All2 (on_Trel (pred1 Σ Γ' (rho_ctx Γ)) bbody) brs1 + (map (fun x => (bcontext x, rho (rho_ctx Γ) (bbody x))) brs0). + Proof. + intros. rewrite - {1}(map_id brs1). eapply All2_map, All2_sym, All2_impl; pcuic. + Qed. *) + + Lemma All2_fold_pred_fix_ctx P (Γ Γ' : context) (mfix0 : mfixpoint term) (mfix1 : list (def term)) : + All2_fold + (on_decls + (on_decls_over (fun (Γ0 Γ'0 : context) (t t0 : term) => P Γ'0 (rho_ctx Γ0) t0 (rho (rho_ctx Γ0) t)) Γ Γ')) (fix_context mfix0) (fix_context mfix1) - -> All2_local_env (on_decl (on_decl_over P Γ' (rho_ctx Γ))) (fix_context mfix1) + -> All2_fold (on_decls (on_decls_over P Γ' (rho_ctx Γ))) (fix_context mfix1) (fix_context (map_fix rho (rho_ctx Γ) (rho_ctx_over (rho_ctx Γ) (fix_context mfix0)) mfix0)). Proof. intros. rewrite fix_context_map_fix. revert X. generalize (fix_context mfix0) (fix_context mfix1). - induction 1; simpl; constructor; auto. 1,3:now symmetry. - unfold on_decl, on_decl_over in p |- *. - now rewrite rho_ctx_app in p. - unfold on_decl, on_decl_over in p |- *. - now rewrite rho_ctx_app in p. + induction 1; simpl; constructor; auto. + depelim p; constructor; simpl; auto; + unfold on_decls_over in * |- *; now rewrite -> rho_ctx_app in *. Qed. - Lemma All2_local_env_sym P Γ Γ' Δ Δ' : - All2_local_env (on_decl (on_decl_over (fun Γ Γ' t t' => P Γ' Γ t' t) Γ' Γ)) Δ' Δ -> - All2_local_env (on_decl (on_decl_over P Γ Γ')) Δ Δ'. + Lemma All2_fold_sym P Γ Γ' Δ Δ' : + All2_fold (on_decls (on_decls_over (fun Γ Γ' t t' => P Γ' Γ t' t) Γ' Γ)) Δ' Δ -> + All2_fold (on_decls (on_decls_over P Γ Γ')) Δ Δ'. Proof. - induction 1; constructor; eauto. all:now symmetry. + induction 1; constructor; eauto. depelim p; constructor. + all:now unfold on_decls_over in *. Qed. - Lemma wf_rho_fix_subst Γ Γ' mfix0 mfix1 : + (*Lemma wf_rho_fix_subst Γ Γ' mfix0 mfix1 : #|mfix0| = #|mfix1| -> pred1_ctx Σ Γ' (rho_ctx Γ) -> - All2_local_env - (on_decl - (on_decl_over + All2_fold + (on_decls + (on_decls_over (fun (Γ Γ' : context) (t t0 : term) => pred1 Σ Γ' (rho_ctx Γ) t0 (rho (rho_ctx Γ) t)) Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody @@ -2105,7 +2395,7 @@ Section Rho. assert ((Nat.pred #|mfix0| - (#|mfix0| - S #|l|)) = #|l|) by lia. assert ((Nat.pred #|mfix0| - (#|mfix0| - S #|l'|)) = #|l'|) by lia. rewrite H0 H1. - intros. depelim Hctxs. red in o. + intros. depelim Hctxs. depelim a. red in o. noconf Heqlen. simpl in H. rewrite -H. econstructor. unfold mapi in IHAll2. @@ -2124,7 +2414,7 @@ Section Rho. simp rho; simpl; simp rho. econstructor. eauto. clear Hctxs o IHAll2. rewrite -fold_fix_context_rho_ctx. - eapply All2_local_env_pred_fix_ctx. eapply Hctxs'. + eapply All2_fold_pred_fix_ctx. eapply Hctxs'. eapply All2_mix. rewrite -fold_fix_context_rho_ctx. all:clear IHAll2 Hctxs H o r. { eapply All2_mix_inv in a0. destruct a0. @@ -2141,16 +2431,14 @@ Section Rho. rewrite rho_ctx_app in a2. unfold on_Trel. eapply All2_map_left. simpl. eapply a2. eapply All2_map_left. simpl. solve_all. } - Qed. - -(* TODO generalize fix/cofix subst by tFix/tCofix constructor! *) + Qed.*) - Lemma wf_rho_cofix_subst Γ Γ' mfix0 mfix1 : + (*Lemma wf_rho_cofix_subst Γ Γ' mfix0 mfix1 : #|mfix0| = #|mfix1| -> pred1_ctx Σ Γ' (rho_ctx Γ) -> - All2_local_env - (on_decl - (on_decl_over + All2_fold + (on_decls + (on_decls_over (fun (Γ Γ' : context) (t t0 : term) => pred1 Σ Γ' (rho_ctx Γ) t0 (rho (rho_ctx Γ) t)) Γ Γ')) (fix_context mfix0) (fix_context mfix1) -> All2_prop2_eq Γ Γ' (Γ ,,, fix_context mfix0) (Γ' ,,, fix_context mfix1) dtype dbody @@ -2198,7 +2486,7 @@ Section Rho. simp rho; simpl; simp rho. econstructor. eauto. clear Hctxs o IHAll2. rewrite -fold_fix_context_rho_ctx. - eapply All2_local_env_pred_fix_ctx. eapply Hctxs'. + eapply All2_fold_pred_fix_ctx. eapply Hctxs'. eapply All2_mix. rewrite -fold_fix_context_rho_ctx. all:clear IHAll2 Hctxs H o r. { eapply All2_mix_inv in a0. destruct a0. @@ -2215,9 +2503,9 @@ Section Rho. rewrite rho_ctx_app in a2. unfold on_Trel. eapply All2_map_left. simpl. eapply a2. eapply All2_map_left. simpl. solve_all. } - Qed. + Qed.*) - Definition pred1_subst Γ Δ Δ' σ τ := + Definition pred1_subst (Γ Δ Δ' : context) σ τ := forall x, pred1 Σ Δ Δ' (σ x) (τ x) * match option_map decl_body (nth_error Γ x) return Type with | Some (Some b) => σ x = τ x @@ -2225,15 +2513,10 @@ Section Rho. end. Lemma pred_subst_rho_cofix (Γ Γ' : context) (mfix0 mfix1 : mfixpoint term) : - pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' (rho_ctx Γ) - -> All2_local_env - (on_decl - (on_decl_over - (fun (Γ0 Γ'0 : context) (t t0 : term) => - pred1 Σ Γ'0 (rho_ctx Γ0) t0 - (rho (rho_ctx Γ0) t)) Γ Γ')) - (fix_context mfix0) (fix_context mfix1) - -> All2 (on_Trel eq (fun x : def term => (dname x, rarg x))) + pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' (rho_ctx Γ) -> + pred1_ctx_over Σ Γ' (rho_ctx Γ) (fix_context mfix1) + (rho_ctx_over (rho_ctx Γ) (fix_context mfix0)) -> + All2 (on_Trel eq (fun x : def term => (dname x, rarg x))) mfix0 mfix1 -> All2 (on_Trel @@ -2267,22 +2550,22 @@ Section Rho. intros predΓ predΓ' fctx eqf redr redl. intros x. destruct (leb_spec_Set (S x) #|cofix_subst mfix1|). - destruct (subst_consn_lt l) as [? [Hb Hb']]. + destruct (subst_consn_lt_spec l) as [? [Hb Hb']]. rewrite Hb'. eapply nth_error_cofix_subst in Hb. subst. rewrite cofix_subst_length in l. - rewrite -(All2_length _ _ eqf) in l. + rewrite -(All2_length eqf) in l. rewrite -(cofix_subst_length mfix0) in l. - destruct (subst_consn_lt l) as [b' [Hb0 Hb0']]. + destruct (subst_consn_lt_spec l) as [b' [Hb0 Hb0']]. rewrite rho_cofix_subst. pose proof (nth_error_map (rho (rho_ctx Γ)) x (cofix_subst mfix0)). rewrite Hb0 in H. simpl in H. rewrite /subst_consn H. eapply nth_error_cofix_subst in Hb0. subst b'. - cbn. rewrite (All2_length _ _ eqf). constructor; auto. + cbn. rewrite (All2_length eqf). constructor; auto. simp rho; simpl; simp rho. rewrite -fold_fix_context_rho_ctx. constructor; auto. - + eapply All2_local_env_pred_fix_ctx. apply fctx. + + rewrite fix_context_map_fix. apply fctx. + red. clear -wfΣ eqf redr redl. eapply All2_sym. apply All2_map_left. pose proof (All2_mix eqf (All2_mix redr redl)) as X; clear eqf redr redl. @@ -2290,28 +2573,24 @@ Section Rho. unfold on_Trel in *. simpl. intros x y. rewrite fix_context_map_fix rho_ctx_app. intuition auto. + pose proof (fix_context_assumption_context mfix1). - rewrite cofix_subst_length (All2_length _ _ eqf) -(fix_context_length mfix1) in l. + rewrite cofix_subst_length (All2_length eqf) -(fix_context_length mfix1) in l. rewrite nth_error_app_lt //. destruct (nth_error (fix_context mfix1) x) eqn:Heq => // /=; auto. destruct c as [na [?|] ty] => //. move: (nth_error_assumption_context _ _ _ H0 Heq) => //. + rewrite cofix_subst_length in l. rewrite !subst_consn_ge; try rewrite ?cofix_subst_length ?map_length; try lia. - now rewrite (All2_length _ _ eqf). - split. rewrite (All2_length _ _ eqf); pcuic. + now rewrite (All2_length eqf). + split. rewrite (All2_length eqf); pcuic. rewrite nth_error_app_ge ?fix_context_length //; try lia. - destruct option_map as [[o|]|]; auto. now rewrite (All2_length _ _ eqf). + destruct option_map as [[o|]|]; auto. now rewrite (All2_length eqf). Qed. Lemma pred_subst_rho_fix (Γ Γ' : context) (mfix0 mfix1 : mfixpoint term) : pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' (rho_ctx Γ) - -> All2_local_env - (on_decl - (on_decl_over - (fun (Γ0 Γ'0 : context) (t t0 : term) => - pred1 Σ Γ'0 (rho_ctx Γ0) t0 - (rho (rho_ctx Γ0) t)) Γ Γ')) - (fix_context mfix0) (fix_context mfix1) + -> + pred1_ctx_over Σ Γ' (rho_ctx Γ) (fix_context mfix1) + (rho_ctx_over (rho_ctx Γ) (fix_context mfix0)) -> All2 (on_Trel eq (fun x : def term => (dname x, rarg x))) mfix0 mfix1 -> All2 @@ -2346,22 +2625,22 @@ Section Rho. intros predΓ predΓ' fctx eqf redr redl. intros x. destruct (leb_spec_Set (S x) #|fix_subst mfix1|). - destruct (subst_consn_lt l) as [? [Hb Hb']]. + destruct (subst_consn_lt_spec l) as [? [Hb Hb']]. rewrite Hb'. eapply nth_error_fix_subst in Hb. subst. rewrite fix_subst_length in l. - rewrite -(All2_length _ _ eqf) in l. + rewrite -(All2_length eqf) in l. rewrite -(fix_subst_length mfix0) in l. - destruct (subst_consn_lt l) as [b' [Hb0 Hb0']]. + destruct (subst_consn_lt_spec l) as [b' [Hb0 Hb0']]. rewrite rho_fix_subst. pose proof (nth_error_map (rho (rho_ctx Γ)) x (fix_subst mfix0)). rewrite Hb0 in H. simpl in H. rewrite /subst_consn H. eapply nth_error_fix_subst in Hb0. subst b'. - cbn. rewrite (All2_length _ _ eqf). constructor; auto. + cbn. rewrite (All2_length eqf). constructor; auto. simp rho; simpl; simp rho. rewrite -fold_fix_context_rho_ctx. constructor; auto. - + eapply All2_local_env_pred_fix_ctx. apply fctx. + + rewrite fix_context_map_fix. apply fctx. + red. clear -wfΣ eqf redr redl. eapply All2_sym. apply All2_map_left. pose proof (All2_mix eqf (All2_mix redr redl)) as X; clear eqf redr redl. @@ -2369,48 +2648,48 @@ Section Rho. unfold on_Trel in *. simpl. intros x y. rewrite fix_context_map_fix rho_ctx_app. intuition auto. + pose proof (fix_context_assumption_context mfix1). - rewrite fix_subst_length (All2_length _ _ eqf) -(fix_context_length mfix1) in l. + rewrite fix_subst_length (All2_length eqf) -(fix_context_length mfix1) in l. rewrite nth_error_app_lt //. destruct (nth_error (fix_context mfix1) x) eqn:Heq => // /=; auto. destruct c as [na [?|] ty] => //. move: (nth_error_assumption_context _ _ _ H0 Heq) => //. + rewrite fix_subst_length in l. rewrite !subst_consn_ge; try rewrite ?fix_subst_length ?map_length; try lia. - now rewrite (All2_length _ _ eqf). - split. rewrite (All2_length _ _ eqf); pcuic. + now rewrite (All2_length eqf). + split. rewrite (All2_length eqf); pcuic. rewrite nth_error_app_ge ?fix_context_length //; try lia. - destruct option_map as [[o|]|]; auto. now rewrite (All2_length _ _ eqf). + destruct option_map as [[o|]|]; auto. now rewrite (All2_length eqf). Qed. Section All2_telescope. - Context (P : forall (Γ Γ' : context), option (term * term) -> term -> term -> Type). + Context (P : forall (Γ Γ' : context), context_decl -> context_decl -> Type). Definition telescope := context. Inductive All2_telescope (Γ Γ' : context) : telescope -> telescope -> Type := | telescope2_nil : All2_telescope Γ Γ' [] [] | telescope2_cons_abs na t t' Δ Δ' : - P Γ Γ' None t t' -> + P Γ Γ' (vass na t) (vass na t') -> All2_telescope (Γ ,, vass na t) (Γ' ,, vass na t') Δ Δ' -> All2_telescope Γ Γ' (vass na t :: Δ) (vass na t' :: Δ') | telescope2_cons_def na b b' t t' Δ Δ' : - P Γ Γ' (Some (b, b')) t t' -> + P Γ Γ' (vdef na b t) (vdef na b' t') -> All2_telescope (Γ ,, vdef na b t) (Γ' ,, vdef na b' t') Δ Δ' -> All2_telescope Γ Γ' (vdef na b t :: Δ) (vdef na b' t' :: Δ'). End All2_telescope. Section All2_telescope_n. - Context (P : forall (Γ Γ' : context), option (term * term) -> term -> term -> Type). + Context (P : forall (Γ Γ' : context), context_decl -> context_decl -> Type). Context (f : nat -> term -> term). Inductive All2_telescope_n (Γ Γ' : context) (n : nat) : telescope -> telescope -> Type := | telescope_n_nil : All2_telescope_n Γ Γ' n [] [] | telescope_n_cons_abs na t t' Δ Δ' : - P Γ Γ' None (f n t) (f n t') -> + P Γ Γ' (vass na (f n t)) (vass na (f n t')) -> All2_telescope_n (Γ ,, vass na (f n t)) (Γ' ,, vass na (f n t')) (S n) Δ Δ' -> All2_telescope_n Γ Γ' n (vass na t :: Δ) (vass na t' :: Δ') | telescope_n_cons_def na b b' t t' Δ Δ' : - P Γ Γ' (Some (f n b, f n b')) (f n t) (f n t') -> + P Γ Γ' (vdef na (f n b) (f n t)) (vdef na (f n b') (f n t')) -> All2_telescope_n (Γ ,, vdef na (f n b) (f n t)) (Γ' ,, vdef na (f n b') (f n t')) (S n) Δ Δ' -> All2_telescope_n Γ Γ' n (vdef na b t :: Δ) (vdef na b' t' :: Δ'). @@ -2418,34 +2697,29 @@ Section Rho. End All2_telescope_n. Lemma All2_telescope_mapi {P} Γ Γ' Δ Δ' (f : nat -> term -> term) k : - All2_telescope_n (on_decl P) f Γ Γ' k Δ Δ' -> - All2_telescope (on_decl P) Γ Γ' (mapi_rec (fun n => map_decl (f n)) Δ k) + All2_telescope_n P f Γ Γ' k Δ Δ' -> + All2_telescope P Γ Γ' (mapi_rec (fun n => map_decl (f n)) Δ k) (mapi_rec (fun n => map_decl (f n)) Δ' k). Proof. induction 1; simpl; constructor; auto. Qed. Lemma local_env_telescope P Γ Γ' Δ Δ' : - All2_telescope (on_decl P) Γ Γ' Δ Δ' -> - All2_local_env_over P Γ Γ' (List.rev Δ) (List.rev Δ'). + All2_telescope (on_decls P) Γ Γ' Δ Δ' -> + All2_fold_over P Γ Γ' (List.rev Δ) (List.rev Δ'). Proof. induction 1. simpl. constructor. - - simpl. eapply All2_local_env_over_app. constructor. constructor. - simpl. reflexivity. apply p. + - simpl. depelim p. eapply All2_fold_over_app. + repeat constructor => //. revert IHX. generalize (List.rev Δ) (List.rev Δ'). induction 1. constructor. - constructor; auto. red in p0. red. red. red. red in p0. - rewrite !app_context_assoc. cbn. apply p0. - constructor; auto. destruct p0. unfold on_decl_over in *. simpl. - rewrite !app_context_assoc. cbn. intuition. - - simpl. eapply All2_local_env_over_app. constructor. constructor; auto. reflexivity. - simpl. unfold on_decl_over, on_decl in *. destruct p. split; intuition auto. + constructor; auto. depelim p0; constructor; unfold on_decls_over in *; + now rewrite !app_context_assoc. + - simpl. eapply All2_fold_over_app. repeat constructor => //. revert IHX. generalize (List.rev Δ) (List.rev Δ'). induction 1. constructor. - constructor; auto. red in p0. red. red. red. red in p0. - rewrite !app_context_assoc. cbn. apply p0. - constructor; auto. destruct p0. unfold on_decl_over in *. simpl. - rewrite !app_context_assoc. cbn. intuition. + constructor; auto. depelim p0; constructor; unfold on_decls_over in *; + now rewrite !app_context_assoc. Qed. @@ -2456,8 +2730,8 @@ Section Rho. (rho_ctx Γ) (dtype x) (rho (rho_ctx Γ) (dtype y))) * (dname x = dname y))%type m m' -> - All2_local_env_over (pred1 Σ) Γ' (rho_ctx Γ) Δ (rho_ctx_over (rho_ctx Γ) Δ') -> - All2_telescope_n (on_decl (pred1 Σ)) (fun n : nat => lift0 n) + All2_fold_over (pred1 Σ) Γ' (rho_ctx Γ) Δ (rho_ctx_over (rho_ctx Γ) Δ') -> + All2_telescope_n (on_decls (pred1 Σ)) (fun n : nat => lift0 n) (Γ' ,,, Δ) (rho_ctx (Γ ,,, Δ')) #|Δ| (map (fun def : def term => vass (dname def) (dtype def)) m) @@ -2465,8 +2739,8 @@ Section Rho. Proof. intros Δlen. induction 1 in Δ, Δ', Δlen |- *; cbn. constructor. - intros. destruct r. rewrite e. constructor. - red. rewrite rho_ctx_app. + intros. destruct r. rewrite e. repeat constructor. + rewrite rho_ctx_app. assert (#|Δ| = #|rho_ctx_over (rho_ctx Γ) Δ'|) by now rewrite rho_ctx_over_length. rewrite {2}H. eapply weakening_pred1_pred1; eauto. specialize (IHX (vass (dname y) (lift0 #|Δ| (dtype x)) :: Δ) @@ -2475,8 +2749,8 @@ Section Rho. rewrite {2}H. rewrite rho_lift0. unfold snoc. forward IHX. simpl. lia. - forward IHX. cbn. constructor. apply X0. reflexivity. - red. red. + forward IHX. cbn. constructor. apply X0. constructor. simpl. + red. assert (#|Δ'| = #|rho_ctx_over (rho_ctx Γ) Δ'|) by now rewrite rho_ctx_over_length. rewrite H0. rewrite - (rho_lift0 (rho_ctx Γ) (rho_ctx_over (rho_ctx Γ) Δ')). simpl. @@ -2489,7 +2763,7 @@ Section Rho. Lemma All_All2_telescopei (Γ Γ' : context) (m m' : mfixpoint term) : All2 (fun (x y : def term) => (pred1 Σ Γ' (rho_ctx Γ) (dtype x) (rho (rho_ctx Γ) (dtype y))) * (dname x = dname y))%type m m' -> - All2_telescope_n (on_decl (pred1 Σ)) (fun n : nat => lift0 n) + All2_telescope_n (on_decls (pred1 Σ)) (fun n : nat => lift0 n) Γ' (rho_ctx Γ) 0 (map (fun def : def term => vass (dname def) (dtype def)) m) @@ -2501,27 +2775,23 @@ Section Rho. Qed. - Lemma rho_All_All2_local_env_inv : + Lemma rho_All_All2_fold_inv : forall Γ Γ' : context, pred1_ctx Σ Γ' (rho_ctx Γ) -> forall Δ Δ' : context, - All2_local_env (on_decl (on_decl_over (pred1 Σ) Γ' (rho_ctx Γ))) Δ + All2_fold (on_decls (on_decls_over (pred1 Σ) Γ' (rho_ctx Γ))) Δ (rho_ctx_over (rho_ctx Γ) Δ') -> - All2_local_env - (on_decl + All2_fold + (on_decls (fun (Δ Δ' : context) (t t' : term) => pred1 Σ (Γ' ,,, Δ) (rho_ctx (Γ ,,, Δ')) t (rho (rho_ctx (Γ ,,, Δ')) t'))) Δ Δ'. Proof. - intros. induction Δ in Δ', X0 |- *. depelim X0. destruct Δ'; noconf H. constructor. - cbn in H. destruct c as [? [?|] ?]; noconf H. - depelim X0. - - destruct Δ'. noconf H. destruct c as [? [?|] ?]; noconf H. - constructor. 2:auto. eapply IHΔ; auto. red. red in o. intros. - red in o. rewrite !rho_ctx_app. eapply o. - - destruct Δ'. noconf H. destruct c as [? [?|] ?]; noconf H. - destruct o. - constructor. 2:auto. eapply IHΔ. auto. red. red in o, o0. intros. - rewrite !rho_ctx_app. split; eauto. + intros. induction Δ in Δ', X0 |- *; depelim X0; destruct Δ'; noconf H. + - constructor. + - destruct c as [? [?|] ?]; simpl in *; depelim a0; simpl in *; constructor; + rewrite ?rho_ctx_app. + 2:constructor; auto. eapply IHΔ; auto; rewrite !rho_ctx_app; eauto. + apply IHΔ; auto. constructor; auto. Qed. Lemma pred1_rho_fix_context_2 (Γ Γ' : context) (m m' : mfixpoint term) : @@ -2529,8 +2799,8 @@ Section Rho. All2 (on_Trel_eq (pred1 Σ Γ' (rho_ctx Γ)) dtype dname) m (map_fix rho (rho_ctx Γ) (fold_fix_context rho (rho_ctx Γ) [] m') m') -> - All2_local_env - (on_decl (on_decl_over (pred1 Σ) Γ' (rho_ctx Γ))) + All2_fold + (on_decls (on_decls_over (pred1 Σ) Γ' (rho_ctx Γ))) (fix_context m) (fix_context (map_fix rho (rho_ctx Γ) (fold_fix_context rho (rho_ctx Γ) [] m') m')). Proof. @@ -2585,6 +2855,17 @@ Section Rho. H : pred1_subst _ Δ Δ' _ _ |- _ => apply (pred1_subst_pred1_ctx H) end : pcuic. + + Lemma pred1_subst_ext Γ Δ Δ' σ σ' τ τ' : + σ =1 σ' -> + τ =1 τ' -> + pred1_subst Γ Δ Δ' σ τ <~> pred1_subst Γ Δ Δ' σ' τ'. + Proof. + intros Hσ Hτ. + rewrite /pred1_subst. split; intros H x; specialize (H x) as []. + split; now rewrite -(Hσ x) -(Hτ x). + split; now rewrite (Hσ x) (Hτ x). + Qed. Lemma pred1_subst_Up: forall (Γ : context) (na : aname) (t0 t1 : term) (Δ Δ' : context) (σ τ : nat -> term), @@ -2593,10 +2874,13 @@ Section Rho. pred1_subst (Γ,, vass na t0) (Δ,, vass na t0.[σ]) (Δ',, vass na t1.[τ]) (⇑ σ) (⇑ τ). Proof. intros Γ na t0 t1 Δ Δ' σ τ X2 Hrel. - intros x. destruct x; simpl. split; auto. eapply pred1_refl_gen. constructor; eauto with pcuic. - unfold subst_compose. rewrite - !(lift0_inst 1). - split. eapply (weakening_pred1_pred1 Σ _ _ [_] [_]); auto. - constructor. 2:auto. constructor. red. red. eapply X2. eapply Hrel. + intros x. destruct x; simpl. split; auto. + eapply pred1_refl_gen. constructor; eauto with pcuic. now constructor. + unfold subst_compose. + split. + rewrite - !(lift0_inst 1). + eapply (weakening_pred1_pred1 Σ _ _ [_] [_]); auto. + constructor. 2:auto. constructor. constructor; auto. eapply Hrel. destruct (Hrel x). destruct option_map as [[o|]|]; now rewrite ?y. Qed. @@ -2608,10 +2892,11 @@ Section Rho. pred1_subst (Γ,, vdef na b0 t0) (Δ,, vdef na b0.[σ] t0.[σ]) (Δ',, vdef na b1.[τ] t1.[τ]) (⇑ σ) (⇑ τ). Proof. intros Γ na b0 b1 t0 t1 Δ Δ' σ τ Xt Xb Hrel. - intros x. destruct x; simpl. split; auto. eapply pred1_refl_gen. constructor; eauto with pcuic. + intros x. destruct x; simpl. split; auto. eapply pred1_refl_gen. + constructor; eauto with pcuic; constructor; auto. unfold subst_compose. rewrite - !(lift0_inst 1). split. eapply (weakening_pred1_pred1 Σ _ _ [_] [_]); auto. - constructor. 2:auto. constructor. red. split; red. eapply Xb. apply Xt. + constructor. 2:auto. constructor. now constructor. eapply Hrel. destruct (Hrel x). destruct option_map as [[o|]|]; now rewrite ?y. Qed. @@ -2619,18 +2904,18 @@ Section Rho. Lemma pred1_subst_Upn: forall (Γ : context) (Δ Δ' : context) (σ τ : nat -> term) (Γ' Δ0 Δ1 : context) n, #|Γ'| = #|Δ0| -> #|Δ0| = #|Δ1| -> n = #|Δ0| -> - pred1_subst Γ Δ Δ' σ τ -> - All2_local_env_over (pred1 Σ) Δ Δ' Δ0 Δ1 -> - pred1_subst (Γ ,,, Γ') (Δ ,,, Δ0) (Δ' ,,, Δ1) (⇑^n σ) (⇑^n τ). + pred1_subst Γ Δ Δ' σ τ -> + All2_fold_over (pred1 Σ) Δ Δ' Δ0 Δ1 -> + pred1_subst (Γ ,,, Γ') (Δ ,,, Δ0) (Δ' ,,, Δ1) (⇑^n σ) (⇑^n τ). Proof. intros * len0 len1 -> Hrel. red. intros H x. destruct (leb_spec_Set (S x) #|idsn #|Δ0| |). unfold Upn. - specialize (subst_consn_lt l). + specialize (subst_consn_lt_spec l). intros [tx [Hdecl Heq]]. rewrite !Heq. split. eapply pred1_refl_gen. auto. - eapply All2_local_env_over_app; auto. destruct (Hrel 0). pcuic. + eapply All2_fold_over_app; auto. destruct (Hrel 0). pcuic. destruct option_map as [[o|]|]; auto. unfold Upn. rewrite !subst_consn_ge. lia. lia. @@ -2645,6 +2930,21 @@ Section Rho. unfold subst_compose. simpl. rewrite y. reflexivity. Qed. + Lemma pred1_subst_up + (Γ : context) (Δ Δ' : context) (σ τ : nat -> term) (Γ' Δ0 Δ1 : context) n : + #|Γ'| = #|Δ0| -> n = #|Δ0| -> + pred1_subst Γ Δ Δ' σ τ -> + All2_fold_over (pred1 Σ) Δ Δ' Δ0 Δ1 -> + pred1_subst (Γ ,,, Γ') (Δ ,,, Δ0) (Δ' ,,, Δ1) (up n σ) (up n τ). + Proof. + intros len' -> ps a. + eapply pred1_subst_ext; tea. + 1-2:rewrite up_Upn //. + eapply pred1_subst_Upn => //. + apply (length_of a). + Qed. + Hint Resolve pred1_subst_up : pcuic. + Lemma substitution_pred1 Γ Δ Γ' Δ' s s' N N' : psubst Σ Γ Γ' s s' Δ Δ' -> pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') N N' -> @@ -2654,49 +2954,54 @@ Section Rho. pose proof (substitution_let_pred1 Σ Γ Δ [] Γ' Δ' [] s s' N N' wfΣ) as H. assert (#|Γ| = #|Γ'|). { eapply psubst_length in redM. intuition auto. - apply pred1_pred1_ctx in redN. eapply All2_local_env_length in redN. + apply pred1_pred1_ctx in redN. eapply All2_fold_length in redN. rewrite !app_context_length in redN. lia. } forward H by auto. forward H by pcuic. specialize (H eq_refl). forward H. apply pred1_pred1_ctx in redN; pcuic. - eapply All2_local_env_app in redN; auto. + eapply All2_fold_app_inv in redN; auto. destruct redN. apply a0. simpl in H. now apply H. Qed. - Lemma inst_iota_red s pars c args brs : - inst s (iota_red pars c args brs) = - iota_red pars c (List.map (inst s) args) (List.map (on_snd (inst s)) brs). + Lemma All2_fold_fold_context P f g Γ Δ : + All2_fold (fun Γ Δ T U => P (fold_context_k f Γ) (fold_context_k g Δ) + (map_decl (f #|Γ|) T) (map_decl (g #|Δ|) U)) Γ Δ -> + All2_fold P (fold_context_k f Γ) (fold_context_k g Δ). Proof. - unfold iota_red. rewrite !inst_mkApps. f_equal; auto using map_skipn. - rewrite nth_map; simpl; auto. + induction 1; rewrite ?fold_context_k_snoc0; constructor; auto. Qed. - - Lemma All2_local_env_fold_context P f g Γ Δ : - All2_local_env (fun Γ Δ p T U => P (fold_context f Γ) (fold_context g Δ) - (option_map (fun '(b, b') => (f #|Γ| b, g #|Δ| b')) p) - (f #|Γ| T) (g #|Δ| U)) Γ Δ -> - All2_local_env P (fold_context f Γ) (fold_context g Δ). + + Lemma All2_fold_fold_context_inv P f g Γ Δ : + All2_fold P (fold_context f Γ) (fold_context g Δ) -> + All2_fold (fun Γ Δ T U => + let Γ' := fold_context f Γ in + let Δ' := fold_context g Δ in + P Γ' Δ' (f Γ' T) (g Δ' U)) Γ Δ. Proof. - induction 1; rewrite ?fold_context_snoc0; constructor; auto. + induction Γ in Δ |- *; destruct Δ; intros h; depelim h. + - constructor. + - constructor; auto. Qed. - Lemma All2_local_env_fix_context P σ τ Γ Δ : - All2_local_env (fun Γ Δ p T U => P (inst_context σ Γ) (inst_context τ Δ) - (option_map (fun '(b, b') => (b.[⇑^#|Γ| σ], b'.[⇑^#|Δ| τ])) p) - (T.[⇑^#|Γ| σ]) (U.[⇑^#|Δ| τ])) Γ Δ -> - All2_local_env P (inst_context σ Γ) (inst_context τ Δ). + Lemma All2_fold_fix_context P σ τ Γ Δ : + All2_fold (on_decls (fun Γ Δ T U => + P (inst_context σ Γ) (inst_context τ Δ) (T.[⇑^#|Γ| σ]) (U.[⇑^#|Δ| τ]))) Γ Δ -> + All2_fold (on_decls P) (inst_context σ Γ) (inst_context τ Δ). Proof. - eapply All2_local_env_fold_context. + intros H. + eapply All2_fold_fold_context. + eapply PCUICEnvironment.All2_fold_impl; tea => /=. + intros ? ? ? ? []; constructor; auto. Qed. - Lemma All2_local_env_impl P Q Γ Δ : - All2_local_env P Γ Δ -> - (forall Γ Δ t T U, #|Γ| = #|Δ| -> P Γ Δ t T U -> Q Γ Δ t T U) -> - All2_local_env Q Γ Δ. + Lemma All2_fold_impl_len P Q Γ Δ : + All2_fold P Γ Δ -> + (forall Γ Δ T U, #|Γ| = #|Δ| -> P Γ Δ T U -> Q Γ Δ T U) -> + All2_fold Q Γ Δ. Proof. - intros H HP. pose proof (All2_local_env_length H). + intros H HP. pose proof (All2_fold_length H). induction H; constructor; simpl; eauto. Qed. @@ -2747,12 +3052,37 @@ Section Rho. revert Δ Δ' σ τ. revert Γ Γ' s t redst. set (P' := fun Γ Γ' => pred1_ctx Σ Γ Γ'). - refine (pred1_ind_all_ctx Σ _ P' _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); subst P'; + set (Pover := fun Γ Γ' ctx ctx' => + forall Δ Δ' σ τ, + ctxmap Γ Δ σ -> + ctxmap Γ' Δ' τ -> + pred1_subst Γ Δ Δ' σ τ -> + pred1_ctx_over Σ Δ Δ' (inst_context σ ctx) (inst_context τ ctx')). + + refine (pred1_ind_all_ctx Σ _ P' Pover _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); subst P' Pover; try (intros until Δ; intros Δ' σ τ Hσ Hτ Hrel); trivial. (* induction redst using ; sigma; intros Δ Δ' σ τ Hσ Hτ Hrel. *) all:eauto 2 with pcuic. + 1:{ simpl. + intros ctx ctx' σ' τ' cmap cmap' ps. + rewrite /inst_context - !mapi_context_fold. + eapply All2_fold_mapi, All2_fold_impl_ind; tea => /=. + clear Hrel. + intros. + unfold on_decls_over in *. + rewrite !mapi_context_fold - !/(inst_context _ _). + eapply X0. + + eapply Upn_ctxmap => //. eapply pres_bodies_inst_context. + + eapply Upn_ctxmap => //. eapply pres_bodies_inst_context. + + rewrite -(length_of X). eapply pred1_subst_Upn; len => //. + { apply (length_of X). } + eapply All2_fold_fold_context, All2_fold_impl_len; tea => /= //. + intros. + intros. eapply All_decls_map, All_decls_impl; tea => /=. + unfold on_decls_over. now rewrite -> !mapi_context_fold. } + (** Beta case *) 1:{ eapply simpl_pred; simpl; rewrite ?up_Upn; sigma; try reflexivity. specialize (X2 _ _ _ _ Hσ Hτ Hrel). @@ -2762,7 +3092,6 @@ Section Rho. forward X0. eapply pred1_subst_Up; auto. specialize (X4 _ _ _ _ Hσ Hτ Hrel). eapply (pred_beta _ _ _ _ _ _ _ _ _ _ X2 X0 X4). } - (** Let-in delta case *) 2:{ rewrite lift_rename rename_inst. @@ -2792,37 +3121,35 @@ Section Rho. - simpl. eapply Hrel. - - simpl. rewrite inst_iota_red. - sigma. econstructor. - now eapply pred1_subst_pred1_ctx. - solve_all. solve_all. - red in X2. solve_all. + - simpl. rewrite inst_iota_red //. + sigma. econstructor; eauto. + + now eapply pred1_subst_pred1_ctx. + + solve_all. + + erewrite nth_error_map, H => //. + + now len. + + solve_all; red. red in b0. + simpl. rewrite !mapi_context_inst. + eapply b0 => //. + rewrite !mapi_context_inst. + red in b. cbn. + eapply b; eauto with pcuic. + eapply pred1_subst_ext. + 3:eapply pred1_subst_Upn; tea; len => //. + 1-3: sigma => //; now rewrite -(length_of a0). + apply b0 => //. - sigma. unfold unfold_fix in *. destruct nth_error eqn:Heq; noconf H. - assert (All2_local_env (on_decl (on_decl_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) + assert (All2_fold (on_decls (on_decls_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) (inst_context τ (fix_context mfix1))). - { clear -wfΣ Hσ Hτ Hrel X2. - induction X2. - + constructor. - + rewrite !inst_context_snoc. constructor; auto. - hnf in p |- *. simpl. eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. - apply (All2_local_env_length X2). - + rewrite !inst_context_snoc. constructor; auto. - hnf in p |- *. simpl. split; eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto with pcuic. } + { exact (X2 _ _ _ _ Hσ Hτ Hrel). } econstructor; eauto with pcuic. instantiate (1 := (map (map_def (inst τ) (inst (⇑^#|mfix1| τ))) mfix1)). rewrite !inst_fix_context; auto. rewrite !inst_fix_context; auto. + clear -X5 wfΣ X3 Hσ Hτ Hrel. red. eapply All2_map. - red in X3. pose proof (All2_length _ _ X3). + red in X3. pose proof (All2_length X3). solve_all; unfold on_Trel in *; simpl in *; intuition eauto. eapply b. rewrite -(fix_context_length mfix0); auto with pcuic. @@ -2834,34 +3161,20 @@ Section Rho. rewrite map_fix_subst. simpl. intros. f_equal. apply map_ext. intros. apply map_def_eq_spec; auto. now sigma. rewrite Upn_comp ?map_length ?fix_subst_length //. - rewrite subst_consn_compose. now sigma. + solve_all. - (* CoFix Case *) simpl. sigma. unfold unfold_cofix in H |- *. destruct nth_error eqn:Heq; noconf H. - assert (All2_local_env (on_decl (on_decl_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) + assert (All2_fold (on_decls (on_decls_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) (inst_context τ (fix_context mfix1))). - { clear -wfΣ Hσ Hτ Hrel X2. - induction X2. - + constructor. - + rewrite !inst_context_snoc. constructor; auto. - hnf in p |- *. simpl. eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. - apply (All2_local_env_length X2). - + rewrite !inst_context_snoc. constructor; auto. - hnf in p |- *. simpl. split; eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto with pcuic. } + { exact (X2 _ _ _ _ Hσ Hτ Hrel). } econstructor. eapply pred1_subst_pred1_ctx; eauto. instantiate (1 := (map (map_def (inst τ) (inst (⇑^#|mfix1| τ))) mfix1)). rewrite !inst_fix_context; auto. rewrite !inst_fix_context; auto. - + clear -X8 wfΣ X3 Hσ Hτ Hrel. red. eapply All2_map. - red in X3. pose proof (All2_length _ _ X3). + + clear -X11 wfΣ X3 Hσ Hτ Hrel. red. eapply All2_map. + red in X3. pose proof (All2_length X3). solve_all; unfold on_Trel in *; simpl in *; intuition eauto. eapply b. rewrite -(fix_context_length mfix0); auto with pcuic. @@ -2873,36 +3186,38 @@ Section Rho. rewrite map_cofix_subst'. simpl. intros. f_equal. apply map_ext. intros. apply map_def_eq_spec; auto. now sigma. rewrite Upn_comp ?map_length ?cofix_subst_length //. - rewrite subst_consn_compose. now sigma. + solve_all. (* args *) + + simpl. solve_all. + eauto. - + red in X7. solve_all. + + red in X7. red. simpl. + rewrite !mapi_context_inst. eauto. + + simpl. rewrite !mapi_context_inst. + eapply X9; eauto with pcuic. + eapply pred1_subst_ext. + 1-2:rewrite !up_Upn //. + pose proof (length_of X6). rewrite H. + eapply pred1_subst_Upn; len => //. + eapply X7 => //. + + solve_all; red; simpl; eauto; rewrite !mapi_context_inst; eauto. + eapply b => //; eauto with pcuic. + eapply pred1_subst_ext. + 1-2:rewrite !up_Upn //. + pose proof (length_of a0). rewrite H. + eapply pred1_subst_Upn; len => //. + eapply b0 => //. - (* Proj Cofix *) simpl. sigma. unfold unfold_cofix in H |- *. destruct nth_error eqn:Heq; noconf H. - assert (All2_local_env (on_decl (on_decl_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) + assert (All2_fold (on_decls (on_decls_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) (inst_context τ (fix_context mfix1))). - { clear -wfΣ Hσ Hτ Hrel X2. - induction X2. - + constructor. - + rewrite !inst_context_snoc. constructor; auto. - hnf in p |- *. simpl. eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. - apply (All2_local_env_length X2). - + rewrite !inst_context_snoc. constructor; auto. - hnf in p |- *. simpl. split; eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto with pcuic. } + { exact (X2 _ _ _ _ Hσ Hτ Hrel). } econstructor. eapply pred1_subst_pred1_ctx; eauto. instantiate (1 := (map (map_def (inst τ) (inst (⇑^#|mfix1| τ))) mfix1)). rewrite !inst_fix_context; auto. rewrite !inst_fix_context; auto. + clear -X5 wfΣ X3 Hσ Hτ Hrel. red. eapply All2_map. - red in X3. pose proof (All2_length _ _ X3). + red in X3. pose proof (All2_length X3). solve_all; unfold on_Trel in *; simpl in *; intuition eauto. eapply b. rewrite -(fix_context_length mfix0); auto with pcuic. @@ -2914,11 +3229,10 @@ Section Rho. rewrite map_cofix_subst'. simpl. intros. f_equal. apply map_ext. intros. apply map_def_eq_spec; auto. now sigma. rewrite Upn_comp ?map_length ?cofix_subst_length //. - rewrite subst_consn_compose. now sigma. + solve_all. (* args *) - simpl. rewrite inst_closed0. - rewrite closedn_subst_instance_constr; auto. + rewrite closedn_subst_instance; auto. eapply declared_decl_closed in H; auto. hnf in H. rewrite H0 in H. rtoProp; auto. econstructor; eauto with pcuic. @@ -2939,40 +3253,30 @@ Section Rho. eapply pred1_subst_vdef_Up; eauto. - (* Case congruence *) - simpl. econstructor; eauto. red in X3. solve_all. + simpl. econstructor; eauto with pcuic; unfold on_Trel; simpl; solve_all; + rewrite !mapi_context_inst; eauto with pcuic. + + eapply X5; eauto with pcuic. + have len := length_of X2. rewrite len. + eapply pred1_subst_up; len => //. + eapply X3 => //. + + eapply b; eauto with pcuic. + have len := length_of a0. rewrite len. + eapply pred1_subst_up; len => //. + eapply b0 => //. - (* Proj congruence *) sigma; pcuic. - (* Fix congruence *) sigma. - assert (All2_local_env (on_decl (on_decl_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) + assert (All2_fold (on_decls (on_decls_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) (inst_context τ (fix_context mfix1))). - { eapply All2_local_env_fix_context. - pose proof (pred1_subst_pred1_ctx Hrel). apply All2_local_env_length in X4. - clear -wfΣ X4 X2 Hσ Hτ Hrel. - induction X2; constructor; simpl in *; auto. - + hnf in p |- *. simpl. eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. - apply (All2_local_env_length X2). - apply All2_local_env_app. apply All2_local_env_app_inv. pcuic. - now eapply All2_local_env_fold_context. destruct (Hrel 0); auto with pcuic. - + hnf in p |- *. simpl. split; eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. - apply (All2_local_env_length X2). - apply All2_local_env_app. apply All2_local_env_app_inv. pcuic. - now eapply All2_local_env_fold_context. destruct (Hrel 0); auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. auto with pcuic. - apply All2_local_env_app. apply All2_local_env_app_inv. pcuic. - now eapply All2_local_env_fold_context. destruct (Hrel 0); auto with pcuic. } + { exact (X2 _ _ _ _ Hσ Hτ Hrel). } constructor; auto with pcuic. { now rewrite !inst_fix_context. } rewrite !inst_fix_context. apply All2_map. red in X3. - pose proof (All2_length _ _ X3). + pose proof (All2_length X3). solve_all. unfold on_Trel in *. simpl. intuition auto. unfold on_Trel in *. simpl. intuition auto. @@ -2983,33 +3287,14 @@ Section Rho. - (* CoFix congruence *) sigma. - assert (All2_local_env (on_decl (on_decl_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) + assert (All2_fold (on_decls (on_decls_over (pred1 Σ) Δ Δ')) (inst_context σ (fix_context mfix0)) (inst_context τ (fix_context mfix1))). - { eapply All2_local_env_fix_context. - pose proof (pred1_subst_pred1_ctx Hrel). apply All2_local_env_length in X4. - clear -wfΣ X4 X2 Hσ Hτ Hrel. - induction X2; constructor; simpl in *; auto. - + hnf in p |- *. simpl. eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. - apply (All2_local_env_length X2). - apply All2_local_env_app. apply All2_local_env_app_inv. pcuic. - now eapply All2_local_env_fold_context. destruct (Hrel 0); auto with pcuic. - + hnf in p |- *. simpl. split; eapply p; auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. - apply (All2_local_env_length X2). - apply All2_local_env_app. apply All2_local_env_app_inv. pcuic. - now eapply All2_local_env_fold_context. destruct (Hrel 0); auto with pcuic. - rewrite -(All2_local_env_length X2). - eapply pred1_subst_Upn; rewrite ?inst_context_length; auto. auto with pcuic. - apply All2_local_env_app. apply All2_local_env_app_inv. pcuic. - now eapply All2_local_env_fold_context. destruct (Hrel 0); auto with pcuic. } + { exact (X2 _ _ _ _ Hσ Hτ Hrel). } constructor; auto with pcuic. { now rewrite !inst_fix_context. } rewrite !inst_fix_context. apply All2_map. red in X3. - pose proof (All2_length _ _ X3). + pose proof (All2_length X3). solve_all. unfold on_Trel in *. simpl. intuition auto. unfold on_Trel in *. simpl. intuition auto. @@ -3028,31 +3313,324 @@ Section Rho. - rewrite !pred_atom_inst; auto. eapply pred1_refl_gen; auto with pcuic. Qed. + (* + Instance All_decls_refl P : + Reflexive P -> + Reflexive (All_decls P). +Proof. intros hP d; destruct d as [na [b|] ty]; constructor; auto. Qed. *) + + (*Lemma strong_substitutivity_fixed Γ Γ' Δ Δ' s t σ τ : + pred1 Σ Γ Γ' s t -> s = t -> Γ = Γ' -> + ctxmap Γ Δ σ -> + ctxmap Γ' Δ' τ -> + (forall x : nat, pred1 Σ Δ Δ' (σ x) (τ x)) -> + pred1 Σ Δ Δ' s.[σ] t.[τ]. + Proof. + intros redst eq eqΓ. + revert Δ Δ' σ τ. + revert Γ Γ' s t redst eq eqΓ. + set (P' := fun Γ Γ' => Γ = Γ' -> pred1_ctx Σ Γ Γ'). + set (Pover := fun Γ Γ' ctx ctx' => + forall Δ Δ' σ τ, + Γ = Γ' -> + ctxmap Γ Δ σ -> + ctxmap Γ' Δ' τ -> + (forall x, pred1 Σ Δ Δ' (σ x) (τ x)) -> + pred1_ctx_over Σ Δ Δ' (inst_context σ ctx) (inst_context τ ctx')).*) + + + Lemma All2_fold_context_assumptions {P Γ Δ} : + All2_fold (on_decls P) Γ Δ -> + context_assumptions Γ = context_assumptions Δ. + Proof. + induction 1; simpl; auto. depelim p => /=; now auto using f_equal. + Qed. + + Lemma pred1_subst_consn {Δ Δ' Γ Γ' args0 args1} : + pred1_ctx Σ Γ' (rho_ctx Γ) -> + #|args1| = #|args0| -> + context_assumptions Δ' = #|args0| -> + All2 (pred1 Σ Γ' (rho_ctx Γ)) args1 args0 -> + pred1_subst (Δ ,,, smash_context [] Δ') Γ' (rho_ctx Γ) (args1 ⋅n ids) (args0 ⋅n ids). + Proof. + intros Hpred hlen Hctx Ha. + intros i. + destruct (leb_spec_Set (S i) #|args1|). + pose proof (subst_consn_lt_spec l) as [arg [hnth heq]]. + rewrite heq. + split. + - eapply All2_nth_error_Some in Ha as [t' [hnth' pred]]; tea. + pose proof (subst_consn_lt_spec (nth_error_Some_length hnth')) as [arg' [hnth'' ->]]. + rewrite hnth' in hnth''. now noconf hnth''. + - case: nth_error_appP => /= //. + * intros x hnth'. len => hleni. + eapply nth_error_smash_context in hnth'. + now rewrite hnth'. + intros ? ?; now rewrite nth_error_nil. + * len. intros x hnth' hi. + destruct (decl_body x) eqn:db => //. + rewrite subst_consn_ge; len => //. lia. + specialize (heq ids). rewrite subst_consn_ge in heq. lia. + congruence. + - split => //. + * rewrite subst_consn_ge //. lia. + pose proof (All2_length Ha). len in H. rewrite H. + rewrite subst_consn_ge //. len. lia. len. + eapply pred1_refl_gen => //. + * rewrite nth_error_app_ge. len. lia. + destruct nth_error eqn:hnth' => /= //. + destruct decl_body eqn:db => /= //. + rewrite !subst_consn_ge; len; try lia. + congruence. + Qed. + + Lemma pred1_subst_shiftn {Δ Δ' Γ Γ' n s s'} : + n = #|Δ'| -> + pred1_subst (Δ ,,, Δ') Γ Γ' s s' -> + pred1_subst Δ Γ Γ' (↑^n ∘s s) (↑^n ∘s s'). + Proof. + intros hn Hp i. + specialize (Hp (n + i)) as [IH hnth]. + split => //. + case: nth_error_spec => /= // x hnth' hi. + destruct decl_body eqn:db => //. subst n. + rewrite nth_error_app_ge in hnth; try lia. + unfold subst_compose, shiftk; simpl. + replace (#|Δ'| + i - #|Δ'|) with i in hnth by lia. + now rewrite hnth' /= db in hnth. + Qed. + + Lemma pred1_subst_ids Δ Γ Γ' : + pred1_ctx Σ Γ Γ' -> + pred1_subst Δ Γ Γ' ids ids. + Proof. + intros i; split. + - now eapply pred1_refl_gen. + - destruct nth_error => /= //. + destruct decl_body => //. + Qed. + + Lemma pred1_subst_skipn {Δ Δ' Γ Γ' n s s'} : + #|s| = #|s'| -> + #|Δ'| = n -> + pred1_ctx Σ Γ Γ' -> + pred1_subst (Δ ,,, Δ') Γ Γ' (s ⋅n ids) (s' ⋅n ids) -> + pred1_subst Δ Γ Γ' (skipn n s ⋅n ids) (skipn n s' ⋅n ids). + Proof. + intros. + destruct (leb_spec_Set (S n) #|s|). + - eapply pred1_subst_ext. + 1,2:rewrite skipn_subst //; try lia. + now eapply pred1_subst_shiftn. + - rewrite !skipn_all2; try lia. + eapply pred1_subst_ext. 1-2:rewrite subst_consn_nil //. + now eapply pred1_subst_ids. + Qed. + + Lemma ctxmap_smash_context Γ Δ s : + #|s| = context_assumptions Δ -> + ctxmap (Γ,,, smash_context [] Δ) Γ (s ⋅n ids). + Proof. + red. intros hargs x d hnth'. + destruct (decl_body d) eqn:db => /= //. + move: hnth'. + case: nth_error_appP; len => //. + - intros x' hnths hlen [= ->]. + eapply nth_error_smash_context in hnths => //. congruence. + intros ? ?; rewrite nth_error_nil => /= //. + - intros x' hnth cass [= ->]. + rewrite subst_consn_ge. lia. + unfold ids. eexists _, _. intuition eauto. + rewrite hargs hnth /= db //. + apply inst_ext => i. + unfold shiftk, subst_compose; simpl. + rewrite subst_consn_ge. lia. + lia_f_equal. + Qed. + + Lemma context_assumptions_smash_context' acc Γ : + context_assumptions (smash_context acc Γ) = #|smash_context [] Γ| + + context_assumptions acc. + Proof. + induction Γ as [|[na [b|] ty] Γ]; simpl; len; auto; + rewrite context_assumptions_smash_context; now len. + Qed. + + Lemma context_assumptions_smash_context'' Γ : + context_assumptions (smash_context [] Γ) = #|smash_context [] Γ|. + Proof. + rewrite context_assumptions_smash_context' /=; lia. + Qed. + + Lemma context_assumptions_smash Γ : + context_assumptions Γ = #|smash_context [] Γ|. + Proof. + rewrite -context_assumptions_smash_context''. + now rewrite context_assumptions_smash_context. + Qed. + + Lemma All2_fold_over_smash_acc {Γ Γ' Δ Δ'} acc acc' : + pred1_ctx_over Σ Γ Γ' Δ Δ' -> + pred1_ctx_over Σ (Γ ,,, Δ) (Γ' ,,, Δ') acc acc' -> + pred1_ctx_over Σ Γ Γ' (smash_context acc Δ) (smash_context acc' Δ'). + Proof. + intros hΔ. revert acc acc'. + induction hΔ; simpl; auto. + intros acc acc' h. + depelim p => /=. + - eapply IHhΔ. + eapply All2_fold_app. repeat constructor; auto. + eapply All2_fold_impl; tea => Γ1 Δ T U; + rewrite /on_decls_over => hlen; + rewrite !app_context_assoc; intuition auto. + - eapply IHhΔ. + rewrite /subst_context - !mapi_context_fold. + eapply All2_fold_mapi. + eapply All2_fold_impl_ind; tea. + intros par par' x y onpar; rewrite /on_decls_over /=. + rewrite !mapi_context_fold - !/(subst_context _ _ _). + intros pred. rewrite !Nat.add_0_r. + eapply (substitution_let_pred1 Σ (Γ ,,, Γ0) [vdef na b t] par + (Γ' ,,, Γ'0) [vdef na b' t'] par' [b] [b'] x y) => //; eauto with pcuic. + * rewrite -{1}(subst_empty 0 b) -{1}(subst_empty 0 b'). + repeat constructor; pcuic. now rewrite !subst_empty. + * len. move: (length_of onpar). + move: (length_of (pred1_pred1_ctx _ pred)). len. simpl. len. lia. + * repeat constructor. pcuic. pcuic. + Qed. + + Lemma pred1_ctx_over_smash Γ Γ' Δ Δ' : + pred1_ctx_over Σ Γ Γ' Δ Δ' -> + pred1_ctx_over Σ Γ Γ' (smash_context [] Δ) (smash_context [] Δ'). + Proof. + intros h. + eapply (All2_fold_over_smash_acc [] []) in h => //. + constructor. + Qed. + + Lemma pred1_ext Γ Γ' t t' u u' : + t = t' -> u = u' -> pred1 Σ Γ Γ' t u -> pred1 Σ Γ Γ' t' u'. + Proof. + now intros -> ->. + Qed. + + Lemma subst0_inst (s : list term) (t : term) : + subst0 s t = t.[s ⋅n ids]. + Proof. now sigma. Qed. + Hint Rewrite subst0_inst : sigma. + + Lemma pred1_expand_lets Γ Γ' Δ Δ' b b' : + pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') b b' -> + #|Γ| = #|Γ'| -> + pred1 Σ (Γ ,,, smash_context [] Δ) (Γ' ,,, smash_context [] Δ') + (expand_lets Δ b) (expand_lets Δ' b'). + Proof. + intros pred hlen. + induction Δ in Γ, Γ', hlen, Δ', b, b', pred |- * using ctx_length_rev_ind. + - destruct Δ'. simpl. now rewrite !expand_lets_nil. + eapply pred1_pred1_ctx in pred. + move: (length_of pred). len. lia. + - destruct Δ' using rev_case. + { eapply pred1_pred1_ctx in pred. + move: (length_of pred). len. lia. } + pose proof (pred1_pred1_ctx _ pred). + apply All2_fold_app_inv in X0 as []. + apply All2_fold_app_inv in a0 as []. + depelim a0. clear a0. + all:simpl; auto. + depelim a1. + * rewrite !(smash_context_app) /=. + rewrite !app_context_assoc in pred. + specialize (X Γ0 ltac:(reflexivity) _ _ _ _ _ pred ltac:(len; lia)). + now rewrite !expand_lets_vass !app_context_assoc. + * rewrite !(smash_context_app) /=. + rewrite !app_context_assoc in pred. + specialize (X Γ0 ltac:(reflexivity) _ _ _ _ _ pred ltac:(len; lia)). + rewrite !expand_lets_vdef. + rewrite (expand_lets_subst_comm Γ0 [b0] b). + rewrite (expand_lets_subst_comm l [b'0] b'). + eapply substitution_let_pred1 in X; eauto. len in X; now exact X. + + rewrite -{1}(subst_empty 0 b0) -{1}(subst_empty 0 b'0); repeat constructor; pcuic. + now rewrite !subst_empty. + + len. now eapply All2_fold_context_assumptions in a2. + + repeat constructor => //. + Qed. + + Lemma fold_context_cst ctx : ctx = fold_context (fun _ d => map_decl id d) ctx. + Proof. + induction ctx; simpl; auto. + now rewrite -IHctx map_decl_id. + Qed. + + Lemma All2_fold_sym' P (Γ Δ : context) : + All2_fold P Γ Δ -> + All2_fold (fun Δ Γ t' t => P Γ Δ t t') Δ Γ. + Proof. + induction 1; constructor; auto; now symmetry. + Qed. +(* + Lemma pred1_ctx_over_rho_right Γ Γ' Δ Δ' : + pred1_ctx_over Σ Γ Γ' Δ' (rho_ctx_over (rho_ctx Γ) Δ) -> + All2_fold + (on_decls + (on_decls_over + (fun (Γ0 Γ'0 : context) (t t0 : term) => + pred1 Σ Γ0 Γ'0 t0 (rho (rho_ctx Γ0) t)) Γ Γ')) + Δ Δ'. + Proof. + rewrite {1}(fold_context_cst Δ'). + intros h. + eapply All2_fold_fold_context_inv in h. + eapply All2_fold_sym' in h. + eapply All2_fold_impl; tea; clear => /=; + rewrite /on_decls /on_decls_over /id => Γ'' Δ'' [[? ?]|] ? ?; + simpl; intuition auto. + rewrite -fold_context_cst in a, b. *) + + Lemma nth_error_fix_context_ass Γ mfix x decl : + nth_error (rho_ctx_over (rho_ctx Γ) (fix_context mfix)) x = Some decl -> + decl_body decl = None. + Proof. + rewrite fold_fix_context_rho_ctx fold_fix_context_rev_mapi. + rewrite rev_mapi /= app_nil_r nth_error_mapi. + now destruct nth_error => /= // => [= <-]. + Qed. Lemma triangle Γ Δ t u : let Pctx := fun (Γ Δ : context) => pred1_ctx Σ Δ (rho_ctx Γ) in + let Pctxover := + fun (Γ Δ ctx ctx' : context) => + pred1_ctx_over Σ Δ (rho_ctx Γ) ctx' (rho_ctx_over (rho_ctx Γ) ctx) in pred1 Σ Γ Δ t u -> pred1 Σ Δ (rho_ctx Γ) u (rho (rho_ctx Γ) t). Proof with solve_discr. - intros Pctx H. revert Γ Δ t u H. - refine (pred1_ind_all_ctx Σ _ Pctx _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); - subst Pctx; intros *. + intros Pctx Pctxover H. revert Γ Δ t u H. + refine (pred1_ind_all_ctx Σ _ Pctx Pctxover _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); + subst Pctx Pctxover; intros *. all:try intros **; rename_all_hyps; try solve [specialize (forall_Γ _ X3); eauto]; eauto; try solve [simpl; econstructor; simpl; eauto]. - simpl. - - induction X0; simpl; depelim predΓ'; constructor; rewrite ?app_context_nil_l; eauto. all:now symmetry. + - simpl. + induction X0; simpl; depelim predΓ'; constructor; rewrite ?app_context_nil_l; simpl; eauto. + depelim p; depelim a; constructor; simpl; auto. + + - (* ctx over *) + simpl. + induction X3; simpl; depelim X2; constructor; simpl; + unfold on_decls_over in p |- *; intuition auto. + depelim p; depelim a; constructor; simpl; auto. + * now rewrite rho_ctx_app in p. + * now rewrite rho_ctx_app in p. + * now rewrite rho_ctx_app in p0. - simpl. rewrite (rho_app_lambda _ _ _ _ _ []). eapply (substitution0_pred1); simpl in *. eauto. eauto. - rewrite app_context_nil_l in X0. eapply X0. - simp rho. eapply (substitution0_let_pred1); simpl in *. eauto. eauto. - rewrite app_context_nil_l in X4. eapply X4. - simp rho. @@ -3065,14 +3643,14 @@ Section Rho. destruct H. intuition. rewrite a. simp rho. rewrite -{1}(firstn_skipn (S i) Γ'). rewrite -{1}(firstn_skipn (S i) (rho_ctx Γ)). - pose proof (All2_local_env_length X0). + pose proof (All2_fold_length X0). assert (S i = #|firstn (S i) Γ'|). rewrite !firstn_length_le; try lia. assert (S i = #|firstn (S i) (rho_ctx Γ)|). rewrite !firstn_length_le; try lia. rewrite {5}H0 {6}H1. eapply weakening_pred1_pred1; eauto. - eapply All2_local_env_over_firstn_skipn. auto. + eapply All2_fold_over_firstn_skipn. auto. noconf heq_option_map. - simp rho. simpl in *. @@ -3081,17 +3659,45 @@ Section Rho. constructor. auto. constructor. auto. - - simpl in X0. cbn. + - (* iota reduction *) + simpl in X0. cbn. rewrite rho_app_case. rewrite decompose_app_mkApps; auto. change eq_inductive with (@eqb inductive _). - destruct (eqb_spec ind ind); try discriminate. + destruct (eqb_spec ci.(ci_ind) ci.(ci_ind)); try discriminate. 2:{ congruence. } - unfold iota_red. eapply pred_mkApps; eauto. - eapply pred_snd_nth. red in X2. - now eapply rho_triangle_All_All2_ind_noeq. auto. - eapply All2_skipn. eapply All2_sym. - rewrite - {1} (map_id args1). eapply All2_map, All2_impl; eauto. simpl. intuition. + unfold iota_red. + eapply All2_nth_error_Some_right in X2 as [br0 [hnth [[predctx predbod] [hbctx hbbod]]]]; tea. + unfold on_Trel in predctx, predbod. + rewrite hnth. + eapply All2_fold_context_assumptions in predctx as ->. + rewrite List.skipn_length. + pose proof (All2_length X1). + rewrite H. + rewrite List.skipn_length in heq_length. + rewrite heq_length /= Nat.eqb_refl. + rewrite !subst_inst. + eapply rho_triangle_All_All2_ind_terms in X1. + eapply strong_substitutivity. + + rewrite rho_ctx_app in hbbod. + instantiate (2 := (Γ' ,,, smash_context [] (bcontext br))). + instantiate (1 := (rho_ctx Γ ,,, smash_context [] (rho_ctx_over (rho_ctx Γ) (bcontext br0)))). + eapply pred1_expand_lets => //. len. + now pose proof (length_of predΓ'). + + eapply ctxmap_ext. sigma. reflexivity. + eapply ctxmap_smash_context. len. + rewrite List.skipn_length. lia. + + eapply ctxmap_ext. sigma. reflexivity. + eapply ctxmap_smash_context; len. + rewrite List.skipn_length. + pose proof (All2_fold_context_assumptions predbod). + len in H0. congruence. + + eapply pred1_subst_ext. + 1-2:sigma; reflexivity. + eapply All2_skipn in X1. + eapply All2_rev in X1. + eapply pred1_subst_consn in X1 => //; rewrite !List.rev_length !List.skipn_length; len; lia. + + auto. - (* Fix reduction *) unfold unfold_fix in heq_unfold_fix |- *. @@ -3115,20 +3721,19 @@ Section Rho. simpl. rewrite isc. eapply pred_mkApps. rewrite rho_ctx_app in Hreleq1. - rewrite !subst_inst. simpl_pred. + rewrite !subst_inst. eapply simpl_pred; [sigma; trea|sigma; trea|]. rewrite /rho_fix_context -fold_fix_context_rho_ctx. eapply strong_substitutivity; eauto. - apply ctxmap_fix_subst. - rewrite -rho_fix_subst -{1}fix_context_map_fix. - apply ctxmap_fix_subst. - rewrite -rho_fix_subst. - eapply All2_prop2_eq_split in X3. - apply pred_subst_rho_fix; intuition auto. - eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. unfold on_Trel in *. - intuition eauto. + * apply ctxmap_fix_subst. + * rewrite -rho_fix_subst -{1}fix_context_map_fix. + apply ctxmap_fix_subst. + * rewrite -rho_fix_subst. + eapply All2_prop2_eq_split in X3. + apply pred_subst_rho_fix; intuition auto. + * eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. + intuition eauto. - (* Case-CoFix reduction *) - destruct ip. rewrite rho_app_case. rewrite decompose_app_mkApps; auto. unfold unfold_cofix in heq_unfold_cofix |- *. @@ -3136,22 +3741,25 @@ Section Rho. eapply All2_prop2_eq_split in X3. intuition. eapply All2_nth_error_Some_right in Heq; eauto. destruct Heq as [t' [Ht' Hrel]]. rewrite Ht'. simpl. - eapply pred_case. eauto. eapply pred_mkApps. - red in Hrel. destruct Hrel. - rewrite rho_ctx_app in p2. - rewrite - fold_fix_context_rho_ctx. - set (rhoΓ := rho_ctx Γ ,,, rho_ctx_over (rho_ctx Γ) (fix_context mfix0)) in *. - rewrite !subst_inst. eapply simpl_pred; try now sigma. - eapply strong_substitutivity; eauto. apply ctxmap_cofix_subst. - unfold rhoΓ. - rewrite -{1}fix_context_map_fix. - rewrite -rho_cofix_subst. - now eapply ctxmap_cofix_subst. - rewrite -rho_cofix_subst. - now eapply pred_subst_rho_cofix; auto. - eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. intuition eauto. - eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. unfold on_Trel in *. - intuition eauto. + unfold on_Trel in *. destruct Hrel. + eapply pred_case; simpl; eauto. + * eapply All2_sym, All2_map_left, All2_impl; tea => /=; intuition eauto. + * rewrite -> rho_ctx_app in *. eauto. + * eapply All2_sym, All2_map_left, All2_impl; tea => /=; unfold on_Trel; + intuition eauto. + rewrite rho_ctx_app in b3. simpl; eauto. + * eapply pred_mkApps. + rewrite rho_ctx_app in p2. + rewrite -fold_fix_context_rho_ctx. + set (rhoΓ := rho_ctx Γ ,,, rho_ctx_over (rho_ctx Γ) (fix_context mfix0)) in *. + rewrite !subst_inst. eapply simpl_pred; try now sigma. + eapply strong_substitutivity; eauto. apply ctxmap_cofix_subst. + unfold rhoΓ. rewrite -{1}fix_context_map_fix. + rewrite -rho_cofix_subst. + now eapply ctxmap_cofix_subst. + rewrite -rho_cofix_subst. + now eapply pred_subst_rho_cofix; auto. + eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. intuition eauto. - (* Proj-Cofix reduction *) simpl. @@ -3166,9 +3774,21 @@ Section Rho. econstructor. eapply pred_mkApps; eauto. rewrite - fold_fix_context_rho_ctx. rewrite rho_ctx_app in Hreleq1. - eapply substitution_pred1; eauto. - { eapply wf_rho_cofix_subst; eauto. - now eapply All2_length in X3. } + sigma. eapply strong_substitutivity; eauto with pcuic. + eapply ctxmap_cofix_subst. + { intros x hnth. + case: nth_error_appP => // decl hnth' hx; intros [= ->]. + eapply nth_error_fix_context_ass in hnth'. rewrite hnth' => //. + len in hx. + destruct decl_body eqn:db => //. + rewrite subst_consn_ge. len. lia. + unfold ids. len. eexists _, _; intuition eauto. + len in hnth'. rewrite hnth' /= db //. + eapply inst_ext. intros i. unfold subst_compose, shiftn, shiftk. + simpl. rewrite subst_consn_ge. len. lia. len. lia_f_equal. } + rewrite -rho_cofix_subst. + red in X3. apply pred_subst_rho_cofix => //; solve_all. + red in a. red. intuition auto. eapply All2_sym, All2_map_left, All2_impl; eauto; simpl; intuition eauto. - simpl; simp rho; simpl. @@ -3187,8 +3807,7 @@ Section Rho. simpl in y. rewrite e0. simpl. auto. - - simpl; simp rho. eapply pred_abs; auto. unfold snoc in *. simpl in X2. - rewrite app_context_nil_l in X2. apply X2. + - simpl; simp rho. eapply pred_abs; auto. - (** Application *) simp rho. @@ -3224,7 +3843,7 @@ Section Rho. eapply (pred1_mkApps_tFix_refl_inv _ _ _ mfix1) in X0; eauto. 2:{ noconf eqsd'. simpl in H; noconf H. rewrite -H0. - pose proof (All2_length _ _ Hargs). + pose proof (All2_length Hargs). unfold is_constructor in i1. move: i1 i0. elim: nth_error_spec => //. @@ -3278,49 +3897,57 @@ Section Rho. simpl. constructor; auto. - simpl; simp rho; simpl. eapply pred_zeta; eauto. - now simpl in X4; rewrite app_context_nil_l in X4. - + - (* Case reduction *) - destruct ind. rewrite rho_app_case. - destruct (decompose_app c0) eqn:Heq. simpl. + rewrite rho_ctx_app in X5. + have hpars : (All2 (pred1 Σ Γ' (rho_ctx Γ)) (pparams p1) + (map (rho (rho_ctx Γ)) (pparams p0))). + { eapply All2_sym, All2_map_left, All2_impl; tea => /=; intuition eauto. } + have hbrs : All2 + (fun br br' : branch term => + on_Trel (pred1_ctx_over Σ Γ' (rho_ctx Γ)) bcontext br br' * + on_Trel (pred1 Σ (Γ',,, bcontext br) (rho_ctx Γ,,, bcontext br')) bbody br + br') brs1 (map (rho_br (rho_ctx Γ)) brs0). + { eapply All2_sym, All2_map_left, All2_impl; tea => /=; unfold on_Trel; intuition eauto. + now rewrite rho_ctx_app in b1. } + + destruct (decompose_app c0) eqn:Heq. cbn -[eqb]. destruct (construct_cofix_discr t) eqn:Heq'. + destruct t; noconf Heq'. + (* Iota *) apply decompose_app_inv in Heq. - subst c0. simpl. - simp rho. - simpl. simp rho in X2. + subst c0. cbn -[eqb]. + simp rho. simp rho in X8. change eq_inductive with (@eqb inductive _). - destruct (eqb_spec i ind). subst ind. - eapply pred1_mkApps_tConstruct in X1 as [args' [? ?]]. subst c1. - eapply pred1_mkApps_refl_tConstruct in X2. - econstructor; eauto. pcuic. - eapply All2_sym, All2_map_left, All2_impl; eauto. - intros. hnf in X1. destruct X1. unfold on_Trel in *. - intuition pcuic. - econstructor; pcuic. - eapply All2_sym, All2_map_left, All2_impl; eauto. - intros. unfold on_Trel in *. intuition pcuic. - + destruct (eqb_spec ci.(ci_ind) ind) ; try solve [pcuic]. subst ind. + destruct (nth_error brs0 n) eqn:hbr => //; try solve [pcuic]. + case: eqb_spec => [eq|neq]; pcuic. + eapply pred1_mkApps_tConstruct in X7 as [args' [? ?]]; pcuic. subst c1. + eapply pred1_mkApps_refl_tConstruct in X8. + econstructor; eauto; pcuic. + * now erewrite nth_error_map, hbr. + * now simpl; len. + + (* CoFix *) apply decompose_app_inv in Heq. subst c0. simpl. simp rho. - simpl. simp rho in X2. - eapply pred1_mkApps_tCoFix_inv in X1 as [mfix' [idx' [[? ?] ?]]]. + simpl. simp rho in X8. + eapply pred1_mkApps_tCoFix_inv in X7 as [mfix' [idx' [[? ?] ?]]]. subst c1. - simpl in X2. eapply pred1_mkApps_tCoFix_refl_inv in X2. + simpl in X8. eapply pred1_mkApps_tCoFix_refl_inv in X8. intuition. eapply All2_prop2_eq_split in a1. intuition. unfold unfold_cofix. assert (All2 (on_Trel eq dname) mfix' (map_fix rho (rho_ctx Γ) (fold_fix_context rho (rho_ctx Γ) [] mfix) mfix)). { eapply All2_impl; [eapply b0|]; pcuic. } - pose proof (All2_mix a1 X1). - eapply pred1_rho_fix_context_2 in X2; pcuic. - rewrite - fold_fix_context_rho_ctx in X2. - rewrite fix_context_map_fix in X2. - eapply rho_All_All2_local_env_inv in X2; pcuic. + pose proof (All2_mix a1 X). + eapply pred1_rho_fix_context_2 in X7; pcuic. + rewrite - fold_fix_context_rho_ctx in X7. + rewrite fix_context_map_fix in X7. + eapply rho_All_All2_fold_inv in X7; pcuic. rewrite /rho_fix_context - fold_fix_context_rho_ctx in a1. destruct nth_error eqn:Heq. simpl. @@ -3332,32 +3959,29 @@ Section Rho. (fix_context mfix)) mfix) (rarg d); pcuic. - --- eapply All2_local_env_pred_fix_ctx; eauto. + -- eapply All2_fold_pred_fix_ctx; eauto. eapply All2_prop2_eq_split in a. intuition auto. - eapply All2_local_env_sym. + eapply All2_fold_sym. pcuic. - --- eapply All2_mix; pcuic. + -- eapply All2_mix; pcuic. rewrite /rho_fix_context - fold_fix_context_rho_ctx in b1. eapply All2_mix. eauto. now rewrite /rho_fix_context - fold_fix_context_rho_ctx in b0. - --- unfold unfold_cofix. + -- unfold unfold_cofix. rewrite nth_error_map. rewrite H. simpl. f_equal. f_equal. unfold map_fix. rewrite fold_fix_context_rho_ctx. rewrite (map_cofix_subst _ (fun Γ Γ' => rho (Γ ,,, Γ'))) //. intros. simp rho; simpl; simp rho. reflexivity. - --- apply All2_sym. eapply All2_map_left. eapply All2_impl; eauto. - unfold on_Trel in *. - intros. intuition pcuic. - - * eapply pred_case; eauto. + + * eapply pred_case; simpl; eauto; solve_all. eapply pred_mkApps. constructor. pcuic. --- rewrite /rho_fix_context - fold_fix_context_rho_ctx. - eapply All2_local_env_pred_fix_ctx. + eapply All2_fold_pred_fix_ctx. eapply All2_prop2_eq_split in a. intuition auto. - eapply All2_local_env_sym. + eapply All2_fold_sym. pcuic. --- eapply All2_mix; pcuic. @@ -3365,16 +3989,8 @@ Section Rho. now rewrite /rho_fix_context - fold_fix_context_rho_ctx. eapply All2_mix; pcuic. --- pcuic. - --- eapply All2_sym, All2_map_left, All2_impl; eauto. - unfold on_Trel in *. - intros. intuition pcuic. - + + apply decompose_app_inv in Heq. subst c0. - assert (All2 (on_Trel_eq (pred1 Σ Γ' (rho_ctx Γ)) snd fst) brs1 - (map (fun x : nat * term => (fst x, rho (rho_ctx Γ) (snd x))) brs0)). - { eapply All2_sym, All2_map_left, All2_impl; eauto. - unfold on_Trel in *. - intros. intuition pcuic. } destruct t; try discriminate; simpl; pcuic. - (* Proj *) @@ -3419,7 +4035,7 @@ Section Rho. eapply pred1_rho_fix_context_2 in X2; pcuic. rewrite - fold_fix_context_rho_ctx in X2. rewrite fix_context_map_fix in X2. - eapply rho_All_All2_local_env_inv in X2; pcuic. + eapply rho_All_All2_fold_inv in X2; pcuic. rewrite /rho_fix_context - fold_fix_context_rho_ctx in a1. intuition auto. destruct nth_error eqn:Heq. simpl. @@ -3432,9 +4048,9 @@ Section Rho. (fix_context mfix)) mfix) (rarg d); pcuic. - --- eapply All2_local_env_pred_fix_ctx; eauto. + --- eapply All2_fold_pred_fix_ctx; eauto. eapply All2_prop2_eq_split in a. intuition auto. - eapply All2_local_env_sym. + eapply All2_fold_sym. pcuic. --- eapply All2_mix; pcuic. @@ -3459,7 +4075,8 @@ Section Rho. - simp rho; simpl; simp rho. rewrite /rho_fix_context - fold_fix_context_rho_ctx. constructor; eauto. - now eapply All2_local_env_pred_fix_ctx. red. red in X3. + { now rewrite fix_context_map_fix. } + red. red in X3. eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. unfold on_Trel; intuition pcuic. rewrite rho_ctx_app in b. now rewrite fix_context_map_fix. @@ -3467,18 +4084,22 @@ Section Rho. - simp rho; simpl; simp rho. rewrite - fold_fix_context_rho_ctx. constructor; eauto. - now eapply All2_local_env_pred_fix_ctx. red. red in X3. + { now rewrite fix_context_map_fix. } + red. red in X3. eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. unfold on_Trel; intuition pcuic. rewrite rho_ctx_app in b. now rewrite fix_context_map_fix. - - simp rho; simpl; econstructor; eauto. simpl in X2. now rewrite !app_context_nil_l in X2. - - simpl in *. simp rho. constructor. eauto. eapply All2_sym, All2_map_left, All2_impl. eauto. - intros. simpl in X. intuition. + - simp rho; simpl; econstructor; eauto. + - simpl in *. simp rho. constructor. eauto. + eapply All2_sym, All2_map_left, All2_impl; tea => /=; intuition auto. - destruct t; noconf H; simpl; constructor; eauto. Qed. End Rho. +Notation fold_context_term f := (fold_context (fun Γ' => map_decl (f Γ'))). +Notation rho_ctx Σ := (fold_context_term (rho Σ)). + (* The diamond lemma for parallel reduction follows directly from the triangle lemma. *) Corollary pred1_diamond {cf : checker_flags} {Σ : global_env} {Γ Δ Δ' t u v} : diff --git a/pcuic/theories/PCUICPosition.v b/pcuic/theories/PCUICPosition.v index 657ce3e93..a174cfb40 100644 --- a/pcuic/theories/PCUICPosition.v +++ b/pcuic/theories/PCUICPosition.v @@ -2,7 +2,7 @@ From Coq Require Import RelationClasses. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICInduction - PCUICReflect PCUICEquality PCUICLiftSubst. + PCUICReflect PCUICEquality PCUICLiftSubst PCUICCases. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. @@ -11,6 +11,13 @@ Local Set Keyed Unification. Set Default Goal Selector "!". +Inductive context_decl_choice := +| choose_decl_body +| choose_decl_type. + +Derive NoConfusion NoConfusionHom EqDec for context_decl_choice. + +Definition context_choice := nat * context_decl_choice. (* A choice is a local position. We define positions in a non dependent way to make it more practical. @@ -18,9 +25,12 @@ Set Default Goal Selector "!". Inductive choice := | app_l | app_r -| case_p +| case_par (n : nat) +| case_pctx (c : context_choice) +| case_preturn | case_c -| case_brs (n : nat) +| case_brsctx (n : nat) (c : context_choice) +| case_brsbody (n : nat) | proj_c | fix_mfix_ty (n : nat) | fix_mfix_bd (n : nat) @@ -41,6 +51,17 @@ Instance reflect_choice : ReflectEq choice := Definition position := list choice. +Definition context_choice_term (Γ : context) (c : context_choice) : option term := + let '(decli, declc) := c in + match nth_error Γ decli with + | Some {| decl_body := body; decl_type := type |} => + match declc with + | choose_decl_body => body + | choose_decl_type => Some type + end + | None => None + end. + Fixpoint validpos t (p : position) {struct p} := match p with | [] => true @@ -48,11 +69,30 @@ 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_p, tCase indn pr c brs => validpos pr p - | case_c, tCase indn pr c brs => validpos c p - | case_brs n, tCase indn 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 + end + | case_pctx ctxc, tCase ci pr c brs => + match context_choice_term pr.(pcontext) ctxc with + | Some t => validpos t p + | None => false + end + | case_preturn, tCase ci pr c brs => validpos pr.(preturn) p + | case_c, tCase ci pr c brs => validpos c p + | case_brsctx n ctxc, tCase ci pr c brs => match nth_error brs n with - | Some (_, br) => validpos br p + | Some br => + match context_choice_term br.(bcontext) ctxc with + | Some t => validpos t p + | None => false + end + | None => false + end + | case_brsbody n, tCase ci pr c brs => + match nth_error brs n with + | Some br => validpos br.(bbody) p | None => false end | proj_c, tProj pr c => validpos c p @@ -97,17 +137,17 @@ Definition dapp_l u v (p : pos u) : pos (tApp u v) := Definition dapp_r u v (p : pos v) : pos (tApp u v) := exist (app_r :: proj1_sig p) (proj2_sig p). -Definition dcase_p indn pr c brs (p : pos pr) : pos (tCase indn pr c brs) := - exist (case_p :: proj1_sig p) (proj2_sig p). +Definition dcase_preturn ci pr c brs (p : pos pr.(preturn)) : pos (tCase ci pr c brs) := + exist (case_preturn :: proj1_sig p) (proj2_sig p). -Definition dcase_c indn pr c brs (p : pos c) : pos (tCase indn pr c brs) := +Definition dcase_c ci pr c brs (p : pos c) : pos (tCase ci pr c brs) := exist (case_c :: proj1_sig p) (proj2_sig p). -(* Equations dcase_brs (n : nat) (indn : inductive × nat) +(* Equations dcase_brs (n : nat) (ci : inductive × nat) (pr c : term) (brs : list (nat × term)) (m : nat) (br : term) (h : nth_error brs n = Some (m,br)) - (p : pos br) : pos (tCase indn pr c brs) := - dcase_brs n indn pr c brs m br h p := + (p : pos br) : pos (tCase ci pr c brs) := + dcase_brs n ci pr c brs m br h p := exist (case_brs n :: ` p) _. Next Obligation. rewrite h. exact (proj2_sig p). @@ -138,6 +178,28 @@ Definition dlet_ty na b B t (p : pos B) : pos (tLetIn na b B t) := Definition dlet_in na b B t (p : pos t) : pos (tLetIn na b B t) := exist (let_in :: proj1_sig p) (proj2_sig p). +Lemma eq_context_upto_context_choice_term Σ Re Rle Γ Γ' c : + eq_context_upto Σ Re Rle Γ Γ' -> + rel_option (eq_term_upto_univ Σ Re (match c.2 with + | choose_decl_body => Re + | choose_decl_type => Rle + end) ) + (context_choice_term Γ c) + (context_choice_term Γ' c). +Proof. + intros eq. + destruct c as (n&c). + eapply eq_context_upto_nth_error with (ctx := Γ) (ctx' := Γ') (n := n) in eq. + depelim eq; cbn in *. + - rewrite H, H0. + destruct e as ((?&?)&?); cbn in *. + destruct a, b; cbn in *. + destruct c; auto. + constructor; auto. + - rewrite H, H0. + constructor. +Qed. + Lemma eq_term_upto_valid_pos : forall {Σ u v p Re Rle napp}, validpos u p -> @@ -153,12 +215,30 @@ Proof. eapply ih ; eauto ]. + dependent destruction e. simpl in *. - destruct (nth_error brs n) as [[m br]|] eqn:e. 2: discriminate. - induction a in n, m, br, e, ih, vp |- *. 1: rewrite e. 1: assumption. + destruct (nth_error (pparams p0) n) as [par|] eqn:enth. 2: discriminate. + destruct e. + induction a0 in n, par, enth, ih, vp |- *. 1: rewrite enth. 1: assumption. destruct n. - * simpl in *. apply some_inj in e. subst. - destruct y. simpl in *. intuition eauto. - * simpl in *. eapply IHa. all: eauto. + * simpl in *. apply some_inj in enth. subst. + intuition eauto. + * simpl in *. eapply IHa0. all: eauto. + + dependent destruction e. simpl in *. + destruct e as (_&_&e&_). + eapply eq_context_upto_context_choice_term with (c := c) in e. + depelim e; rewrite H, H0 in *; eauto. + + dependent destruction e. simpl in *. + eapply ih; eauto. apply e. + + dependent destruction e. simpl in *. + destruct nth_error eqn:nth; [|congruence]. + eapply All2_nth_error_Some in a; eauto. + destruct a as (?&->&eq&_). + eapply eq_context_upto_context_choice_term with (c := c) in eq. + depelim eq; rewrite H, H0 in *; eauto. + + dependent destruction e. simpl in *. + destruct nth_error eqn:nth; [|congruence]. + eapply All2_nth_error_Some in a; eauto. + destruct a as (?&->&_&eq). + eauto. + dependent destruction e. simpl in *. destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e. 2: discriminate. induction a in n, na, ty, bo, ra, e, ih, vp |- *. @@ -302,39 +382,84 @@ Proof. - eapply (ih2 (exist p0 e)). assumption. } assert ( - forall indn pr c brs p, + forall n ci pr c brs par (p : pos par) + (e : nth_error pr.(pparams) n = Some par) + (e1 : validpos (tCase ci pr c brs) (case_par n :: proj1_sig p) = true), Acc posR p -> - Acc posR (dcase_p indn pr c brs p) + Acc posR (exist (case_par n :: proj1_sig p) e1) + ) as Acc_case_pars. + { intros n ci pr c brs par p e e1 h. + induction h as [p ih1 ih2] in e, e1 |- *. + constructor. intros [q e2] h. + dependent destruction h. + simple refine (let q := exist p0 _ : pos par in _). + - simpl. cbn in e2. rewrite e in e2. assumption. + - specialize (ih2 q). eapply ih2. all: assumption. + } + assert ( + forall ci pr c brs ctxc t (p : pos t) + (e : context_choice_term pr.(pcontext) ctxc = Some t) + (vp : validpos (tCase ci pr c brs) (case_pctx ctxc :: proj1_sig p) = true), + Acc posR p -> + Acc posR (exist (case_pctx ctxc :: proj1_sig p) vp)) as Acc_case_pctx. + { intros ci pr c brs ctxc t p e vp h. + induction h as [p ih1 ih2] in e, vp |- *. + constructor. intros [q e2] h. + dependent destruction h. + simple refine (let q := exist p0 _ : pos t in _). + - simpl. cbn in e2. rewrite e in e2. assumption. + - specialize (ih2 q). eapply ih2. all: assumption. + } + assert ( + forall ci pr c brs p, + Acc posR p -> + Acc posR (dcase_preturn ci pr c brs p) ) as Acc_case_p. - { intros indn pr c brs p h. + { intros ci pr c brs p h. induction h as [p ih1 ih2]. constructor. intros [q e] h. dependent destruction h. eapply (ih2 (exist p0 e)). assumption. } assert ( - forall indn pr c brs p, + forall ci pr c brs p, Acc posR p -> - Acc posR (dcase_c indn pr c brs p) + Acc posR (dcase_c ci pr c brs p) ) as Acc_case_c. - { intros indn pr c brs p h. + { intros ci pr c brs p h. induction h as [p ih1 ih2]. constructor. intros [q e] h. dependent destruction h. eapply (ih2 (exist p0 e)). assumption. } assert ( - forall n indn pr c brs m br (p : pos br) - (e : nth_error brs n = Some (m, br)) - (e1 : validpos (tCase indn pr c brs) (case_brs n :: proj1_sig p) = true), + forall ci pr c brs n br ctxc t (p : pos t) + (brsnth : nth_error brs n = Some br) + (e : context_choice_term br.(bcontext) ctxc = Some t) + (vp : validpos (tCase ci pr c brs) (case_brsctx n ctxc :: proj1_sig p) = true), + Acc posR p -> + Acc posR (exist (case_brsctx n ctxc :: proj1_sig p) vp) + ) as Acc_case_brsctx. + { intros ci pr c brs n br ctxc t p brsnth e vp h. + induction h as [p ih1 ih2] in brsnth, e, vp |- *. + constructor. intros [q e2] h. + dependent destruction h. + simple refine (let q := exist p0 _ : pos t in _). + - simpl. cbn in e2. rewrite brsnth, e in e2. assumption. + - specialize (ih2 q). eapply ih2. all: assumption. + } + assert ( + forall n ci pr c brs br (p : pos br.(bbody)) + (e : nth_error brs n = Some br) + (e1 : validpos (tCase ci pr c brs) (case_brsbody n :: proj1_sig p) = true), Acc posR p -> - Acc posR (exist (case_brs n :: proj1_sig p) e1) + Acc posR (exist (case_brsbody n :: proj1_sig p) e1) ) as Acc_case_brs. - { intros n indn pr c brs m br p e e1 h. + { intros n ci pr c brs br p e e1 h. induction h as [p ih1 ih2] in e, e1 |- *. constructor. intros [q e2] h. dependent destruction h. - simple refine (let q := exist p0 _ : pos br in _). + simple refine (let q := exist p0 _ : pos br.(bbody) in _). - simpl. cbn in e2. rewrite e in e2. assumption. - specialize (ih2 q). eapply ih2. all: assumption. } @@ -470,34 +595,127 @@ Proof. -- assumption. * eapply Acc_app_r with (p := exist q e). eapply IHt2. - - destruct q as [q e]. destruct q as [| c q]. + - destruct X as [IHXpars IHXpred]. + destruct q as [q e]. destruct q as [| c q]. + constructor. intros [p' e'] h. unfold posR in h. cbn in h. dependent destruction h. destruct c ; noconf e'. + * simpl in e'. + case_eq (nth_error (pparams p) n). + 2:{ intro h. pose proof e' as hh. rewrite h in hh. discriminate. } + intros par e1. + eapply All_nth_error in IHXpars as ihpar. 2: exact e1. + unshelve eapply Acc_case_pars with (1 := e1) (p := exist p0 _). + -- simpl. rewrite e1 in e'. assumption. + -- eapply ihpar. + * simpl in e'. + case_eq (context_choice_term (pcontext p) c). + 2:{ intro h. exfalso. rewrite h in e'. discriminate. } + intros t' choose. + assert (validpos t' p0 × forall (p : pos t'), Acc posR p) as (vp&IH). + { rewrite choose in e'. + split; auto. + unfold context_choice_term in choose. + destruct c. + destruct nth_error eqn:nth; [|discriminate]. + eapply fst, All_nth_error in IHXpred; eauto. + destruct c0, IHXpred; cbn in *. + destruct c; subst; auto. + noconf choose. + auto. } + unshelve eapply Acc_case_pctx with (1 := choose) (p := exist p0 _); eauto. * eapply Acc_case_p with (p := exist p0 e'). - eapply IHt1. + eapply IHXpred. * eapply Acc_case_c with (p := exist p0 e'). - eapply IHt2. + eapply IHt. + * simpl in e'. + case_eq (nth_error l n). + 2:{ intro h. pose proof e' as hh. rewrite h in hh. discriminate. } + intros br nthbr. + case_eq (context_choice_term br.(bcontext) c). + 2:{ intro h. exfalso. rewrite nthbr, h in e'. discriminate. } + intros t' choose. + assert (validpos t' p0 × forall (p : pos t'), Acc posR p) as (vp&IH). + { rewrite nthbr, choose in e'. + split; auto. + unfold context_choice_term in choose. + destruct c. + eapply All_nth_error in nthbr; eauto. + cbn in *. + destruct nthbr as (IH&_). + destruct nth_error eqn:nthctx; [|discriminate]. + eapply All_nth_error in IH; eauto. + destruct c0, IH; cbn in *. + destruct c; subst; auto. + noconf choose. + auto. } + unshelve eapply Acc_case_brsctx with (1 := nthbr) (2 := choose) (p := exist p0 _); eauto. * simpl in e'. case_eq (nth_error l n). 2:{ intro h. pose proof e' as hh. rewrite h in hh. discriminate. } - intros [m br] e1. - eapply All_nth_error in X as ihbr. 2: exact e1. + intros br e1. + eapply All_nth_error in X0 as ihbr. 2: exact e1. simpl in ihbr. unshelve eapply Acc_case_brs with (1 := e1) (p := exist p0 _). -- simpl. rewrite e1 in e'. assumption. -- eapply ihbr. + destruct c ; noconf e. + * simpl in e. + case_eq (nth_error (pparams p) n). + 2:{ intro h. pose proof e as hh. rewrite h in hh. discriminate. } + intros par e1. + eapply All_nth_error in IHXpars as ihpar. 2: exact e1. + unshelve eapply Acc_case_pars with (1 := e1) (p := exist q _). + -- simpl. rewrite e1 in e. assumption. + -- eapply ihpar. + * simpl in e. + case_eq (context_choice_term (pcontext p) c). + 2:{ intro h. exfalso. rewrite h in e. discriminate. } + intros t' choose. + assert (validpos t' q × forall (p : pos t'), Acc posR p) as (vp&IH). + { rewrite choose in e. + split; auto. + unfold context_choice_term in choose. + destruct c. + destruct nth_error eqn:nth; [|discriminate]. + eapply fst, All_nth_error in IHXpred; eauto. + destruct c0, IHXpred; cbn in *. + destruct c; subst; auto. + noconf choose. + auto. } + unshelve eapply Acc_case_pctx with (1 := choose) (p := exist q _); eauto. * eapply Acc_case_p with (p := exist q e). - eapply IHt1. + eapply IHXpred. * eapply Acc_case_c with (p := exist q e). - eapply IHt2. + eapply IHt. * simpl in e. case_eq (nth_error l n). 2:{ intro h. pose proof e as hh. rewrite h in hh. discriminate. } - intros [m br] e1. - eapply All_nth_error in X as ihbr. 2: exact e1. + intros br nthbr. + case_eq (context_choice_term br.(bcontext) c). + 2:{ intro h. exfalso. rewrite nthbr, h in e. discriminate. } + intros t' choose. + assert (validpos t' q × forall (p : pos t'), Acc posR p) as (vp&IH). + { rewrite nthbr, choose in e. + split; auto. + unfold context_choice_term in choose. + destruct c. + eapply All_nth_error in nthbr; eauto. + cbn in *. + destruct nthbr as (IH&_). + destruct nth_error eqn:nthctx; [|discriminate]. + eapply All_nth_error in IH; eauto. + destruct c0, IH; cbn in *. + destruct c; subst; auto. + noconf choose. + auto. } + unshelve eapply Acc_case_brsctx with (1 := nthbr) (2 := choose) (p := exist q _); eauto. + * simpl in e. + case_eq (nth_error l n). + 2:{ intro h. pose proof e as hh. rewrite h in hh. discriminate. } + intros br e1. + eapply All_nth_error in X0 as ihbr. 2: exact e1. simpl in ihbr. unshelve eapply Acc_case_brs with (1 := e1) (p := exist q _). -- simpl. rewrite e1 in e. assumption. @@ -605,11 +823,27 @@ Fixpoint atpos t (p : position) {struct p} : term := match c, t with | app_l, tApp u v => atpos u p | app_r, tApp u v => atpos v p - | case_p, tCase indn pr c brs => atpos pr p - | case_c, tCase indn pr c brs => atpos c p - | case_brs n, tCase indn pr c brs => + | case_par n, tCase ci pr c brs => + match nth_error pr.(pparams) n with + | Some par => atpos par p + | None => tRel 0 + end + | case_pctx choice, tCase ci pr c brs => + option_get + (tRel 0) + (t <- context_choice_term pr.(pcontext) choice;; + Some (atpos t p)) + | case_preturn, tCase ci pr c brs => atpos pr.(preturn) p + | case_c, tCase ci pr c brs => atpos c p + | case_brsctx n choice, tCase ci pr c brs => + option_get + (tRel 0) + (br <- nth_error brs n;; + t <- context_choice_term br.(bcontext) choice;; + Some (atpos t p)) + | case_brsbody n, tCase ci pr c brs => match nth_error brs n with - | Some (_, br) => atpos br p + | Some br => atpos br.(bbody) p | None => tRel 0 end | proj_c, tProj pr c => atpos c p @@ -658,7 +892,18 @@ Proof. - destruct t ; destruct a. all: try solve [ rewrite hh ; reflexivity ]. all: try apply IHp. - + simpl. destruct nth_error as [[m br]|] eqn:e. + + simpl. destruct nth_error as [?|] eqn:e. + * apply IHp. + * rewrite hh. reflexivity. + + simpl. destruct context_choice_term eqn:e. + * apply IHp. + * rewrite hh. reflexivity. + + simpl. destruct nth_error as [br|] eqn:e. + * destruct context_choice_term. + -- apply IHp. + -- rewrite hh. reflexivity. + * rewrite hh. reflexivity. + + simpl. destruct nth_error. * apply IHp. * rewrite hh. reflexivity. + simpl. destruct nth_error as [[na ty bo ra]|] eqn:e. @@ -688,16 +933,15 @@ Proof. - destruct t ; destruct a. all: try noconf hp. all: try (apply IHp ; assumption). - + simpl in *. destruct nth_error as [[m br]|] eqn:e. 2: discriminate. - apply IHp. all: assumption. - + simpl in *. destruct nth_error as [[na ty bo ra]|] eqn:e. 2: discriminate. - apply IHp. all: assumption. - + simpl in *. destruct nth_error as [[na ty bo ra]|] eqn:e. 2: discriminate. - apply IHp. all: assumption. - + simpl in *. destruct nth_error as [[na ty bo ra]|] eqn:e. 2: discriminate. - apply IHp. all: assumption. - + simpl in *. destruct nth_error as [[na ty bo ra]|] eqn:e. 2: discriminate. - apply IHp. all: assumption. + all: simpl in *; + repeat + match goal with + | [H: context[nth_error ?a ?b] |- _] => + destruct (nth_error a b); [|discriminate] + | [H: context[context_choice_term ?a ?b] |- _] => + destruct (context_choice_term a b); [|discriminate] + end; + auto. Qed. Lemma positionR_poscat : @@ -722,31 +966,18 @@ Proof. all: try apply IHp. all: destruct q ; try reflexivity. all: try (destruct c ; reflexivity). - + destruct nth_error as [[m br]|] eqn:e. 2: reflexivity. - simpl. rewrite app_nil_r. reflexivity. - + destruct nth_error as [[m br]|] eqn:e. - * apply IHp. - * destruct c. all: reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. 2: reflexivity. - simpl. rewrite app_nil_r. reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. - * apply IHp. - * destruct c. all: reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. 2: reflexivity. - simpl. rewrite app_nil_r. reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. - * apply IHp. - * destruct c. all: reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. 2: reflexivity. - simpl. rewrite app_nil_r. reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. - * apply IHp. - * destruct c. all: reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. 2: reflexivity. - simpl. rewrite app_nil_r. reflexivity. - + destruct nth_error as [[na ty bo ra]|] eqn:e. - * apply IHp. - * destruct c. all: reflexivity. + all: + repeat + match goal with + | |- context[nth_error ?a ?b] => + destruct (nth_error a b); auto + | |- context[context_choice_term ?a ?b] => + destruct (context_choice_term a b); auto + end. + all: rewrite ?app_nil_r. + all: simpl; auto. + all: try solve [destruct c; auto]; try solve [destruct c0; auto]. + all: rewrite <- IHp; auto. Qed. Lemma positionR_trans : Transitive positionR. @@ -782,78 +1013,182 @@ Proof. - cbn. constructor. apply IHp. assumption. Qed. -(* Stacks are the dual of positions. - They can be seen as terms with holes. - *) -Inductive stack : Type := -| Empty -| App (t : term) (π : stack) -| Fix (f : mfixpoint term) (n : nat) (args : list term) (π : stack) -| Fix_mfix_ty (na : aname) (bo : term) (ra : nat) (mfix1 mfix2 : mfixpoint term) (id : nat) (π : stack) -| Fix_mfix_bd (na : aname) (ty : term) (ra : nat) (mfix1 mfix2 : mfixpoint term) (id : nat) (π : stack) -| CoFix (f : mfixpoint term) (n : nat) (args : list term) (π : stack) -| CoFix_mfix_ty (na : aname) (bo : term) (ra : nat) (mfix1 mfix2 : mfixpoint term) (id : nat) (π : stack) -| CoFix_mfix_bd (na : aname) (ty : term) (ra : nat) (mfix1 mfix2 : mfixpoint term) (id : nat) (π : stack) -| Case_p (indn : inductive * nat) (c : term) (brs : list (nat * term)) (π : stack) -| Case (indn : inductive * nat) (p : term) (brs : list (nat * term)) (π : stack) -| Case_brs (indn : inductive * nat) (p c : term) (m : nat) (brs1 brs2 : list (nat * term)) (π : stack) -| Proj (p : projection) (π : stack) -| Prod_l (na : aname) (B : term) (π : stack) -| Prod_r (na : aname) (A : term) (π : stack) -| Lambda_ty (na : aname) (b : term) (π : stack) -| Lambda_tm (na : aname) (A : term) (π : stack) -| LetIn_bd (na : aname) (B t : term) (π : stack) -| LetIn_ty (na : aname) (b t : term) (π : stack) -| LetIn_in (na : aname) (b B : term) (π : stack) -| coApp (t : term) (π : stack). - -Notation "'ε'" := (Empty). - -Derive NoConfusion NoConfusionHom for stack. - -Instance EqDec_def {A} : EqDec A -> EqDec (def A). -Proof. - intros X x y. decide equality; apply eq_dec. -Defined. - -Instance EqDec_stack : EqDec stack. -Proof. - intros x y. decide equality; apply eq_dec. -Defined. +(* Hole in fixpoint definition *) +Variant def_hole := +| def_hole_type (dname : aname) (dbody : term) (rarg : nat) +| def_hole_body (dname : aname) (dtype : term) (rarg : nat). + +Definition mfix_hole := mfixpoint term * def_hole * mfixpoint term. + +(* Represents a context_decl with a hole in it *) +Variant context_decl_hole : Type := +| decl_hole_type (na : aname) (body : option term) +| decl_hole_body (na : aname) (type : term). + +(* Represents a context with a hole in it *) +Definition context_hole := context * context_decl_hole * context. + +Variant predicate_hole := +| pred_hole_params + (params1 params2 : list term) + (puinst : Instance.t) + (pcontext : context) + (preturn : term) +| pred_hole_context + (pparams : list term) + (puinst : Instance.t) + (pcontext : context_hole) + (preturn : term) +| pred_hole_return + (pparams : list term) + (puinst : Instance.t) + (pcontext : context). + +Variant branch_hole := +| branch_hole_context (bcontext : context_hole) (bbody : term) +| branch_hole_body (bcontext : context). + +Definition branches_hole := list (branch term) * branch_hole * list (branch term). + +(* Represents a non-nested term with a hole in it *) +Variant stack_entry : Type := +| App_l (v : term) (* Hole in head *) +| App_r (u : term) (* Hole in arg *) +| Fix_app (* Hole in last arg *) + (mfix : mfixpoint term) (idx : nat) (args : list term) +| Fix (mfix : mfix_hole) (idx : nat) +| CoFix_app (* Hole in last arg *) + (mfix : mfixpoint term) (idx : nat) (args : list term) +| CoFix (mfix : mfix_hole) (idx : nat) +| Case_pred (* Hole in predicate *) + (ci : case_info) + (p : predicate_hole) + (c : term) + (brs : list (branch term)) +| Case_discr (* Hole in scrutinee *) + (ci : case_info) + (p : predicate term) + (brs : list (branch term)) +| Case_branch (* Hole in branch *) + (ci : case_info) + (p : predicate term) + (c : term) + (brs : branches_hole) +| Proj (* Hole in projectee *) + (p : projection) +| Prod_l (na : aname) (B : term) +| Prod_r (na : aname) (A : term) +| Lambda_ty (na : aname) (b : term) +| Lambda_bd (na : aname) (A : term) +| LetIn_bd (na : aname) (B t : term) +| LetIn_ty (na : aname) (b t : term) +| LetIn_in (na : aname) (b B : term). + +Definition stack := list stack_entry. + +Derive NoConfusion for def_hole context_decl_hole predicate_hole branch_hole stack_entry. + +Instance EqDec_def_hole : EqDec def_hole. +Proof. intros ? ?; decide equality; apply eq_dec. Defined. + +Instance EqDec_context_decl_hole : EqDec context_decl_hole. +Proof. intros ? ?; decide equality; apply eq_dec. Defined. + +Instance EqDec_predicate_hole : EqDec predicate_hole. +Proof. intros ? ?; decide equality; apply eq_dec. Defined. + +Instance EqDec_branch_hole : EqDec branch_hole. +Proof. intros ? ?; decide equality; apply eq_dec. Defined. + +Instance EqDec_stack_entry : EqDec stack_entry. +Proof. intros ? ?; decide equality; apply eq_dec. Defined. Instance reflect_stack : ReflectEq stack := let h := EqDec_ReflectEq stack in _. -Fixpoint zipc t 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 => + {| dname := dname; + dtype := t; + dbody := dbody; + rarg := rarg |} + | def_hole_body dname dtype rarg => + {| dname := dname; + dtype := dtype; + dbody := t; + rarg := rarg |} + end in + mfix1 ++ (def :: mfix2). + +Definition fill_context_hole '((ctx1, decl, ctx2) : context_hole) (t : term) : context := + let decl := + match decl with + | decl_hole_type na body => + {| decl_name := na; decl_body := body; decl_type := t |} + | decl_hole_body na type => {| decl_name := na; decl_body := Some t; decl_type := type |} + end in + ctx1 ,,, [decl] ,,, ctx2. + +Definition fill_predicate_hole (p : predicate_hole) (t : term) : predicate term := + match p with + | pred_hole_params params1 params2 puinst pcontext preturn => + {| pparams := params1 ++ (t :: params2); + puinst := puinst; + pcontext := pcontext; + preturn := preturn |} + | pred_hole_context pparams puinst pcontext preturn => + {| pparams := pparams; + puinst := puinst; + pcontext := fill_context_hole pcontext t; + preturn := preturn |} + | pred_hole_return pparams puinst pcontext => + {| pparams := pparams; + puinst := puinst; + pcontext := pcontext; + preturn := t |} + end. + +Definition fill_branches_hole '((brs1, br, brs2) : branches_hole) (t : term) : list (branch term) := + let br := + match br with + | branch_hole_context bcontext bbody => + {| bcontext := fill_context_hole bcontext t; bbody := bbody |} + | branch_hole_body bcontext => + {| bcontext := bcontext; bbody := t |} + end in + brs1 ++ (br :: brs2). + +Definition fill_hole (t : term) (se : stack_entry) : term := + match se with + | App_l v => tApp t v + | App_r u => tApp u t + | Fix_app mfix idx args => tApp (mkApps (tFix mfix idx) args) t + | Fix mfix idx => tFix (fill_mfix_hole mfix t) idx + | CoFix_app mfix idx args => tApp (mkApps (tCoFix mfix idx) args) t + | CoFix mfix idx => tCoFix (fill_mfix_hole mfix t) idx + | Case_pred ci p c brs => tCase ci (fill_predicate_hole p t) c brs + | Case_discr ci p brs => tCase ci p t brs + | Case_branch ci p c brs => tCase ci p c (fill_branches_hole brs t) + | Proj p => tProj p t + | Prod_l na B => tProd na t B + | Prod_r na A => tProd na A t + | Lambda_ty na b => tLambda na t b + | Lambda_bd na A => tLambda na A t + | LetIn_bd na B u => tLetIn na t B u + | LetIn_ty na b u => tLetIn na b t u + | LetIn_in na b B => tLetIn na b B t + end. + +(* Not using fold_left here to get the right unfolding behavior *) +Fixpoint zipc (t : term) (stack : stack) : term := match stack with - | ε => t - | App u π => zipc (tApp t u) π - | Fix f n args π => zipc (tApp (mkApps (tFix f n) args) t) π - | Fix_mfix_ty na bo ra mfix1 mfix2 idx π => - zipc (tFix (mfix1 ++ mkdef _ na t bo ra :: mfix2) idx) π - | Fix_mfix_bd na ty ra mfix1 mfix2 idx π => - zipc (tFix (mfix1 ++ mkdef _ na ty t ra :: mfix2) idx) π - | CoFix f n args π => zipc (tApp (mkApps (tCoFix f n) args) t) π - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx π => - zipc (tCoFix (mfix1 ++ mkdef _ na t bo ra :: mfix2) idx) π - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx π => - zipc (tCoFix (mfix1 ++ mkdef _ na ty t ra :: mfix2) idx) π - | Case_p indn c brs π => zipc (tCase indn t c brs) π - | Case indn pred brs π => zipc (tCase indn pred t brs) π - | Case_brs indn pred c m brs1 brs2 π => - zipc (tCase indn pred c (brs1 ++ (m,t) :: brs2)) π - | Proj p π => zipc (tProj p t) π - | Prod_l na B π => zipc (tProd na t B) π - | Prod_r na A π => zipc (tProd na A t) π - | Lambda_ty na b π => zipc (tLambda na t b) π - | Lambda_tm na A π => zipc (tLambda na A t) π - | LetIn_bd na B u π => zipc (tLetIn na t B u) π - | LetIn_ty na b u π => zipc (tLetIn na b t u) π - | LetIn_in na b B π => zipc (tLetIn na b B t) π - | coApp u π => zipc (tApp u t) π + | [] => t + | se :: stack => zipc (fill_hole t se) stack end. -Definition zip (t : term * stack) := zipc (fst t) (snd t). +Definition zip (t : term * stack) : term := zipc (fst t) (snd t). Tactic Notation "zip" "fold" "in" hyp(h) := lazymatch type of h with @@ -871,18 +1206,15 @@ Tactic Notation "zip" "fold" := (* TODO Tail-rec version *) (* Get the arguments out of a stack *) -Fixpoint decompose_stack π := +Fixpoint decompose_stack (π : stack) : list term × stack := match π with - | App u π => let '(l,π) := decompose_stack π in (u :: l, π) + | App_l u :: π => let '(l,π) := decompose_stack π in (u :: l, π) | _ => ([], π) end. (* TODO Tail-rec *) -Fixpoint appstack l π := - match l with - | u :: l => App u (appstack l π) - | [] => π - end. +Definition appstack (l : list term) (π : stack) : stack := + map App_l l ++ π. Lemma decompose_stack_eq : forall π l ρ, @@ -891,25 +1223,25 @@ Lemma decompose_stack_eq : Proof. intros π l ρ eq. revert l ρ eq. induction π ; intros l ρ eq. - all: try solve [ cbn in eq ; inversion eq ; subst ; reflexivity ]. - destruct l. - - cbn in eq. revert eq. case_eq (decompose_stack π). - intros. inversion eq. - - cbn in eq. revert eq. case_eq (decompose_stack π). - intros l0 s H0 eq. inversion eq. subst. - cbn. f_equal. eapply IHπ. assumption. + - noconf eq; auto. + - cbn in *. + destruct decompose_stack. + destruct a; noconf eq; cbn in *; auto. + f_equal. + eauto. Qed. Lemma decompose_stack_not_app : forall π l u ρ, - decompose_stack π = (l, App u ρ) -> False. + decompose_stack π = (l, App_l u :: ρ) -> False. Proof. intros π l u ρ eq. revert u l ρ eq. induction π ; intros u l ρ eq. - all: try solve [ cbn in eq ; inversion eq ]. - cbn in eq. revert eq. case_eq (decompose_stack π). - intros l0 s H0 eq. inversion eq. subst. - eapply IHπ. eassumption. + - noconf eq. + - cbn in eq. + destruct decompose_stack. + destruct a; noconf eq; cbn in *; auto. + eauto. Qed. Lemma zipc_appstack : @@ -918,7 +1250,7 @@ Lemma zipc_appstack : Proof. intros t args ρ. revert t ρ. induction args ; intros t ρ. - cbn. reflexivity. - - cbn. rewrite IHargs. reflexivity. + - cbn. apply IHargs. Qed. Lemma decompose_stack_appstack : @@ -933,7 +1265,7 @@ Qed. Fixpoint decompose_stack_at π n : option (list term * term * stack) := match π with - | App u π => + | App_l u :: π => match n with | 0 => ret ([], u, π) | S n => @@ -947,21 +1279,21 @@ Fixpoint decompose_stack_at π n : option (list term * term * stack) := Lemma decompose_stack_at_eq : forall π n l u ρ, decompose_stack_at π n = Some (l,u,ρ) -> - π = appstack l (App u ρ). + π = appstack l (App_l u :: ρ). Proof. intros π n l u ρ h. induction π in n, l, u, ρ, h |- *. - all: try solve [ cbn in h ; discriminate ]. - destruct n. - - cbn in h. inversion h. subst. - cbn. reflexivity. - - cbn in h. revert h. - case_eq (decompose_stack_at π n). - + intros [[l' v] ρ'] e1 e2. - inversion e2. subst. clear e2. - specialize IHπ with (1 := e1). subst. - cbn. reflexivity. - + intros H0 h. discriminate. + - noconf h. + - cbn in h. + destruct n as [|n]. + + destruct a; noconf h; auto. + + specialize (IHπ n). + destruct decompose_stack_at. + * destruct p as ((?&?)&?). + destruct a; noconf h. + cbn. + f_equal; eauto. + * destruct a; noconf h. Qed. Lemma decompose_stack_at_length : @@ -971,16 +1303,17 @@ Lemma decompose_stack_at_length : Proof. intros π n l u ρ h. induction π in n, l, u, ρ, h |- *. - all: try solve [ cbn in h ; discriminate ]. - destruct n. - - cbn in h. inversion h. reflexivity. - - cbn in h. revert h. - case_eq (decompose_stack_at π n). - + intros [[l' v] ρ'] e1 e2. - inversion e2. subst. clear e2. - specialize IHπ with (1 := e1). subst. - cbn. reflexivity. - + intros H0 h. discriminate. + - noconf h. + - cbn in h. + destruct n as [|n]. + + destruct a; noconf h; auto. + + specialize (IHπ n). + destruct decompose_stack_at. + * destruct p as ((?&?)&?). + destruct a; noconf h. + cbn. + f_equal; eauto. + * destruct a; noconf h. Qed. (* TODO Find a better place for this. *) @@ -1001,34 +1334,44 @@ Proof. intros i [na ty bo ra]. simpl. reflexivity. Qed. -Fixpoint stack_context π : context := - match π with - | ε => [] - | App u π => stack_context π - | Fix f n args π => stack_context π - | Fix_mfix_ty na bo ra mfix1 mfix2 idx π => stack_context π - | Fix_mfix_bd na ty ra mfix1 mfix2 idx π => - stack_context π ,,, - fix_context_alt (map def_sig mfix1 ++ (na,ty) :: map def_sig mfix2) - | CoFix f n args π => stack_context π - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx π => stack_context π - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx π => - stack_context π ,,, - fix_context_alt (map def_sig mfix1 ++ (na,ty) :: map def_sig mfix2) - | Case_p indn c brs π => stack_context π - | Case indn pred brs π => stack_context π - | Case_brs indn pred c m brs1 brs2 π => stack_context π - | Proj p π => stack_context π - | Prod_l na B π => stack_context π - | Prod_r na A π => stack_context π ,, vass na A - | Lambda_ty na u π => stack_context π - | Lambda_tm na A π => stack_context π ,, vass na A - | LetIn_bd na B u π => stack_context π - | LetIn_ty na b u π => stack_context π - | LetIn_in na b B π => stack_context π ,, vdef na b B - | coApp u π => stack_context π +Definition mfix_hole_context '((mfix1, def, mfix2) : mfix_hole) : context := + match def with + | def_hole_type _ _ _ => [] + | def_hole_body na ty _ => + fix_context_alt (map def_sig mfix1 ++ (na, ty) :: map def_sig mfix2) + end. + +Definition context_hole_context '((ctx1, decl, ctx2) : context_hole) : context := + ctx1. + +Definition predicate_hole_context (p : predicate_hole) : context := + match p with + | pred_hole_params _ _ _ _ _ => [] + | pred_hole_context _ _ pcontext _ => context_hole_context pcontext + | pred_hole_return pparams puinst pcontext => pcontext + end. + +Definition branches_hole_context '((brs1, br, brs2) : branches_hole) : context := + match br with + | branch_hole_context bcontext bbody => context_hole_context bcontext + | branch_hole_body bcontext => bcontext end. +Definition stack_entry_context (se : stack_entry) : context := + match se with + | Fix mfix idx => mfix_hole_context mfix + | CoFix mfix idx => mfix_hole_context mfix + | Case_pred ci p c brs => predicate_hole_context p + | Case_branch ci p c brs => branches_hole_context brs + | Prod_r na A => [vass na A] + | Lambda_bd na A => [vass na A] + | LetIn_in na b B => [vdef na b B] + | _ => [] + end. + +Definition stack_context : stack -> context := + flat_map stack_entry_context. + Lemma stack_context_appstack : forall {π args}, stack_context (appstack args π) = stack_context π. @@ -1039,185 +1382,182 @@ Proof. - simpl. apply IHargs. Qed. -Fixpoint stack_position π : position := - match π with - | ε => [] - | App u ρ => stack_position ρ ++ [ app_l ] - | Fix f n args ρ => stack_position ρ ++ [ app_r ] - | Fix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - stack_position ρ ++ [ fix_mfix_ty #|mfix1| ] - | Fix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - stack_position ρ ++ [ fix_mfix_bd #|mfix1| ] - | CoFix f n args ρ => stack_position ρ ++ [ app_r ] - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - stack_position ρ ++ [ cofix_mfix_ty #|mfix1| ] - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - stack_position ρ ++ [ cofix_mfix_bd #|mfix1| ] - | Case_p indn c brs ρ => stack_position ρ ++ [ case_p ] - | Case indn pred brs ρ => stack_position ρ ++ [ case_c ] - | Case_brs indn pred c m brs1 brs2 ρ => - stack_position ρ ++ [ case_brs #|brs1| ] - | Proj pr ρ => stack_position ρ ++ [ proj_c ] - | Prod_l na B ρ => stack_position ρ ++ [ prod_l ] - | Prod_r na A ρ => stack_position ρ ++ [ prod_r ] - | Lambda_ty na u ρ => stack_position ρ ++ [ lam_ty ] - | Lambda_tm na A ρ => stack_position ρ ++ [ lam_tm ] - | LetIn_bd na B u ρ => stack_position ρ ++ [ let_bd ] - | LetIn_ty na b u ρ => stack_position ρ ++ [ let_ty ] - | LetIn_in na b B ρ => stack_position ρ ++ [ let_in ] - | coApp u ρ => stack_position ρ ++ [ app_r ] +Definition context_hole_choice '((ctx1, decl, ctx2) : context_hole) : context_choice := + let decl := + match decl with + | decl_hole_type _ _ => choose_decl_type + | decl_hole_body _ _ => choose_decl_body + end in + (#|ctx2|, decl). + +Definition stack_entry_choice (se : stack_entry) : choice := + match se with + | App_l v => app_l + | App_r u => app_r + | Fix_app mfix idx args => app_r + | Fix (mfix1, def_hole_type _ _ _, _) idx => fix_mfix_ty #|mfix1| + | Fix (mfix1, def_hole_body _ _ _, _) idx => fix_mfix_bd #|mfix1| + | CoFix_app mfix idx args => app_r + | CoFix (mfix1, def_hole_type _ _ _, _) idx => cofix_mfix_ty #|mfix1| + | CoFix (mfix1, def_hole_body _ _ _, _) idx => cofix_mfix_bd #|mfix1| + | Case_pred ci (pred_hole_params pars1 _ _ _ _) c brs => case_par #|pars1| + | Case_pred ci (pred_hole_context _ _ ctx _) c brs => case_pctx (context_hole_choice ctx) + | Case_pred ci (pred_hole_return _ _ _) c brs => case_preturn + | Case_discr ci p brs => case_c + | Case_branch ci p c (brs1, branch_hole_context ctx _, brs2) => + case_brsctx #|brs1| (context_hole_choice ctx) + | Case_branch ci p c (brs1, branch_hole_body _, brs2) => case_brsbody #|brs1| + | Proj p => proj_c + | Prod_l na B => prod_l + | Prod_r na A => prod_r + | Lambda_ty na b => lam_ty + | Lambda_bd na A => lam_tm + | LetIn_bd na B t => let_bd + | LetIn_ty na b t => let_ty + | LetIn_in na b B => let_in end. +Definition stack_position : stack -> position := + rev_map stack_entry_choice. + +Lemma stack_position_cons se π : + stack_position (se :: π) = + stack_position π ++ [stack_entry_choice se]. +Proof. + unfold stack_position. + rewrite rev_map_cons; auto. +Qed. + Lemma stack_position_atpos : forall t π, atpos (zipc t π) (stack_position π) = t. Proof. - intros t π. revert t. induction π ; intros u. - all: try solve [ cbn ; rewrite ?poscat_atpos, ?IHπ ; reflexivity ]. - - cbn. rewrite poscat_atpos. rewrite IHπ. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. rewrite poscat_atpos. rewrite IHπ. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. rewrite poscat_atpos. rewrite IHπ. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. rewrite poscat_atpos. rewrite IHπ. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. rewrite poscat_atpos. rewrite IHπ. - cbn. rewrite nth_error_app_ge by lia. - replace (#|brs1| - #|brs1|) with 0 by lia. simpl. - reflexivity. + intros t π. revert t. induction π ; intros u; auto. + rewrite stack_position_cons. + cbn. + rewrite poscat_atpos. + rewrite IHπ. + destruct a; cbn; auto. + - destruct mfix as ((?&?)&?). + destruct d; cbn. + all: rewrite nth_error_snoc; auto. + - destruct mfix as ((?&?)&?). + destruct d; cbn. + all: rewrite nth_error_snoc; auto. + - destruct p; cbn; auto. + + rewrite nth_error_snoc; auto. + + destruct pcontext as ((?&[])&?); cbn. + all: rewrite nth_error_snoc; auto. + - destruct brs as ((?&[])&?); cbn. + all: rewrite nth_error_snoc; auto. + destruct bcontext as ((?&[])&?); cbn. + all: rewrite nth_error_snoc; auto. Qed. Lemma stack_position_valid : forall t π, validpos (zipc t π) (stack_position π). Proof. - intros t π. revert t. induction π ; intros u. - all: try solve [ - cbn ; eapply poscat_valid ; [ - eapply IHπ - | rewrite stack_position_atpos ; reflexivity - ] - ]. - - reflexivity. - - cbn. eapply poscat_valid. - + eapply IHπ. - + rewrite stack_position_atpos. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. eapply poscat_valid. - + eapply IHπ. - + rewrite stack_position_atpos. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. eapply poscat_valid. - + eapply IHπ. - + rewrite stack_position_atpos. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. eapply poscat_valid. - + eapply IHπ. - + rewrite stack_position_atpos. - cbn. rewrite nth_error_app_ge by lia. - replace (#|mfix1| - #|mfix1|) with 0 by lia. simpl. - reflexivity. - - cbn. eapply poscat_valid. - + eapply IHπ. - + rewrite stack_position_atpos. - cbn. rewrite nth_error_app_ge by lia. - replace (#|brs1| - #|brs1|) with 0 by lia. simpl. - reflexivity. + intros t π. revert t. induction π ; intros u; auto. + rewrite stack_position_cons. + cbn. + apply poscat_valid; eauto. + rewrite stack_position_atpos. + destruct a; cbn; auto. + - destruct mfix as ((?&?)&?), d. + all: rewrite nth_error_snoc; auto. + - destruct mfix as ((?&?)&?), d. + all: rewrite nth_error_snoc; auto. + - destruct p; cbn; auto. + + rewrite nth_error_snoc; auto. + + destruct pcontext as ((?&[])&?); cbn. + all: rewrite nth_error_snoc; auto. + - destruct brs as ((?&[])&?); cbn. + all: rewrite nth_error_snoc; auto. + destruct bcontext as ((?&[])&?); cbn. + all: rewrite nth_error_snoc; auto. Qed. -Definition stack_pos t π : pos (zipc t π) := +Definition stack_pos (t : term) (π : stack) : pos (zipc t π) := exist (stack_position π) (stack_position_valid t π). -Fixpoint list_make {A} n x : list A := - match n with - | 0 => [] - | S n => x :: list_make n x - end. +(* TODO: Move *) +Lemma map_const {X Y} (y : Y) (l : list X) : + map (fun _ => y) l = repeat y #|l|. +Proof. + induction l; cbn; auto. + f_equal; auto. +Qed. -Lemma list_make_app_r : - forall A n (x : A), - x :: list_make n x = list_make n x ++ [x]. +Lemma repeat_snoc {A} (a : A) n : + repeat a (S n) = repeat a n ++ [a]. Proof. - intros A n x. revert x. - induction n ; intro x. - - reflexivity. - - cbn. rewrite IHn. reflexivity. + induction n; auto. + cbn. + f_equal; auto. +Qed. + +Lemma rev_repeat {A} (a : A) n : + List.rev (repeat a n) = repeat a n. +Proof. + induction n; auto. + rewrite repeat_snoc at 1. + rewrite rev_app_distr; cbn. + f_equal; auto. Qed. Lemma stack_position_appstack : forall args ρ, stack_position (appstack args ρ) = - stack_position ρ ++ list_make #|args| app_l. + stack_position ρ ++ repeat app_l #|args|. Proof. - intros args ρ. revert ρ. - induction args as [| u args ih ] ; intros ρ. - - cbn. rewrite app_nil_r. reflexivity. - - cbn. rewrite ih. rewrite <- app_assoc. - rewrite list_make_app_r. reflexivity. + intros args ρ. + unfold stack_position, appstack. + rewrite rev_map_app. + f_equal. + rewrite rev_map_spec, map_map. + cbn. + rewrite map_const, rev_repeat; auto. 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'. + Proof. + intros eq. + destruct c as ((?&[])&?); cbn in *. + all: apply app_inj_length_l in eq as (_&eq); noconf eq; auto. + Qed. Lemma zipc_inj : forall u v π, zipc u π = zipc v π -> u = v. Proof. intros u v π e. revert u v e. - induction π ; intros u v e. - all: try solve [ cbn in e ; apply IHπ in e ; inversion e ; reflexivity ]. - - cbn in e. assumption. - - apply IHπ in e. - assert (em : - mfix1 ++ mkdef _ na u bo ra :: mfix2 = - mfix1 ++ mkdef _ na v bo ra :: mfix2 - ). - { inversion e. reflexivity. } - apply app_inv_head in em. inversion em. reflexivity. - - apply IHπ in e. - assert (em : - mfix1 ++ mkdef _ na ty u ra :: mfix2 = - mfix1 ++ mkdef _ na ty v ra :: mfix2 - ). - { inversion e. reflexivity. } - apply app_inv_head in em. inversion em. reflexivity. - - apply IHπ in e. - assert (em : - mfix1 ++ mkdef _ na u bo ra :: mfix2 = - mfix1 ++ mkdef _ na v bo ra :: mfix2 - ). - { inversion e. reflexivity. } - apply app_inv_head in em. inversion em. reflexivity. - - apply IHπ in e. - assert (em : - mfix1 ++ mkdef _ na ty u ra :: mfix2 = - mfix1 ++ mkdef _ na ty v ra :: mfix2 - ). - { inversion e. reflexivity. } - apply app_inv_head in em. inversion em. reflexivity. - - apply IHπ in e. - assert (eb : brs1 ++ (m, u) :: brs2 = brs1 ++ (m, v) :: brs2). - { inversion e. reflexivity. } - apply app_inv_head in eb. inversion eb. reflexivity. + induction π ; intros u v e; auto. + cbn in e. + apply IHπ in e. + destruct a; cbn in e; noconf e; auto. + - destruct mfix as ((?&[])&?); cbn in *. + all: apply app_inj_length_l in H0 as (_&H0); auto. + all: noconf H0; auto. + - destruct mfix as ((?&[])&?); cbn in *. + all: apply app_inj_length_l in H0 as (_&H0); auto. + all: noconf H0; auto. + - destruct p; cbn in *; noconf H0; auto. + + apply app_inj_length_l in H0 as (_&H0); auto. + noconf H0; auto. + + apply fill_context_hole_inj in H0; auto. + - destruct brs as ((?&[])&?); cbn in *. + + apply app_inj_length_l in H0 as (_&H0); auto; noconf H0. + apply fill_context_hole_inj in H0; auto. + + apply app_inj_length_l in H0 as (_&H0); noconf H0; auto. Qed. - Definition isStackApp π := + Definition isStackApp (π : stack) : bool := match π with - | App _ _ => true + | App_l _ :: _ => true | _ => false end. @@ -1235,7 +1575,7 @@ Section Stacks. Definition zipx (Γ : context) (t : term) (π : stack) : term := it_mkLambda_or_LetIn Γ (zipc t π). - Fixpoint context_position Γ : position := + Fixpoint context_position (Γ : context) : position := match Γ with | [] => [] | {| decl_name := na ; decl_body := None ; decl_type := A |} :: Γ => @@ -1284,7 +1624,7 @@ Section Stacks. assumption. Qed. - Definition xposition Γ π : position := + Definition xposition (Γ : context) (π : stack) : position := context_position Γ ++ stack_position π. Lemma xposition_atpos : @@ -1316,7 +1656,7 @@ Section Stacks. eassumption. Qed. - Definition xpos Γ t π : pos (zipx Γ t π) := + Definition xpos (Γ : context) (t : term) (π : stack) : pos (zipx Γ t π) := exist (xposition Γ π) (xposition_valid Γ t π). Lemma positionR_stack_pos_xpos : @@ -1329,45 +1669,13 @@ Section Stacks. eapply positionR_poscat. assumption. Qed. - Definition zipp t π := + Definition zipp (t : term) (π : stack) : term := let '(args, ρ) := decompose_stack π in mkApps t args. - (* Maybe a stack should be a list! *) - Fixpoint stack_cat (ρ θ : stack) : stack := - match ρ with - | ε => θ - | App u ρ => App u (stack_cat ρ θ) - | Fix f n args ρ => Fix f n args (stack_cat ρ θ) - | Fix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - Fix_mfix_ty na bo ra mfix1 mfix2 idx (stack_cat ρ θ) - | Fix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - Fix_mfix_bd na ty ra mfix1 mfix2 idx (stack_cat ρ θ) - | CoFix f n args ρ => CoFix f n args (stack_cat ρ θ) - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - CoFix_mfix_ty na bo ra mfix1 mfix2 idx (stack_cat ρ θ) - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - CoFix_mfix_bd na ty ra mfix1 mfix2 idx (stack_cat ρ θ) - | Case_p indn c brs ρ => Case_p indn c brs (stack_cat ρ θ) - | Case indn p brs ρ => Case indn p brs (stack_cat ρ θ) - | Case_brs indn p c m brs1 brs2 ρ => - Case_brs indn p c m brs1 brs2 (stack_cat ρ θ) - | Proj p ρ => Proj p (stack_cat ρ θ) - | Prod_l na B ρ => Prod_l na B (stack_cat ρ θ) - | Prod_r na A ρ => Prod_r na A (stack_cat ρ θ) - | Lambda_ty na u ρ => Lambda_ty na u (stack_cat ρ θ) - | Lambda_tm na A ρ => Lambda_tm na A (stack_cat ρ θ) - | LetIn_bd na B u ρ => LetIn_bd na B u (stack_cat ρ θ) - | LetIn_ty na b u ρ => LetIn_ty na b u (stack_cat ρ θ) - | LetIn_in na b B ρ => LetIn_in na b B (stack_cat ρ θ) - | coApp u ρ => coApp u (stack_cat ρ θ) - end. - - Notation "ρ +++ θ" := (stack_cat ρ θ) (at level 20). - Lemma stack_cat_appstack : forall args ρ, - appstack args ε +++ ρ = appstack args ρ. + appstack args [] ++ ρ = appstack args ρ. Proof. intros args ρ. revert ρ. induction args ; intros ρ. @@ -1375,176 +1683,6 @@ Section Stacks. - simpl. rewrite IHargs. reflexivity. Qed. - Lemma stack_cat_nil_r : - forall π, - π +++ ε = π. - Proof. - intro π. - induction π. - all: simpl. - all: rewrite ?IHπ. - all: reflexivity. - Qed. - - Lemma stack_cat_assoc : - forall π ρ θ, - (π +++ ρ) +++ θ = π +++ (ρ +++ θ). - Proof. - intros π ρ θ. - induction π in ρ, θ |- *. - all: simpl. - all: rewrite ?IHπ. - all: reflexivity. - Qed. - - Fixpoint rev_stack π := - match π with - | ε => ε - | App u ρ => rev_stack ρ +++ App u ε - | Fix f n args ρ => rev_stack ρ +++ Fix f n args ε - | Fix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - rev_stack ρ +++ Fix_mfix_ty na bo ra mfix1 mfix2 idx ε - | Fix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - rev_stack ρ +++ Fix_mfix_bd na ty ra mfix1 mfix2 idx ε - | CoFix f n args ρ => rev_stack ρ +++ CoFix f n args ε - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx ρ => - rev_stack ρ +++ CoFix_mfix_ty na bo ra mfix1 mfix2 idx ε - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx ρ => - rev_stack ρ +++ CoFix_mfix_bd na ty ra mfix1 mfix2 idx ε - | Case_p indn c brs ρ => rev_stack ρ +++ Case_p indn c brs ε - | Case indn p brs ρ => rev_stack ρ +++ Case indn p brs ε - | Case_brs indn p c m brs1 brs2 ρ => - rev_stack ρ +++ Case_brs indn p c m brs1 brs2 ε - | Proj p ρ => rev_stack ρ +++ Proj p ε - | Prod_l na B ρ => rev_stack ρ +++ Prod_l na B ε - | Prod_r na A ρ => rev_stack ρ +++ Prod_r na A ε - | Lambda_ty na u ρ => rev_stack ρ +++ Lambda_ty na u ε - | Lambda_tm na A ρ => rev_stack ρ +++ Lambda_tm na A ε - | LetIn_bd na B u ρ => rev_stack ρ +++ LetIn_bd na B u ε - | LetIn_ty na b u ρ => rev_stack ρ +++ LetIn_ty na b u ε - | LetIn_in na b B ρ => rev_stack ρ +++ LetIn_in na b B ε - | coApp u ρ => rev_stack ρ +++ coApp u ε - end. - - Lemma rev_stack_app : - forall π ρ, - rev_stack (π +++ ρ) = rev_stack ρ +++ rev_stack π. - Proof. - intros π ρ. - induction π in ρ |- *. - all: simpl. - 1:{ rewrite stack_cat_nil_r. reflexivity. } - all: rewrite IHπ. - all: rewrite stack_cat_assoc. - all: reflexivity. - Qed. - - Lemma rev_stack_invol : - forall π, - rev_stack (rev_stack π) = π. - Proof. - intro π. - induction π. - all: simpl. - 1: reflexivity. - all: rewrite rev_stack_app. - all: rewrite IHπ. - all: reflexivity. - Qed. - - (* Induction principle for stacks, in reverse order *) - Lemma stack_rev_rect : - forall (P : stack -> Type), - P ε -> - (forall t π, - P π -> - P (π +++ App t ε) - ) -> - (forall mfix idx args π, - P π -> - P (π +++ Fix mfix idx args ε) - ) -> - (forall na bo ra mfix1 mfix2 id π, - P π -> - P (π +++ Fix_mfix_ty na bo ra mfix1 mfix2 id ε) - ) -> - (forall na ty ra mfix1 mfix2 id π, - P π -> - P (π +++ Fix_mfix_bd na ty ra mfix1 mfix2 id ε) - ) -> - (forall mfix idx args π, - P π -> - P (π +++ CoFix mfix idx args ε) - ) -> - (forall na bo ra mfix1 mfix2 id π, - P π -> - P (π +++ CoFix_mfix_ty na bo ra mfix1 mfix2 id ε) - ) -> - (forall na ty ra mfix1 mfix2 id π, - P π -> - P (π +++ CoFix_mfix_bd na ty ra mfix1 mfix2 id ε) - ) -> - (forall indn c brs π, - P π -> - P (π +++ Case_p indn c brs ε) - ) -> - (forall indn p brs π, - P π -> - P (π +++ Case indn p brs ε) - ) -> - (forall indn p c m brs1 brs2 π, - P π -> - P (π +++ Case_brs indn p c m brs1 brs2 ε) - ) -> - (forall p π, - P π -> - P (π +++ Proj p ε) - ) -> - (forall na B π, - P π -> - P (π +++ Prod_l na B ε) - ) -> - (forall na A π, - P π -> - P (π +++ Prod_r na A ε) - ) -> - (forall na b π, - P π -> - P (π +++ Lambda_ty na b ε) - ) -> - (forall na A π, - P π -> - P (π +++ Lambda_tm na A ε) - ) -> - (forall na B t π, - P π -> - P (π +++ LetIn_bd na B t ε) - ) -> - (forall na b t π, - P π -> - P (π +++ LetIn_ty na b t ε) - ) -> - (forall na b B π, - P π -> - P (π +++ LetIn_in na b B ε) - ) -> - (forall t π, - P π -> - P (π +++ coApp t ε) - ) -> - forall π, P π. - Proof. - intros P hε hApp hFix hFixty hFixbd hCoFix hCoFixty hCoFixbd hCasep hCase - hCasebrs hProj hProdl hProdr hLamty hLamtm hLetbd hLetty hLetin hcoApp. - assert (h : forall π, P (rev_stack π)). - { intro π. induction π. - all: eauto. - } - intro π. - rewrite <- rev_stack_invol. - apply h. - Qed. - Lemma decompose_stack_twice : forall π args ρ, decompose_stack π = (args, ρ) -> @@ -1564,44 +1702,33 @@ Section Stacks. Lemma zipc_stack_cat : forall t π ρ, - zipc t (π +++ ρ) = zipc (zipc t π) ρ. + zipc t (π ++ ρ) = zipc (zipc t π) ρ. Proof. intros t π ρ. revert t ρ. - induction π ; intros u ρ. - all: (simpl ; rewrite ?IHπ ; reflexivity). - Qed. - - Lemma stack_cat_empty : - forall ρ, ρ +++ ε = ρ. - Proof. - intros ρ. induction ρ. - all: (simpl ; rewrite ?IHρ ; reflexivity). + induction π ; intros u ρ; auto. + simpl. + rewrite IHπ; auto. Qed. Lemma stack_position_stack_cat : forall π ρ, - stack_position (ρ +++ π) = + stack_position (ρ ++ π) = stack_position π ++ stack_position ρ. Proof. - intros π ρ. revert π. - induction ρ ; intros π. - all: try (simpl ; rewrite IHρ ; rewrite app_assoc ; reflexivity). - simpl. rewrite app_nil_r. reflexivity. + intros π ρ. apply rev_map_app. Qed. Lemma stack_context_stack_cat : forall π ρ, - stack_context (ρ +++ π) = stack_context π ,,, stack_context ρ. + stack_context (ρ ++ π) = stack_context π ,,, stack_context ρ. Proof. - intros π ρ. revert π. induction ρ ; intros π. - all: try (cbn ; rewrite ?IHρ ; reflexivity). - - cbn. rewrite IHρ. unfold ",,,". - rewrite app_assoc. reflexivity. - - cbn. rewrite IHρ. unfold ",,,". - rewrite app_assoc. reflexivity. + intros π ρ. + unfold stack_context. + rewrite !flat_map_concat_map. + rewrite map_app, concat_app; auto. Qed. - Definition zippx t π := + Definition zippx (t : term) (π : stack) : term := let '(args, ρ) := decompose_stack π in it_mkLambda_or_LetIn (stack_context ρ) (mkApps t args). @@ -1611,8 +1738,6 @@ Section Stacks. End Stacks. -Notation "ρ +++ θ" := (stack_cat ρ θ) (at level 20). - (* Context closure *) Definition context_clos (R : term -> term -> Type) u v := ∑ u' v' π, diff --git a/pcuic/theories/PCUICPretty.v b/pcuic/theories/PCUICPretty.v index 408b3f8ab..6a4ab8d70 100644 --- a/pcuic/theories/PCUICPretty.v +++ b/pcuic/theories/PCUICPretty.v @@ -21,10 +21,6 @@ End lookups. Section print_term. Context (Σ : global_env_ext). - Definition print_defs (print_term : context -> bool -> bool -> term -> string) Γ (defs : mfixpoint term) := - let ctx' := fix_context defs in - print_list (print_def (print_term Γ true false) (print_term (ctx' ++ Γ) true false)) (nl ^ " with ") defs. - Fixpoint decompose_lam (t : term) (n : nat) : (list aname) * (list term) * term := match n with | 0 => ([], [], t) @@ -37,13 +33,8 @@ Section print_term. end end. - Definition is_fresh (Γ : context) (id : ident) := - List.forallb - (fun decl => - match decl.(decl_name).(binder_name) with - | nNamed id' => negb (ident_eq id id') - | nAnon => true - end) Γ. + Definition is_fresh (Γ : list ident) (id : ident) := + List.forallb (fun id' => negb (ident_eq id id')) Γ. Fixpoint name_from_term (t : term) := match t with @@ -73,46 +64,122 @@ Section print_term. end in aux n. - Definition fresh_name (Γ : context) (t : term) (na : name) := + Definition fresh_name (Γ : list ident) (na : name) (t : option term) : ident := let id := match na with | nNamed id => id - | nAnon => name_from_term t + | nAnon => + match t with + | Some t => name_from_term t + | None => "_" + end end in - if is_fresh Γ id then nNamed id - else nNamed (fresh_id_from Γ 10 id). + if is_fresh Γ id then id + else fresh_id_from Γ 10 id. + + Definition rename_decl (na : aname) (decl : context_decl) : context_decl := + {| decl_name := na; + decl_type := decl_type decl; + decl_body := decl_body decl |}. - Definition fresh_aname (Γ : context) (na : aname) (t : term) := - map_binder_annot (fresh_name Γ t) na. + (* Definition build_return_context + (ind : inductive) + (oib : one_inductive_body) + (pred : predicate term) : option context := + (* Decompose the type. It will contain parameters too, but at the end, which is ok. *) + let '(Γ, _) := decompose_prod_assum [] (ind_type oib) in + (* We have to skip the first name since that's the name of the inductive binder. *) + let index_names := tl (pcontext pred) in + match hd_error (pcontext pred) with + | Some ind_binder_name => + Some ( + map (fun '(na, decl) => rename_decl na decl) + (combine (tl (pcontext pred)) Γ) + ,, + 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 + | [] => Γids + | decl :: Γ => aux (fresh_name Γids (binder_name (decl_name decl)) + (Some (decl_type decl)) :: Γids) + Γ + end in + aux Γ (MCList.rev Γ'). + + Section Aux. + Context (print_term : list ident -> bool -> bool -> term -> string). + Definition print_defs Γ (defs : mfixpoint term) := + let ctx' := fix_context defs in + print_list (print_def (print_term Γ true false) (print_term (fresh_names Γ ctx') true false)) + (nl ^ " with ") defs. + + Definition pr_context_decl Γ (c : context_decl) : ident * string := + match c with + | {| 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 ++ ")")%string) + | {| decl_name := na; decl_type := ty; decl_body := Some b |} => + let na' := (fresh_name Γ na.(binder_name) (Some ty)) in + (na', ("(" ++ na' ++ " : " ++ print_term Γ true false ty ++ " := " ++ + print_term Γ true false b ++ ")")%string) + end. + + Fixpoint print_context_gen Γ Δ := + match Δ with + | [] => (Γ, ""%string) + | d :: decls => + let '(Γ, s) := print_context_gen Γ decls in + let '(na, s') := pr_context_decl Γ d in + match decls with + | [] => (na :: Γ, (s ++ s')%string) + | _ => (na :: Γ, (s ++ " " ++ s')%string) + end + end. + + Fixpoint print_context_names Γ Δ := + match Δ with + | [] => (Γ, ""%string) + | 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 + | [] => (na :: Γ, (s ++ na)%string) + | _ => (na :: Γ, (s ++ " " ++ na)%string) + end + end. + + End Aux. + + Context (all : bool). - Fixpoint print_term (Γ : context) (top : bool) (inapp : bool) (t : term) {struct t} := + Fixpoint print_term (Γ : list ident) (top : bool)(inapp : bool) (t : term) {struct t} := match t with | tRel n => match nth_error Γ n with - | Some {| decl_name := na |} => - match na.(binder_name) with - | nAnon => "Anonymous (" ^ string_of_nat n ^ ")" - | nNamed id => id - end + | Some id => id | None => "UnboundRel(" ^ string_of_nat n ^ ")" end | tVar n => "Var(" ^ n ^ ")" | tEvar ev args => "Evar(" ^ string_of_nat ev ^ "[]" (* TODO *) ^ ")" | tSort s => string_of_sort s | tProd na dom codom => - let na' := fresh_aname Γ na dom in + let na' := fresh_name Γ na.(binder_name) (Some dom) in parens top - ("∀ " ^ string_of_aname na' ^ " : " ^ - print_term Γ true false dom ^ ", " ^ print_term (vass na' dom :: Γ) true false codom) + ("∀ " ^ na' ^ " : " ^ + print_term Γ true false dom ^ ", " ^ print_term (na':: Γ) true false codom) | tLambda na dom body => - let na' := fresh_aname Γ na dom in - parens top ("fun " ^ string_of_aname na' ^ " : " ^ print_term Γ true false dom - ^ " => " ^ print_term (vass na' dom :: Γ) true false body) + let na' := fresh_name Γ na.(binder_name) (Some dom) in + parens top ("fun " ^ na' ^ " : " ^ print_term Γ true false dom + ^ " => " ^ print_term (na':: Γ) true false body) | tLetIn na def dom body => - let na' := fresh_aname Γ na dom in - parens top ("let" ^ string_of_aname na' ^ " : " ^ print_term Γ true false dom ^ + let na' := fresh_name Γ na.(binder_name) (Some dom) in + parens top ("let" ^ na' ^ " : " ^ print_term Γ true false dom ^ " := " ^ print_term Γ true false def ^ " in " ^ nl ^ - print_term (vdef na' def dom :: Γ) true false body) + print_term (na' :: Γ) true false body) | tApp f l => parens (top || inapp) (print_term Γ false true f ^ " " ^ print_term Γ false false l) | tConst c u => string_of_kername c ^ print_universe_instance u @@ -126,7 +193,7 @@ Section print_term. match lookup_ind_decl Σ i k with | Some (_, oib) => match nth_error oib.(ind_ctors) l with - | Some (na, _, _) => na ^ print_universe_instance u + | Some cdecl => cdecl.(cstr_name) ^ print_universe_instance u | None => "UnboundConstruct(" ^ string_of_inductive ind ^ "," ^ string_of_nat l ^ "," ^ string_of_universe_instance u ^ ")" @@ -135,39 +202,35 @@ Section print_term. "UnboundConstruct(" ^ string_of_inductive ind ^ "," ^ string_of_nat l ^ "," ^ string_of_universe_instance u ^ ")" end - | tCase (mkInd mind i as ind, pars) p t brs => + | tCase {| ci_ind := mkInd mind i as ind; ci_npar := pars |} p t brs => match lookup_ind_decl Σ mind i with | Some (_, oib) => - match p with - | tLambda na _ty b => - let fix print_branch Γ arity br {struct br} := - match arity with - | 0 => "=> " ^ print_term Γ true false br - | S n => - match br with - | tLambda na A B => - let na' := fresh_aname Γ na A in - string_of_aname na' ^ " " ^ print_branch (vass na' A :: Γ) n B - | t => "=> " ^ print_term Γ true false br - end - end - in - let brs := map (fun '(arity, br) => - print_branch Γ arity br) brs in - let brs := combine brs oib.(ind_ctors) in - parens top ("match " ^ print_term Γ true false t ^ - " as " ^ string_of_aname na ^ - " in " ^ oib.(ind_name) ^ " return " ^ print_term Γ true false b ^ - " with " ^ nl ^ - print_list (fun '(b, (na, _, _)) => na ^ " " ^ b) - (nl ^ " | ") brs ^ nl ^ "end" ^ nl) - | _ => - "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_term p ^ "," ^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")" - end - | None => - "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_term p ^ "," ^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")" + let Γret := p.(pcontext) in + let Γret := fresh_names Γ Γret in + let ret_binders := firstn #|pcontext p| Γret in + let (as_name, indices) := (hd "_" ret_binders, MCList.rev (tail ret_binders)) in + let in_args := repeat "_" #|pparams p| ++ indices in + let in_str := oib.(ind_name) ^ String.concat "" (map (fun a => " " ^ a) in_args) in + + 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 ^ + " return " ^ print_term Γret true false (preturn p) ^ + " with " ^ nl ^ + print_list (fun '(b, cdecl) => cdecl.(cstr_name) ^ " " ^ b) + (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_list (pretty_string_of_branch string_of_term) brs ^ ")" end | tProj (mkInd mind i as ind, pars, k) c => match lookup_ind_decl Σ mind i with @@ -194,3 +257,53 @@ Section print_term. end. End print_term. + +Notation pr_term Σ Γ top := (print_term Σ true Γ top false). + +Notation print_context Σ := (print_context_gen Σ (print_term Σ true)). + +Definition print_one_cstr Σ Γ (mib : mutual_inductive_body) (c : constructor_body) : string := + 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) : string := + let '(Γpars, spars) := print_context Σ Γ mib.(ind_params) in + let '(Γinds, sinds) := print_context Σ Γpars oib.(ind_indices) in + oib.(ind_name) ++ spars ++ sinds ++ pr_term Σ Γinds true (tSort oib.(ind_sort)) ++ ":=" ++ nl ++ + if short then "..." + else print_list (print_one_cstr Σ Γpars mib) nl oib.(ind_ctors). + +Fixpoint print_env_aux (short : bool) (prefix : nat) (Σ : global_env) (acc : string) := + match prefix with + | 0 => match Σ with [] => acc | _ => ("..." ++ nl ++ acc)%string end + | S n => + match Σ with + | [] => acc + | (kn, InductiveDecl mib) :: Σ => + let Σ' := (Σ, mib.(ind_universes)) in + let names := fresh_names Σ' [] (arities_context mib.(ind_bodies)) in + print_env_aux short n Σ + ("Inductive " ++ + print_list (print_one_ind short Σ' names mib) nl mib.(ind_bodies) ++ "." ++ + nl ++ acc)%string + | (kn, ConstantDecl cb) :: Σ => + let Σ' := (Σ, cb.(cst_universes)) in + print_env_aux short n Σ + ((match cb.(cst_body) with + | Some _ => "Definition " + | None => "Axiom " + end) ++ string_of_kername kn ++ " : " ++ pr_term Σ' nil true cb.(cst_type) ++ + match cb.(cst_body) with + | Some b => + if short then ("..." ++ nl)%string + else (" := " ++ nl ++ pr_term Σ' nil true b ++ "." ++ nl) + | None => "." + end ++ acc)%string + end + end. + +Definition print_env (short : bool) (prefix : nat) Σ := print_env_aux short prefix Σ EmptyString. + +Definition print_program (short : bool) (prefix : nat) (p : program) : string := + print_env short prefix (fst p) ++ nl ++ + pr_term (empty_ext (fst p)) nil true (snd p). diff --git a/pcuic/theories/PCUICPrincipality.v b/pcuic/theories/PCUICPrincipality.v index 90b81cdb5..3c589e893 100644 --- a/pcuic/theories/PCUICPrincipality.v +++ b/pcuic/theories/PCUICPrincipality.v @@ -61,7 +61,7 @@ Section Principality. isWfArity Σ Γ (tSort u). Proof. move=> wfΓ wfu. - split. eapply PCUICSpine.isType_Sort; eauto. exists [], u. intuition auto. + split. eapply isType_Sort; eauto. exists [], u. intuition auto. Qed. Hint Extern 10 (isWfArity _ _ (tSort _)) => apply isWfArity_sort : pcuic. @@ -195,7 +195,7 @@ Section Principality. - eapply inversion_Ind in hA as [mdecl [idecl [? [Hdecl ?]]]] => //; auto. repeat outtimes. - exists (subst_instance_constr u (ind_type idecl)). + exists (subst_instance u (ind_type idecl)). int inversion_Ind. destruct hB as [mdecl' [idecl' [? [Hdecl' ?]]]] => //. red in Hdecl, Hdecl'. destruct Hdecl as [? ?]. destruct Hdecl' as [? ?]. red in H, H1. @@ -205,7 +205,7 @@ Section Principality. - eapply inversion_Construct in hA as [mdecl [idecl [? [? [Hdecl ?]]]]] => //; auto. repeat outtimes. - exists (type_of_constructor mdecl (i0, t, n0) (i, n) u). + exists (type_of_constructor mdecl x (i, n) u). int inversion_Construct. destruct hB as [mdecl' [idecl' [? [? [Hdecl' [? ?]]]]]] => //. red in Hdecl, Hdecl'. destruct Hdecl as [[? ?] ?]. @@ -214,44 +214,37 @@ Section Principality. rewrite H3 in H0. noconf H0. rewrite H4 in H1. now noconf H1. - - destruct p as [ind n]. - assert (wf Σ) by auto. - eapply inversion_Case in hA=>//. - repeat outsum. repeat outtimes. simpl in *. - repeat outtimes. - subst. - destruct (IHu1 _ _ t) as [? p]. - destruct (IHu2 _ _ t0) as [? p0]. - destruct (p _ t). destruct (p0 _ t0). - eapply invert_cumul_ind_r in c1 as [u' [x0' [redr [redu ?]]]]; auto. - exists (mkApps u1 (skipn (ind_npars x1) x0 ++ [u2])); intros b hB; repeat split; auto. + - assert (wf Σ) by auto. + eapply inversion_Case in hA as (mdecl&idecl&isdecl&indices&[]&?); auto. + destruct (IHu _ _ scrut_ty) as [? p0]. + destruct (p0 _ scrut_ty). + eapply invert_cumul_ind_r in c0 as [u' [x0' [redr [redu ?]]]]; auto. + exists (mkApps ptm (indices ++ [u])); intros b hB; repeat split; auto. 2:econstructor; eauto. - eapply inversion_Case in hB=>//; auto. - repeat outsum. repeat outtimes. simpl in *. - repeat outtimes. - destruct (PCUICWeakeningEnv.declared_inductive_inj d d0) as [-> ->]. - destruct (p0 _ t4). - eapply invert_cumul_ind_r in c2 as [u'' [x9' [redr' [redu' ?]]]]; auto. - assert (All2 (fun a a' => Σ ;;; Γ |- a = a') x0 x9). + eapply inversion_Case in hB as (mdecl'&idecl'&isdecl'&indices'&[]&?); tea. clear brs_ty0. + destruct (PCUICWeakeningEnv.declared_inductive_inj isdecl isdecl') as [-> ->]. + destruct (p0 _ scrut_ty0). + eapply invert_cumul_ind_r in c1 as [u'' [x9' [redr' [redu' ?]]]]; auto. + assert (All2 (fun a a' => Σ ;;; Γ |- a = a') x0' x9'). { destruct (red_confluence wfΣ redr redr'). destruct p1. eapply red_mkApps_tInd in r as [args' [? ?]]; auto. eapply red_mkApps_tInd in r0 as [args'' [? ?]]; auto. subst. solve_discr. - clear -wfΣ a0 a1 a2 a3 a4. - eapply All2_trans with x0'; eauto. eapply conv_trans; eauto. - eapply (All2_impl (Q:=fun x y => Σ ;;; Γ |- x = y)) in a3; auto using red_conv. - eapply (All2_impl (Q:=fun x y => Σ ;;; Γ |- x = y)) in a4; auto using red_conv. + clear -wfΣ a a0 a1 a2. eapply All2_trans with args'; eauto. eapply conv_trans; eauto. - eapply All2_trans with x9'; eauto. eapply conv_trans; eauto. - eapply All2_symmetry; eauto. eapply conv_sym. + eapply (All2_impl (Q:=fun x y => Σ ;;; Γ |- x = y)) in a1; auto using red_conv. + eapply (All2_impl (Q:=fun x y => Σ ;;; Γ |- x = y)) in a2; auto using red_conv. eapply All2_symmetry; eauto. eapply conv_sym. } - clear redr redr' a1 a2. - etransitivity. 2:eapply c1. + clear redr redr'. + etransitivity. 2:eapply c0. eapply conv_cumul, mkApps_conv_args; auto. eapply All2_app. 2:constructor; auto. - now eapply All2_skipn. + assert (All2 (conv Σ Γ) x0' (pparams p ++ indices')). + { transitivity x9'; tea. apply All2_symmetry; eauto. tc. } + pose proof (conv_terms_trans _ _ _ a X3). + eapply All2_app_inv in X4 as [] => //. - destruct s as [[ind k] pars]; simpl in *. eapply inversion_Proj in hA=>//; auto. @@ -260,7 +253,7 @@ Section Principality. specialize (IHu _ _ t) as [C HP]. destruct (HP _ t). eapply invert_cumul_ind_r in c0 as [u' [x0' [redr [redu ?]]]]; auto. - exists (subst0 (u :: List.rev x0') (subst_instance_constr u' t0)). + exists (subst0 (u :: List.rev x0') (subst_instance u' t0)). intros B hB. eapply inversion_Proj in hB=>//; auto. repeat outsum. repeat outtimes. @@ -271,7 +264,7 @@ Section Principality. eapply type_reduction in t0; eauto. eapply invert_cumul_ind_r in c1 as [u'' [x0'' [redr' [redu' ?]]]]; auto. eapply (type_Proj _ _ _ _ _ _ _ _ d0); simpl; auto. - now rewrite -(All2_length _ _ a). + now rewrite -(All2_length a). eapply invert_cumul_ind_r in c1 as [u'' [x0'' [redr' [redu' ?]]]]; auto. destruct (red_confluence wfΣ redr redr') as [nf [redl redr'']]. eapply red_mkApps_tInd in redl as [? [-> conv]]; auto. @@ -287,7 +280,7 @@ Section Principality. { eapply validity in t2; eauto. destruct t2 as [s Hs]. eapply invert_type_mkApps_ind in Hs. intuition eauto. all:auto. eapply d. } - transitivity (subst0 (u :: List.rev x0') (subst_instance_constr x2 t3)); cycle 1. + transitivity (subst0 (u :: List.rev x0') (subst_instance x2 t3)); cycle 1. eapply conv_cumul. assert (conv_terms Σ Γ x0' x7). { transitivity x4. eapply (All2_impl conv); auto using red_conv. @@ -321,10 +314,10 @@ Section Principality. eapply (wf_projection_context _ (p:= (ind, k, pars))); pcuic. len. simpl. len. simpl. rewrite d0.(onNpars). - rewrite closedn_subst_instance_constr. + rewrite closedn_subst_instance. now apply (declared_projection_closed wfΣ d). simpl; len. rewrite d0.(onNpars). - rewrite closedn_subst_instance_constr. + rewrite closedn_subst_instance. now apply (declared_projection_closed wfΣ d). - pose proof (typing_wf_local hA). @@ -379,7 +372,7 @@ Proof. solve_discr. split. assert (#|args| = #|args'|). - now rewrite (All2_length _ _ eqargs) (All2_length _ _ eqargs') (All2_length _ _ eq0) (All2_length _ _ eq1). + now rewrite (All2_length eqargs) (All2_length eqargs') (All2_length eq0) (All2_length eq1). exists ui'. split; auto. eapply All2_trans; [|eapply eqargs|]. intro; intros. eapply conv_trans; eauto. @@ -418,6 +411,16 @@ Proof. eapply eq_term_upto_univ_empty_impl; auto; typeclasses eauto. Qed. +Lemma eq_context_empty_eq_context {cf:checker_flags} {Σ : global_env_ext} {x y} : + eq_context_upto [] (eq_universe Σ) (eq_universe Σ) x y -> + eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) x y. +Proof. + intros. + eapply All2_fold_impl; tea. + intros ???? []; constructor; eauto using eq_term_empty_eq_term. + all:now apply eq_term_empty_eq_term. +Qed. + Notation eq_term_napp Σ n x y := (eq_term_upto_univ_napp Σ (eq_universe Σ) (eq_universe Σ) n x y). @@ -455,7 +458,7 @@ Proof. (fun Σ Γ t T => forall (onu : on_udecl Σ.1 Σ.2), forall t' T' : term, Σ ;;; Γ |- t' : T' -> leq_term [] Σ t' t -> Σ;;; Γ |- t' : T) - (fun Σ Γ wfΓ => wf_local Σ Γ)); auto;intros Σ wfΣ Γ wfΓ; intros. + (fun Σ Γ => wf_local Σ Γ)); auto;intros Σ wfΣ Γ wfΓ; intros. 1-13:match goal with [ H : leq_term _ _ _ _ |- _ ] => depelim H end. @@ -465,7 +468,7 @@ Proof. auto. } - eapply inversion_Sort in X0 as [wf [wfs cum]]. eapply type_Cumul' with (tSort (Universe.super s)). - constructor; auto. eapply PCUICSpine.isType_Sort; pcuic. + constructor; auto. eapply PCUICArities.isType_Sort; pcuic. constructor. constructor. apply leq_universe_super. apply x. auto. @@ -532,44 +535,44 @@ Proof. eapply eq_term_empty_eq_term in X7_2. eapply type_Cumul'. eapply type_App'; [eapply X3|eapply X5]. - eapply PCUICValidity.validity; pcuic. + eapply validity; pcuic. eapply type_App; eauto. eapply conv_cumul. eapply (subst_conv Γ [vass na A] [vass na A] []); pcuic. repeat constructor. now rewrite subst_empty. repeat constructor. now rewrite subst_empty. - eapply PCUICValidity.validity in X2; auto. + eapply validity in X2; auto. apply PCUICArities.isType_tProd in X2 as [tyA]; auto. constructor; auto. - eapply inversion_Const in X1 as [decl' [wf [declc [cu cum]]]]; auto. eapply type_Cumul'; eauto. econstructor; eauto. - eapply PCUICValidity.validity; eauto. + eapply validity; eauto. econstructor; eauto. eapply conv_cumul. constructor. pose proof (PCUICWeakeningEnv.declared_constant_inj _ _ H declc); subst decl'. - eapply PCUICUnivSubstitution.eq_term_upto_univ_subst_instance_constr; eauto; typeclasses eauto. + eapply PCUICUnivSubstitution.eq_term_upto_univ_subst_instance; eauto; typeclasses eauto. - eapply inversion_Ind in X1 as [decl' [idecl' [wf [declc [cu cum]]]]]; auto. eapply type_Cumul'; eauto. econstructor; eauto. - eapply PCUICValidity.validity; eauto. + eapply validity; eauto. econstructor; eauto. eapply conv_cumul. constructor. pose proof (PCUICWeakeningEnv.declared_inductive_inj isdecl declc) as [-> ->]. - eapply PCUICUnivSubstitution.eq_term_upto_univ_subst_instance_constr; eauto; typeclasses eauto. + eapply PCUICUnivSubstitution.eq_term_upto_univ_subst_instance; eauto; typeclasses eauto. - eapply inversion_Construct in X1 as [decl' [idecl' [cdecl' [wf [declc [cu cum]]]]]]; auto. eapply type_Cumul'; eauto. econstructor; eauto. - eapply PCUICValidity.validity; eauto. + eapply validity; eauto. econstructor; eauto. pose proof (PCUICWeakeningEnv.declared_constructor_inj isdecl declc) as [-> [-> ->]]. unfold type_of_constructor. - transitivity (subst0 (inds (inductive_mind (ind, i).1) u (ind_bodies mdecl)) - (subst_instance_constr u0 cdecl'.1.2)). + transitivity (subst0 (inds (inductive_mind ind) u (ind_bodies mdecl)) + (subst_instance u0 cdecl'.(cstr_type))). * eapply conv_cumul. eapply (conv_subst_conv _ Γ _ _ []); eauto. { eapply conv_inds. now eapply R_global_instance_empty_universe_instance. } @@ -580,33 +583,36 @@ Proof. eapply subslet_untyped_subslet. eapply (PCUICSpine.weaken_subslet _ _ _ Γ []); eauto. eapply PCUICArities.subslet_inds; eauto. - destruct declc; eauto. * constructor. eapply PCUICEquality.subst_leq_term. eapply PCUICEquality.eq_term_leq_term. - eapply PCUICUnivSubstitution.eq_term_upto_univ_subst_instance_constr; eauto; typeclasses eauto. - - - eapply inversion_Case in X6 as (u' & args' & mdecl' & idecl' & ps' & pty' & btys' & inv); auto. - intuition auto. - intuition auto. - pose proof (X2 _ _ a6 (eq_term_empty_leq_term X7_2)). - eapply eq_term_empty_eq_term in X7_1. - eapply eq_term_empty_eq_term in X7_2. + eapply PCUICUnivSubstitution.eq_term_upto_univ_subst_instance; eauto; typeclasses eauto. + + - assert (isType Σ Γ (mkApps ptm (indices ++ [c]))). + { eapply validity. econstructor; eauto. + solve_all. } + eapply inversion_Case in X10 as (mdecl' & idecl' & decli' & indices' & data & cum); auto. + destruct (PCUICWeakeningEnv.declared_inductive_inj isdecl decli'). subst mdecl' idecl'. + destruct data. + unshelve epose proof (X8 _ _ _ scrut_ty (eq_term_empty_leq_term X11)); tea. + pose proof (eq_term_empty_eq_term X11). + destruct e as [eqpars [eqinst [eqpctx eqpret]]]. + eapply eq_term_empty_eq_term in eqpret. eapply type_Cumul'. - econstructor; eauto. - eapply PCUICValidity.validity; eauto. - eapply (type_Case _ _ (ind, npar)). eapply isdecl. - all:eauto. - eapply (All2_impl X5); pcuicfo. - destruct b1 as [s [? ?]]. now exists s. + econstructor; eauto. tas. clear brs_ty. eapply conv_cumul. eapply mkApps_conv_args; pcuic. - eapply All2_app. simpl in *. + rewrite /ptm. constructor. + eapply PCUICEquality.eq_term_upto_univ_it_mkLambda_or_LetIn; tea. tc. + eapply eq_context_empty_eq_context; tea. + eapply All2_app. 2:constructor; pcuic. - eapply All2_skipn. - clear -onu wfΣ a6 X4 X6. - unshelve eapply (principal_type_ind a6 X4). + specialize (X3 _ _ scrut_ty (eq_term_empty_leq_term X11)). + unshelve epose proof (principal_type_ind scrut_ty X3) as [_ indconv]; tea. split; auto. - + eapply All2_app_inv in indconv as [convpars convinds]. + 2:exact (All2_length eqpars). + exact convinds. + - eapply inversion_Proj in X3 as (u' & mdecl' & idecl' & pdecl' & args' & inv); auto. intuition auto. specialize (X3 _ _ a0 (eq_term_empty_leq_term X4)). @@ -615,16 +621,16 @@ Proof. pose proof (principal_type_ind X3 a0) as [Ruu' X3']. eapply type_Cumul'. clear a0. econstructor; eauto. - now rewrite (All2_length _ _ X3'). + now rewrite (All2_length X3'). eapply PCUICValidity.validity; eauto. eapply type_Proj; eauto. - transitivity (subst0 (c :: List.rev args) (subst_instance_constr u pdecl'.2)). + transitivity (subst0 (c :: List.rev args) (subst_instance u pdecl'.2)). eapply conv_cumul. set (ctx := PCUICInductives.projection_context mdecl' idecl' p.1.1 u). set (ctx' := PCUICInductives.projection_context mdecl' idecl' p.1.1 u). eapply (conv_subst_conv _ Γ ctx ctx' []); eauto. constructor. now constructor. - eapply All2_rev. eapply All2_refl. intros; apply conv_refl'. + eapply All2_rev. eapply All2_refl. reflexivity. eapply subslet_untyped_subslet; eauto. eapply PCUICInductives.projection_subslet; eauto. eapply validity in X3; auto. diff --git a/pcuic/theories/PCUICRedIrrefl.v b/pcuic/theories/PCUICRedIrrefl.v new file mode 100644 index 000000000..517133c90 --- /dev/null +++ b/pcuic/theories/PCUICRedIrrefl.v @@ -0,0 +1,299 @@ + +(* Distributed under the terms of the MIT license. *) +From MetaCoq.Template Require Import config utils. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction + PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICWeakeningEnv PCUICWeakening + PCUICSigmaCalculus (* for smash_context lemmas, to move *) + PCUICSubstitution PCUICClosed PCUICCumulativity PCUICGeneration PCUICReduction + PCUICEquality PCUICConfluence + PCUICContextConversion PCUICContextSubst PCUICUnivSubstitution + PCUICConversion PCUICInversion PCUICContexts PCUICArities + PCUICSpine PCUICInductives PCUICValidity. + +From Equations Require Import Equations. +Derive Subterm for term. + +Require Import ssreflect. + +Local Set SimplIsCbn. + +Implicit Types (cf : checker_flags) (Σ : global_env_ext). + +Hint Rewrite reln_length : len. + +Ltac substu := autorewrite with substu => /=. + +Tactic Notation "substu" "in" hyp(id) := + autorewrite with substu in id; simpl in id. + + From MetaCoq.PCUIC Require Import PCUICContextRelation. +Proposition leq_term_equiv `{checker_flags} Σ t t' : + leq_term Σ.1 Σ t t' -> leq_term Σ.1 Σ t' t -> eq_term Σ.1 Σ t t'. + Admitted. + +Lemma cum_cum_trans {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ T U V} : + Σ ;;; Γ |- T <= U -> + Σ ;;; Γ |- U <= V -> + ∑ T' U' V', + red Σ Γ T T' × + red Σ Γ U U' × + red Σ Γ V V' × + leq_term Σ Σ T' U' × + leq_term Σ Σ U' V'. +Proof. + move/cumul_alt; intros (T' & U' & (redTT' & redUU') & leqT'U'). + move/cumul_alt; intros (U'' & V' & (redUU'' & redVV') & leqU''V'). + destruct (red_confluence wfΣ redUU' redUU'') as [Unf [redU'nf redU''nf]]. + destruct (red_eq_term_upto_univ_l Σ _ leqU''V' redU''nf) as [v'nf [redV'nf lequnf]]. + destruct (red_eq_term_upto_univ_r Σ _ leqT'U' redU'nf) as [T'nf [redT'nf leqTnf]]. + exists T'nf, Unf, v'nf. + intuition auto. + - now transitivity T'. + - now transitivity U'. + - now transitivity V'. +Qed. + +Hint Constructors term_direct_subterm : term. + +Lemma leq_term_size {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} T T' : + leq_term Σ Σ T T' -> + PCUICSize.size T = PCUICSize.size T'. +Proof. + induction 1; simpl; auto; try lia. + f_equal. admit. + f_equal. rewrite IHX. admit. +Admitted. + +Lemma lift_irrefl_direct n k t x : + term_direct_subterm t x -> + lift n k t <> x. +Proof. + intros ts H. subst x. + revert ts. + induction t using term_forall_list_ind in n, k |- *; simpl; + try solve [intros H; depelim H]. + * intros H. depelim H. + eapply IHt2; rewrite -> H. constructor. + eapply IHt1; rewrite -> H. constructor. + * intros H. depelim H. + eapply IHt2; rewrite -> H. constructor. + eapply IHt1; rewrite -> H. constructor. + * intros H; depelim H. + eapply IHt3; rewrite -> H; eauto with term. + eapply IHt2; rewrite -> H; eauto with term. + eapply IHt1; rewrite -> H; eauto with term. + * intros H; depelim H. + eapply IHt2; rewrite -> H; eauto with terms. + constructor. + eapply IHt1; rewrite -> H; constructor. + * intros H; depelim H. + eapply IHt. rewrite -> H. constructor. + * intros H; depelim H. + eapply IHt; rewrite -> H. constructor. +Qed. + +Lemma lift_irrefl n k t : + term_subterm t (lift n k t) -> False. +Proof. + intros H; depind H. + now eapply lift_irrefl_direct. + eapply IHclos_trans2. +Admitted. + + +Lemma nocycle {A} {R} {wfR : Equations.Prop.Classes.WellFounded R} : + forall x : A, R x x -> False. +Proof. + intros x Ryy. red in wfR. + induction (wfR x) as [y accy IHy]. + apply (IHy _ Ryy Ryy). +Qed. + +Instance term_direct_subterm_wf : WellFounded term_direct_subterm. +Proof. + intros x. induction x; + constructor; intros y H; depelim H; auto. +Qed. + +Lemma term_direct_subterm_irrefl x : term_direct_subterm x x -> False. +Proof. + intros H. + now apply nocycle in H. +Qed. + + +Lemma term_subterm_irrefl x : term_subterm x x -> False. +Proof. + intros H. + now apply nocycle in H. +Qed. +(* +Lemma subst_irrefl s k b x : + term_subterm b x -> All (fun a => term_subterm a x) s -> + subst s k b <> x. +Proof. + intros ts hs H; subst x. + revert ts. + induction b using term_forall_list_ind in k, s, hs |- *; simpl; try (split; congruence). + all:try apply term_subterm_irrefl. + * destruct (leb_spec_Set k n). + case: nth_error_spec => /= // [t hnth hn|hn]. + eapply nth_error_all in hs; tea => /=. simpl in hs. + destruct (leb_spec_Set k n);try lia. + rewrite hnth in hs. + now eapply lift_irrefl in hs. + intros. admit. + (* depelim ts. *) + apply term_subterm_irrefl. + * intros. admit. + * intros ts. + depelim ts. simpl in hs. + depelim H. + eapply IHb2. + 2:{ rewrite -> H. constructor. constructor. } + eapply (All_impl hs). + intros. depelim H0. + rewrite H. + + +Admitted. + +Lemma beta_irrefl b a na ty : + b {0 := a} <> tApp (tLambda na ty b) a. +Proof. + intros H. + forward (subst_irrefl [a] 0 b (tApp (tLambda na ty b) a)). + eapply Relation_Operators.t_trans with (tLambda na ty b). + repeat constructor. + repeat constructor. + intros. forward H0. + constructor. 2:constructor. + constructor. constructor. + rewrite /subst1 in H. congruence. +Qed. + +Lemma red_leq_sym {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ T T' T''} : + red1 Σ Γ T T' -> + red1 Σ Γ T T'' -> + (T' = T'') + (leq_term Σ Σ T' T'' -> False). + (* leq_term Σ Σ T'' T'. *) +Proof. + intros red red'. + (* eapply (eq_term_upto_univ_napp_flip _ _ (fun x y => leq_universe Σ y x)); eauto. all:tc. + - intros x. reflexivity. + - intros x y z ? ?. etransitivity; tea. + - intros x y e. apply eq_universe_leq_universe. now symmetry. + - *) + + induction red using red1_ind_all in T'', red' |- *; try depelim red'. + all:try solve_discr. + all:try (left; reflexivity). + * depelim red'; try solve_discr. + right. intros leq. admit. + right. intros leq. +Abort.*) + +From MetaCoq.PCUIC Require Import PCUICParallelReduction PCUICParallelReductionConfluence PCUICEquality PCUICSubstitution. +(* +Lemma red_leq_sym {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} + {Γ Γ' Γ'' T T' T''} {Re Rle : Universe.t -> Universe.t -> Prop} {equ lequ napp} : + (forall u u' : Universe.t, reflectT (Re u u') (equ u u')) -> + (forall u u' : Universe.t, reflectT (Rle u u') (lequ u u')) -> + pred1 Σ Γ Γ' T T' -> + pred1 Σ Γ Γ'' T T'' -> + eq_term_upto_univ_napp Σ Re Rle napp T' T'' -> + eq_term_upto_univ_napp Σ Re Re napp T' T''. +Proof. + intros requ rlequ. + intros red red'. + pose proof (pred1_diamond wfΣ red red') as []. + + + revert Γ Γ' T T' red napp lequ Rle rlequ Γ'' T'' red'. + apply: pred1_ind_all_ctx. + intros. exact X. intros. + exact X3. + all:intros. + - depelim red'; try solve_discr. + * specialize (X0 napp lequ Rle rlequ _ _ red'2). + destruct (reflect_eq_term_upto_univ Σ equ lequ Re Rle 0 requ rlequ a1 a3). + apply eq_term_upto_univ_substs; tc. + apply X0. admit. + constructor. 2:constructor. + now apply (X4 0 lequ Rle rlequ _ _ red'3). + admit. + (* Implies a1, a3 not part of b1 {0 := a1} ... *) + * specialize (X4 napp lequ Rle rlequ _ _ red'2). + + + apply clos_refl_trans_out in red. + apply clos_red_rel_out in red; eauto. + apply clos_refl_trans_out in red'. + apply clos_red_rel_out in +*) +(*Lemma red_leq_sym {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ T T' T''} : + red Σ Γ T T' -> + red Σ Γ T T'' -> + leq_term Σ Σ T' T'' -> + leq_term Σ Σ T'' T'. +Proof. + intros red red'. + apply clos_refl_trans_out in red. + apply clos_red_rel_out in red; eauto. + apply clos_refl_trans_out in red'. + apply clos_red_rel_out in red'; eauto. + assert (eq_term Σ Σ T T) by reflexivity. + intros leq. pose proof (fill_eq Σ X red red'). + pose proof (red_confluence wfΣ red red').*) + +(* From MetaCoq.PCUIC Require Import PCUICEqualityDec. *) + + +Lemma cum_cum_conv {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ T U } : + Σ ;;; Γ |- T <= U -> + Σ ;;; Γ |- U <= T -> + Σ ;;; Γ |- T = U. +Proof. + intros cuml cumr. + destruct (cum_cum_trans cuml cumr) as (T' & U' & T'' & redTT' & redUU' & redTT'' & leql & leqr). + apply conv_alt_red. + assert (eq_term Σ Σ T T) by reflexivity. + pose proof (fill_eq Σ X redTT' redTT'') as (T'eq & T''eq & (redT'eq & redT''eq) & eqeqs). + epose proof (red_eq_term_upto_univ_r Σ _ leqr redT''eq) as [U'eq [redU'eq eqU']]. + epose proof (red_eq_term_upto_univ_l Σ _ leql redT'eq) as [U'eq' [redU'eq' eqU'']]. + change (leq_term Σ Σ T'eq U'eq') in eqU''. + change (leq_term Σ Σ U'eq T''eq) in eqU'. + assert (leq_term Σ Σ U'eq T'eq). + { transitivity T''eq => //. now apply eq_term_leq_term; symmetry. } + assert () + + + exists T'eq, U'eq'. + intuition auto. + - transitivity T' => //. + - transitivity U' => //. + - + apply leq_term_equiv; auto. + assert (leq_term Σ Σ U'eq U'eq'). + now transitivity T'eq. + assert (leq_term Σ.1 Σ U'eq' T'eq -> False). admit. + + epose proof (reflect_eq_term_upto_univ Σ _ _ (eq_universe Σ) (leq_universe Σ) 0 _ _ U'eq T'eq). + + + + transitivity T''eq. now apply eq_term_leq_term. + + apply eqU''. + now transitivity U'. + assert (leq_term Σ Σ T' T''). by transitivity U'. + clear leql leqr redUU' cuml cumr U U'. + pose proof fill_eq. + pose prood (red_eq_term_upto_univ_l Σ _ ) + + admit. + exists T', U'. intuition auto. + apply leq_term_equiv; auto. + transitivity T''. auto. symmetry in X. + now apply eq_term_leq_term. + diff --git a/pcuic/theories/PCUICRedTypeIrrelevance.v b/pcuic/theories/PCUICRedTypeIrrelevance.v new file mode 100644 index 000000000..073f3a25a --- /dev/null +++ b/pcuic/theories/PCUICRedTypeIrrelevance.v @@ -0,0 +1,171 @@ +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 + PCUICReduction PCUICContextRelation PCUICContextReduction. + +From Coq Require Import CRelationClasses. + +(** 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. +*) + +Ltac pcuic := + try repeat red; cbn in *; + try (solve [ intuition auto; eauto with pcuic || (try lia || congruence) ]). + +Lemma All2_fold_nth_ass {P n Γ Γ' d} : + All2_fold P Γ Γ' -> nth_error Γ n = Some d -> + assumption_context Γ -> + { d' & ((nth_error Γ' n = Some d') * + let Γs := skipn (S n) Γ in + let Γs' := skipn (S n) Γ' in + All2_fold P Γs Γs' * + (d.(decl_body) = None) * + P Γs Γs' d d')%type }. +Proof. + induction n in Γ, Γ', d |- *; destruct Γ; intros Hrel H; noconf H. + - depelim Hrel. intro ass. + simpl. eexists; intuition eauto. + now depelim ass. + - intros ass. depelim Hrel. + destruct (IHn _ _ _ Hrel H). + now depelim ass. + cbn -[skipn] in *. + eexists; intuition eauto. +Qed. + +(** Types of variables and names are irrelevant during reduction: + Only bodies of let-bindings should be preserved to get the same reductions. +*) + +Section ContextChangeTypesReduction. + + Context {cf : checker_flags}. + Context (Σ : global_env). + +Definition pres_let_bodies (c : context_decl) (c' : context_decl) : Type := + match c.(decl_body) with + | None => unit + | Some b => decl_body c' = Some b + end. + +Global Instance pres_let_bodies_refl : Reflexive pres_let_bodies. +Proof. intros [? [|]]; constructor; reflexivity. Qed. + +(* Global Instance pres_let_bodies_sym : Symmetric pres_let_bodies. +Proof. + intros x y rel. + depelim rel; constructor; now symmetry. +Qed. *) + +Global Instance pres_let_bodies_trans : Transitive pres_let_bodies. +Proof. + intros x y z; unfold pres_let_bodies. + now destruct decl_body => // ->. +Qed. + +(* Global Instance pres_let_bodies_equiv : Equivalence pres_let_bodies. +Proof. constructor; typeclasses eauto. Qed. *) + +Lemma OnOne2All_All3 {A B} (P Q : A -> B -> B -> Type) l l' l'' : + OnOne2All P l l' l'' -> + (forall x y z, P x y z -> Q x y z) -> + (forall x y, Q x y y) -> + All3 Q l l' l''. +Proof. + intros H ? ?. induction H; constructor; auto. + induction tl in bs, e |- *; destruct bs; simpl in e; try constructor; auto; try congruence. +Qed. + +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 : + Reflexive (All2_fold (fun _ _ : context => pres_let_bodies)). +Proof. + intros x. + eapply All2_fold_refl. intros. reflexivity. +Qed. + +Lemma context_pres_let_bodies_red1 Γ Γ' s t : + All2_fold (fun _ _ => pres_let_bodies) Γ Γ' -> + red1 Σ Γ s t -> red1 Σ Γ' s t. +Proof. + intros HT X0. induction X0 using red1_ind_all in Γ', HT |- *; eauto. + all:pcuic. + all:try solve [econstructor; eauto; solve_all]. + - econstructor. + move: H; case: nth_error_spec => [x hnth hi|hi] /= // [=] hbod. + eapply All2_fold_nth in HT as [d' [hnth' [_ pres]]]; eauto. + rewrite /pres_let_bodies hbod in pres. + now rewrite hnth' /= pres. + - econstructor; eauto. + eapply OnOne2_local_env_impl; tea. + intros Δ x y. + eapply on_one_decl_impl; intros Γ'' t t' IH; simpl. + eapply IH. eapply All2_fold_app; auto. + eapply All2_fold_refl. + intros; reflexivity. + - econstructor; eauto. eapply IHX0. + eapply All2_fold_app; eauto. + now eapply All2_fold_refl. + - econstructor; eauto. solve_all. + * rewrite -b. left; intuition eauto. + eapply b0; eauto. + eapply All2_fold_app; eauto. + eapply All2_fold_refl; intros; reflexivity. + * right. split; auto. + eapply OnOne2_local_env_impl; tea. + intros Δ ? ?. + eapply on_one_decl_impl; intros Γ'' t t' IH; simpl. + eapply IH. eapply All2_fold_app; auto. + eapply pres_let_bodies_ctx_refl. + - eapply fix_red_body; eauto. solve_all. + destruct x as [? ? ? ?], y as [? ? ? ?]. simpl in *. noconf b. + eapply b0; eauto. + eapply All2_fold_app; eauto. + eapply pres_let_bodies_ctx_refl. + - eapply cofix_red_body; eauto; solve_all. + eapply b0. + 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) Γ Γ' -> + red Σ Γ s t -> red Σ Γ' s t. +Proof. + intros pres. + eapply clos_rt_monotone => x y. + now apply context_pres_let_bodies_red1. +Qed. + +End ContextChangeTypesReduction. + +Lemma fix_context_pres_let_bodies Γ mfix mfix' : + #|mfix| = #|mfix'| -> + All2_fold (fun _ _ => pres_let_bodies) (Γ,,, fix_context mfix) (Γ,,, fix_context mfix'). +Proof. + intros len. + apply All2_fold_app. + - now rewrite !fix_context_length. + - apply All2_fold_refl. + intros. + destruct x. + destruct decl_body; constructor; + reflexivity. + - unfold fix_context, mapi. + generalize 0 at 2 4. + induction mfix in mfix', len |- *; intros n. + + destruct mfix'; [|cbn in *; discriminate len]. + constructor. + + destruct mfix'; cbn in *; [discriminate len|]. + apply All2_fold_app. + * now rewrite !List.rev_length !mapi_rec_length. + * constructor; [constructor|]. + constructor. + * apply IHmfix; lia. +Qed. diff --git a/pcuic/theories/PCUICReduction.v b/pcuic/theories/PCUICReduction.v index a63e073c1..16afcaae1 100644 --- a/pcuic/theories/PCUICReduction.v +++ b/pcuic/theories/PCUICReduction.v @@ -1,19 +1,41 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils - PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICInduction. + PCUICLiftSubst PCUICUnivSubst PCUICInduction (*PCUICEquality *) + PCUICContextRelation PCUICCases. Require Import ssreflect. Require Import Equations.Prop.DepElim. From Equations.Type Require Import Relation Relation_Properties. From Equations Require Import Equations. - +Set Equations Transparent. Set Default Goal Selector "!". +Notation rtrans_clos := clos_refl_trans_n1. + +Lemma All2_many_OnOne2 : + forall A (R : A -> A -> Type) l l', + All2 R l l' -> + rtrans_clos (OnOne2 R) l l'. +Proof. + intros A R l l' h. + induction h. + - constructor. + - econstructor. + + constructor. eassumption. + + clear - IHh. rename IHh into h. + induction h. + * constructor. + * econstructor. + -- econstructor 2. eassumption. + -- assumption. +Qed. + Definition tDummy := tVar String.EmptyString. +Definition dummy_branch : branch term := mk_branch [] tDummy. -Definition iota_red npar c args brs := - (mkApps (snd (List.nth c brs (0, tDummy))) (List.skipn npar args)). +Definition iota_red npar args br := + subst (List.rev (List.skipn npar args)) 0 (expand_lets br.(bcontext) (bbody br)). (** ** Reduction *) @@ -74,9 +96,245 @@ Proof. unfold fix_context. now rewrite List.rev_length mapi_length. Qed. Inspired by the reduction relation from Coq in Coq [Barras'99]. *) -Local Open Scope type_scope. Arguments OnOne2 {A} P%type l l'. +Definition set_pcontext (p : predicate term) (pctx' : context) : predicate term := + {| pparams := p.(pparams); + puinst := p.(puinst); + pcontext := pctx'; + preturn := p.(preturn) |}. + +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 := + eq_refl. + +Definition set_pparams (p : predicate term) (pars' : list term) : predicate term := + {| pparams := pars'; + puinst := p.(puinst); + pcontext := p.(pcontext); + preturn := p.(preturn) |}. + +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 := + {| decl_name := f (decl_name 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 + 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 := + match d, d' with + | {| decl_name := na; decl_body := None; decl_type := ty |}, + {| decl_name := na'; decl_body := None; decl_type := ty' |} => + 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' × + ((P Γ ty ty' × b = b') + + (P Γ b b' × ty = ty')) + | _, _ => False + end. + +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. + intros HP Γ x y. + 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 : + 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)). +Proof. + intros Γ x y. + destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl in *; firstorder auto; subst; simpl; + auto. +Qed. + +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)). +Proof. + intros Γ x y. + destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl in *; firstorder auto; subst; simpl; + auto. +Qed. + +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 #|Γ|))). +Proof. + intros Γ x y. + destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl in *; firstorder auto; subst; simpl; + auto. +Qed. + +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) -> + on_one_decl Q Γ d d'. +Proof. + intros Γ [na [b|] ty] [na' [b'|] ty'] ond []%andb_and; simpl; firstorder auto. +Qed. + +Section OnOne_local_2. + Context (P : forall (Γ : context), context_decl -> context_decl -> Type). + + Inductive OnOne2_local_env : context -> context -> Type := + | onone2_localenv_cons_abs Γ na na' t t' : + P Γ (vass na t) (vass na' t') -> + OnOne2_local_env (Γ ,, vass na t) (Γ ,, vass na' t') + | onone2_localenv_def Γ na na' b b' t t' : + P Γ (vdef na b t) (vdef na' b' t') -> + OnOne2_local_env (Γ ,, vdef na b t) (Γ ,, vdef na' b' t') + | onone2_localenv_cons_tl Γ Γ' d : + OnOne2_local_env Γ Γ' -> + OnOne2_local_env (Γ ,, d) (Γ' ,, d). +End OnOne_local_2. + +Instance OnOne2_local_env_length {P ctx ctx'} : + HasLen (OnOne2_local_env P ctx ctx') #|ctx| #|ctx'|. +Proof. + induction 1; simpl; lia. +Qed. + +Lemma OnOne2_local_env_impl R S : + (forall Δ, inclusion (R Δ) (S Δ)) -> + inclusion (OnOne2_local_env R) + (OnOne2_local_env S). +Proof. + intros H x y H'. + induction H'; try solve [econstructor; firstorder]. +Qed. + +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. + intros HP. now apply OnOne2_local_env_impl, on_one_decl_impl. +Qed. + +Lemma OnOne2_local_env_map R Γ Δ (f : aname -> aname) (g : term -> term) : + OnOne2_local_env (fun Γ => on_Trel (R (map (map_decl_na f g) Γ)) (map_decl_na f g)) Γ Δ -> + OnOne2_local_env R (map (map_decl_na f g) Γ) (map (map_decl_na f g) Δ). +Proof. + unfold on_Trel in *; induction 1; simpl; try solve [econstructor; intuition auto]. +Qed. + +Lemma OnOne2_local_env_map_context R Γ Δ (f : term -> term) : + OnOne2_local_env (fun Γ => on_Trel (R (map (map_decl f) Γ)) (map_decl f)) Γ Δ -> + OnOne2_local_env R (map_context f Γ) (map_context f Δ). +Proof. + unfold on_Trel in *; induction 1; simpl; try solve [econstructor; intuition auto]. +Qed. + +Lemma OnOne2_local_env_mapi_context R Γ Δ (f : nat -> term -> term) : + OnOne2_local_env (fun Γ => on_Trel (R (mapi_context f Γ)) (map_decl (f #|Γ|))) Γ Δ -> + OnOne2_local_env R (mapi_context f Γ) (mapi_context f Δ). +Proof. + unfold on_Trel in *; induction 1; simpl; try solve [econstructor; intuition auto]. + rewrite -(length_of X). now constructor. +Qed. + +Lemma test_context_k_impl {p q : nat -> term -> bool} {k k'} {ctx} : + (forall n t, p n t -> q n t) -> + k = k' -> + test_context_k p k ctx -> test_context_k q k' ctx. +Proof. + intros Hfg <-. + induction ctx as [|[na [b|] ty] ctx]; simpl; auto; + move/andb_and=> [testp testd]; rewrite (IHctx testp); + eapply test_decl_impl; tea; eauto. +Qed. + +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', + P Γ d d' -> + test_context_k q k Γ -> + test_decl (q (#|Γ| + k)) d -> + test_decl (p (#|Γ| + k)) d') -> + test_context_k q k ctx -> + test_context_k p k ctx'. +Proof. + intros hq onenv HPq. + induction onenv. + * move=> /= /andb_and [testq testd]. + rewrite (test_context_k_impl _ _ testq) //. + simpl; eauto. + * move=> /= /andb_and [testq testd]. + rewrite (test_context_k_impl _ _ testq) //. + simpl; eauto. + * move=> /= /andb_and [testq testd]. + rewrite (IHonenv testq). + eapply test_decl_impl; tea. + intros x Hx. eapply hq. + now rewrite -(length_of onenv). +Qed. + +Lemma on_one_decl_test_decl (P : context -> term -> term -> Type) Γ + (p q : term -> bool) d d' : + (forall t, p t -> q t) -> + (forall t t', P Γ t t' -> p t -> q t') -> + on_one_decl P Γ d d' -> + test_decl p d -> + test_decl q d'. +Proof. + intros Hp. + unfold test_decl. + destruct d as [na [b|] ty], d' as [na' [b'|] ty']; simpl in * => //; + intuition auto; rtoProp; + subst; simpl; intuition eauto. +Qed. + +Lemma OnOne2_local_env_impl_test {P Q ctx ctx'} {k} {p : nat -> term -> bool} : + OnOne2_local_env P ctx ctx' -> + (forall Γ d d', + P Γ d d' -> + test_context_k p k Γ -> + test_decl (p (#|Γ| + k)) d -> + Q Γ d d') -> + test_context_k p k ctx -> + OnOne2_local_env Q ctx ctx'. +Proof. + intros onenv HPq. + induction onenv. + * move=> /= /andb_and [testq testd]. + constructor; auto. + * move=> /= /andb_and [testq testd]. + constructor; auto. + * move=> /= /andb_and [testq testd]. + constructor; auto. +Qed. + +(*Lemma OnOne2_local_env_mapi_context R (Γ Δ : context) (f g : nat -> term -> term) : + OnOne2_local_env (fun Γ d d' => R (mapi_context f Γ) (map_decl (f #|Γ|) d) (map_decl (g #|Γ|) d)) Γ Δ -> + OnOne2_local_env R (mapi_context f Γ) (mapi_context g Δ). +Proof. + unfold on_Trel in *; induction 1; simpl; try solve [econstructor; intuition auto]. + * rewrite /map_decl /=. econstructor. +Qed.*) + +Local Open Scope type_scope. Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := (** Reductions *) (** Beta *) @@ -92,9 +350,12 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := red1 Σ Γ (tRel i) (lift0 (S i) body) (** Case *) -| red_iota ind pars c u args p brs : - red1 Σ Γ (tCase (ind, pars) p (mkApps (tConstruct ind c u) args) brs) - (iota_red pars c args brs) +| red_iota ci c u args p brs br : + nth_error brs c = Some br -> + (* #|p.(pparams)| = ci.(ind_npars) ->*) + #|skipn (ci_npar ci) args| = context_assumptions br.(bcontext) -> + red1 Σ Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + (iota_red ci.(ci_npar) args br) (** Fix unfolding, with guard *) | red_fix mfix idx args narg fn : @@ -117,7 +378,7 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := (** Constant unfolding *) | red_delta c decl body (isdecl : declared_constant Σ c decl) u : decl.(cst_body) = Some body -> - red1 Σ Γ (tConst c u) (subst_instance_constr u body) + red1 Σ Γ (tConst c u) (subst_instance u body) (** Proj *) | red_proj i pars narg args u arg: @@ -132,11 +393,31 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := | letin_red_ty na b t b' r : red1 Σ Γ t r -> red1 Σ Γ (tLetIn na b t b') (tLetIn na b r b') | letin_red_body na b t b' r : red1 Σ (Γ ,, vdef na b t) b' r -> red1 Σ Γ (tLetIn na b t b') (tLetIn na b t r) -| case_red_pred ind p p' c brs : red1 Σ Γ p p' -> 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 p c brs brs' : - OnOne2 (on_Trel_eq (red1 Σ Γ) snd fst) brs brs' -> - red1 Σ Γ (tCase ind p c brs) (tCase ind p c brs') +| case_red_param ci p params' c brs : + OnOne2 (red1 Σ Γ) p.(pparams) params' -> + red1 Σ Γ (tCase ci p c brs) + (tCase ci (set_pparams p params') c brs) + +| case_red_pcontext ci p pcontext' c brs : + OnOne2_local_env (on_one_decl (fun Γ' => red1 Σ (Γ ,,, Γ'))) p.(pcontext) pcontext' -> + red1 Σ Γ (tCase ci p c brs) + (tCase ci (set_pcontext p pcontext') c brs) + +| case_red_return ci p preturn' c brs : + red1 Σ (Γ ,,, p.(pcontext)) p.(preturn) preturn' -> + red1 Σ Γ (tCase ci p c brs) + (tCase ci (set_preturn p preturn') c brs) + +| case_red_discr ci p c c' brs : + red1 Σ Γ c c' -> + red1 Σ Γ (tCase ci p c brs) (tCase ci p c' brs) + +| case_red_brs ci p c brs brs' : + OnOne2 (fun br br' => + on_Trel_eq (red1 Σ (Γ ,,, br.(bcontext))) bbody bcontext br br' + + on_Trel_eq (OnOne2_local_env (on_one_decl (fun Γ' => red1 Σ (Γ ,,, Γ')))) bcontext bbody br br') + brs brs' -> + red1 Σ Γ (tCase ci p c brs) (tCase ci p c brs') | proj_red p c c' : red1 Σ Γ c c' -> red1 Σ Γ (tProj p c) (tProj p c') @@ -166,6 +447,9 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := OnOne2 (on_Trel_eq (red1 Σ (Γ ,,, fix_context mfix0)) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> red1 Σ Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx). +Definition red1_ctx Σ := (OnOne2_local_env (on_one_decl (fun Δ t t' => red1 Σ Δ t t'))). +Definition red1_ctx_rel Σ Γ := (OnOne2_local_env (on_one_decl (fun Δ t t' => red1 Σ (Γ ,,, Δ) t t'))). + Lemma red1_ind_all : forall (Σ : global_env) (P : context -> term -> term -> Type), @@ -177,18 +461,21 @@ Lemma red1_ind_all : (forall (Γ : context) (i : nat) (body : term), option_map decl_body (nth_error Γ i) = Some (Some body) -> P Γ (tRel i) ((lift0 (S i)) body)) -> - (forall (Γ : context) (ind : inductive) (pars c : nat) (u : Instance.t) (args : list term) - (p : term) (brs : list (nat * term)), - P Γ (tCase (ind, pars) p (mkApps (tConstruct ind c u) args) brs) (iota_red pars c args brs)) -> + (forall (Γ : context) (ci : case_info) (c : nat) (u : Instance.t) (args : list term) + (p : predicate term) (brs : list (branch term)) br, + nth_error brs c = Some br -> + #|skipn (ci_npar ci) args| = context_assumptions br.(bcontext) -> + P Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + (iota_red ci.(ci_npar) args br)) -> (forall (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term), unfold_fix mfix idx = Some (narg, fn) -> is_constructor narg args = true -> P Γ (mkApps (tFix mfix idx) args) (mkApps fn args)) -> - (forall (Γ : context) (ip : inductive * nat) (p : term) (mfix : mfixpoint term) (idx : nat) - (args : list term) (narg : nat) (fn : term) (brs : list (nat * term)), + (forall (Γ : context) ci (p : predicate term) (mfix : mfixpoint term) (idx : nat) + (args : list term) (narg : nat) (fn : term) (brs : list (branch term)), unfold_cofix mfix idx = Some (narg, fn) -> - P Γ (tCase ip p (mkApps (tCoFix mfix idx) args) brs) (tCase ip p (mkApps fn args) brs)) -> + P Γ (tCase ci p (mkApps (tCoFix mfix idx) args) brs) (tCase ci p (mkApps fn args) brs)) -> (forall (Γ : context) (p : projection) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term), @@ -196,7 +483,7 @@ Lemma red1_ind_all : (forall (Γ : context) c (decl : constant_body) (body : term), declared_constant Σ c decl -> - forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance_constr u body)) -> + forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance u body)) -> (forall (Γ : context) (i : inductive) (pars narg : nat) (args : list term) (u : Instance.t) (arg : term), @@ -218,15 +505,33 @@ Lemma red1_ind_all : (forall (Γ : context) (na : aname) (b t b' r : term), red1 Σ (Γ,, vdef na b t) b' r -> P (Γ,, vdef na b t) b' r -> P Γ (tLetIn na b t b') (tLetIn na b t r)) -> - (forall (Γ : context) (ind : inductive * nat) (p p' c : term) (brs : list (nat * term)), - red1 Σ Γ p p' -> P Γ p p' -> P Γ (tCase ind p c brs) (tCase ind p' c brs)) -> - - (forall (Γ : context) (ind : inductive * nat) (p c c' : term) (brs : list (nat * term)), + (forall (Γ : context) (ci : case_info) p params' c brs, + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) p.(pparams) params' -> + P Γ (tCase ci p c brs) + (tCase ci (set_pparams p params') c brs)) -> + + (forall (Γ : context) (ci : case_info) p pcontext' c brs, + OnOne2_local_env (on_one_decl (fun Γ' => P (Γ ,,, Γ'))) p.(pcontext) pcontext' -> + P Γ (tCase ci p c brs) + (tCase ci (set_pcontext p pcontext') c brs)) -> + + (forall (Γ : context) (ci : case_info) p preturn' c brs, + red1 Σ (Γ ,,, p.(pcontext)) p.(preturn) preturn' -> + P (Γ ,,, p.(pcontext)) 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) (ind : inductive * nat) (p c : term) (brs brs' : list (nat * term)), - OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) snd fst) brs brs' -> - 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 Σ (Γ ,,, br.(bcontext))) (P (Γ ,,, br.(bcontext)))) + bbody bcontext br br') + + (on_Trel_eq (OnOne2_local_env + (on_one_decl (fun Γ' => (P (Γ ,,, Γ'))))) + bcontext bbody br br')) brs brs' -> + P Γ (tCase ci p c brs) (tCase ci p c brs')) -> (forall (Γ : context) (p : projection) (c c' : term), red1 Σ Γ c c' -> P Γ c c' -> P Γ (tProj p c) (tProj p c')) -> @@ -268,7 +573,7 @@ Lemma red1_ind_all : forall (Γ : context) (t t0 : term), red1 Σ Γ t t0 -> P Γ t t0. Proof. - intros. rename X26 into Xlast. revert Γ t t0 Xlast. + intros. rename X28 into Xlast. revert Γ t t0 Xlast. fix aux 4. intros Γ t T. move aux at top. destruct 1; match goal with @@ -283,11 +588,35 @@ Proof. - eapply X4; eauto. - eapply X5; eauto. - - revert brs brs' o. + - revert params' o. + generalize (pparams p). + fix auxl 3. + intros params params' []. + + constructor. split; auto. + + constructor. auto. + + - revert pcontext' o. + generalize (pcontext p). + fix auxl 3. + intros l pctx' []; constructor. + * simpl in *. intuition auto. + * simpl in *. intuition auto. + * apply auxl, o. + + - revert brs' o. + revert brs. fix auxl 3. intros l l' Hl. destruct Hl. - + constructor. intuition auto. - + constructor. intuition auto. + + simpl in *. constructor; intros; intuition auto. + right. split; auto. + revert a. + generalize (bcontext hd) (bcontext hd'). + fix auxl' 3. + intros l pctx' []; constructor. + * simpl in *; intuition auto. + * simpl in *. intuition auto. + * apply auxl', o. + + constructor. eapply auxl. apply Hl. - revert l l' o. fix auxl 3. @@ -295,21 +624,22 @@ Proof. + constructor. split; auto. + constructor. auto. - - eapply X22. - revert mfix0 mfix1 o; fix auxl 3; intros l l' Hl; destruct Hl; - constructor; try split; auto; intuition. + - eapply X24. + revert mfix0 mfix1 o; fix auxl 3. + intros l l' Hl; destruct Hl; + constructor; try split; auto; intuition. - - eapply X23. + - eapply X25. revert o. generalize (fix_context mfix0). intros c Xnew. revert mfix0 mfix1 Xnew; fix auxl 3; intros l l' Hl; destruct Hl; constructor; try split; auto; intuition. - - eapply X24. + - eapply X26. revert mfix0 mfix1 o. fix auxl 3; intros l l' Hl; destruct Hl; constructor; try split; auto; intuition. - - eapply X25. + - eapply X27. revert o. generalize (fix_context mfix0). intros c new. revert mfix0 mfix1 new; fix auxl 3; intros l l' Hl; destruct Hl; constructor; try split; auto; intuition. @@ -319,6 +649,28 @@ Hint Constructors red1 : pcuic. Definition red Σ Γ := clos_refl_trans (red1 Σ Γ). +Definition red_one_ctx_rel (Σ : global_env) (Γ : context) := + OnOne2_local_env + (on_one_decl (fun (Δ : context) (t t' : term) => red Σ (Γ,,, Δ) t t')). + +Definition red_ctx_rel Σ Γ := clos_refl_trans (red1_ctx_rel Σ Γ). + +(* TODO move to All_decls *) +Inductive red_decls Σ (Γ Γ' : context) : forall (x y : context_decl), Type := +| red_vass na T T' : + red Σ Γ T T' -> + red_decls Σ Γ Γ' (vass na T) (vass na T') + +| red_vdef_body na b b' T T' : + red Σ Γ b b' -> + red Σ Γ T T' -> + red_decls Σ Γ Γ' (vdef na b T) (vdef na b' T'). +Derive Signature NoConfusion for red_decls. + +Definition red_context Σ := All2_fold (red_decls Σ). +Definition red_context_rel Σ Γ := + All2_fold (fun Δ Δ' => red_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')). + Lemma refl_red Σ Γ t : red Σ Γ t t. Proof. reflexivity. @@ -371,7 +723,6 @@ Proof. etransitivity; tea. Defined. - (** For this notion of reductions, theses are the atoms that reduce to themselves: *) @@ -408,13 +759,18 @@ Section ReductionCongruence. | tCtxLetIn_r : aname -> term (* the term *) -> term (* the type *) -> term_context -> term_context | tCtxApp_l : term_context -> term -> term_context - | tCtxApp_r : term -> term_context -> term_context - | tCtxCase_pred : (inductive * nat) (* # of parameters *) -> term_context (* type info *) - -> term (* discriminee *) -> list (nat * term) (* branches *) -> term_context - | tCtxCase_discr : (inductive * nat) (* # of parameters *) -> term (* type info *) - -> term_context (* discriminee *) -> list (nat * term) (* branches *) -> term_context - | tCtxCase_branch : (inductive * nat) (* # of parameters *) -> term (* type info *) - -> term (* discriminee *) -> list_nat_context (* branches *) -> term_context + | tCtxApp_r : term -> term_context -> term_context + | 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 -> + context -> (* context of predicate *) + term_context (* type info *) + -> term (* discriminee *) -> list (branch term) (* branches *) -> term_context + | tCtxCase_discr : case_info -> predicate term (* type info *) + -> term_context (* discriminee *) -> list (branch term) (* branches *) -> term_context + | tCtxCase_branch : case_info -> predicate term (* type info *) + -> term (* discriminee *) -> branch_context (* branches *) -> term_context | tCtxProj : projection -> term_context -> term_context (* | tCtxFix : mfixpoint_context -> nat -> term_context harder because types of fixpoints are necessary *) (* | tCtxCoFix : mfixpoint_context -> nat -> term_context *) @@ -423,9 +779,9 @@ Section ReductionCongruence. | tCtxHead : term_context -> list term -> list_context | tCtxTail : term -> list_context -> list_context - with list_nat_context := - | tCtxHead_nat : (nat * term_context) -> list (nat * term) -> list_nat_context - | tCtxTail_nat : (nat * term) -> list_nat_context -> list_nat_context. + with branch_context := + | tCtxHead_nat : (context * term_context) -> list (branch term) -> branch_context + | tCtxTail_nat : (branch term) -> branch_context -> branch_context. (* with mfixpoint_context := *) (* | tCtxHead_mfix : def_context -> list (def term) -> mfixpoint_context *) @@ -435,6 +791,12 @@ Section ReductionCongruence. (* | tCtxType : name -> term_context -> term -> nat -> def_context *) (* | tCtxDef : name -> term -> term_context -> nat -> def_context. *) + Fixpoint branch_contexts (b : branch_context) : list context := + match b with + | tCtxHead_nat (ctx, _) tl => ctx :: map bcontext tl + | tCtxTail_nat b tl => bcontext b :: branch_contexts tl + end. + Section FillContext. Context (t : term). @@ -450,9 +812,18 @@ Section ReductionCongruence. | tCtxLetIn_r na b ty b' => tLetIn na b ty (fill_context b'); | tCtxApp_l f a => tApp (fill_context f) a; | tCtxApp_r f a => tApp f (fill_context a); - | tCtxCase_pred par p c brs => tCase par (fill_context p) c brs; - | tCtxCase_discr par p c brs => tCase par p (fill_context c) brs; - | tCtxCase_branch par p c brs => tCase par p c (fill_list_nat_context brs); + | tCtxCase_pars ci pars puinst pctx pret c brs => + tCase ci {| pparams := fill_list_context pars; + puinst := puinst; + pcontext := pctx; + preturn := pret |} c brs ; + | tCtxCase_pred ci pars puinst pctx p c brs => + tCase ci {| pparams := pars; + puinst := puinst; + pcontext := pctx; + preturn := fill_context p |} c brs ; + | tCtxCase_discr ci p c brs => tCase ci p (fill_context c) brs; + | tCtxCase_branch ci p c brs => tCase ci p c (fill_branch_context brs); | tCtxProj p c => tProj p (fill_context c) } (* | tCtxFix mfix n => tFix (fill_mfix_context mfix) n; *) (* | tCtxCoFix mfix n => tCoFix (fill_mfix_context mfix) n } *) @@ -461,9 +832,11 @@ Section ReductionCongruence. { fill_list_context (tCtxHead ctx l) => (fill_context ctx) :: l; fill_list_context (tCtxTail hd ctx) => hd :: fill_list_context ctx } - with fill_list_nat_context (l : list_nat_context) : list (nat * term) by struct l := - { fill_list_nat_context (tCtxHead_nat (n, ctx) l) => (n, fill_context ctx) :: l; - fill_list_nat_context (tCtxTail_nat hd ctx) => hd :: fill_list_nat_context ctx }. + with fill_branch_context (l : branch_context) : list (branch term) by struct 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 }. (* with fill_mfix_context (l : mfixpoint_context) : mfixpoint term by struct l := *) (* { fill_mfix_context (tCtxHead_mfix (tCtxType na ty def rarg) l) => *) @@ -471,7 +844,7 @@ Section ReductionCongruence. (* fill_mfix_context (tCtxHead_mfix (tCtxDef na ty def rarg) l) => *) (* {| dname := na; dtype := ty; dbody := fill_context def; rarg := rarg |} :: l; *) (* fill_mfix_context (tCtxTail_mfix hd ctx) => hd :: fill_mfix_context ctx }. *) - Global Transparent fill_context fill_list_context fill_list_nat_context. + Global Transparent fill_context fill_list_context fill_branch_context. Equations hole_context (ctx : term_context) (Γ : context) : context by struct ctx := { | tCtxHole | Γ => Γ; @@ -485,9 +858,10 @@ Section ReductionCongruence. | tCtxLetIn_r na b ty b' | Γ => hole_context b' (Γ ,, vdef na b ty); | tCtxApp_l f a | Γ => hole_context f Γ; | tCtxApp_r f a | Γ => hole_context a Γ; - | tCtxCase_pred par p c brs | Γ => hole_context p Γ; - | tCtxCase_discr par p c brs | Γ => hole_context c Γ; - | tCtxCase_branch par p c brs | Γ => hole_list_nat_context brs Γ; + | tCtxCase_pars ci params puinst pctx pret c brs | Γ => hole_list_context params Γ; + | tCtxCase_pred ci params puinst pctx pret c brs | Γ => hole_context pret (Γ ,,, pctx); + | tCtxCase_discr ci p c brs | Γ => hole_context c Γ; + | tCtxCase_branch ci p c brs | Γ => hole_branch_context brs Γ; | tCtxProj p c | Γ => hole_context c Γ } (* | tCtxFix mfix n | Γ => hole_mfix_context mfix Γ ; *) (* | tCtxCoFix mfix n | Γ => hole_mfix_context mfix Γ } *) @@ -496,19 +870,67 @@ Section ReductionCongruence. { hole_list_context (tCtxHead ctx l) Γ => hole_context ctx Γ; hole_list_context (tCtxTail hd ctx) Γ => hole_list_context ctx Γ } - with hole_list_nat_context (l : list_nat_context) (Γ : context) : context by struct l := - { hole_list_nat_context (tCtxHead_nat (n, ctx) l) Γ => hole_context ctx Γ; - hole_list_nat_context (tCtxTail_nat hd ctx) Γ => hole_list_nat_context ctx Γ }. + with hole_branch_context (l : branch_context) (Γ : context) : context by struct l := + { hole_branch_context (tCtxHead_nat (bctx, ctx) l) Γ => hole_context ctx (Γ ,,, bctx); + hole_branch_context (tCtxTail_nat hd ctx) Γ => hole_branch_context ctx Γ }. (* with hole_mfix_context (l : mfixpoint_context) (Γ : context) : context by struct l := *) (* { hole_mfix_context (tCtxHead_mfix (tCtxType na ctx def rarg) _) Γ => hole_context ctx Γ; *) (* hole_mfix_context (tCtxHead_mfix (tCtxDef na ty ctx rarg) _) Γ => hole_context ctx; *) (* hole_mfix_context (tCtxTail_mfix hd ctx) Γ => hole_mfix_context ctx tys Γ }. *) - Global Transparent hole_context hole_list_context hole_list_nat_context. + Global Transparent hole_context hole_list_context hole_branch_context. End FillContext. - Inductive contextual_closure (red : forall Γ, term -> term -> Type) : context -> term -> term -> Type := + Universe wf_context_i. + (*Equations(noeqns noind) wf_context (ctx : term_context) : Type@{wf_context_i} by struct ctx := { + | tCtxHole => True; + | tCtxEvar n l => wf_list_context l; + | tCtxProd_l na ctx b => (wf_context ctx); + | tCtxProd_r na ty ctx => (wf_context ctx); + | tCtxLambda_l na ty b => (wf_context ty); + | tCtxLambda_r na ty b => (wf_context b); + | tCtxLetIn_l na b ty b' => (wf_context b); + | tCtxLetIn_b na b ty b' => (wf_context ty); + | tCtxLetIn_r na b ty b' => (wf_context b'); + | tCtxApp_l f a => (wf_context f); + | 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, + declared_inductive Σ ci.(ci_ind) mdecl idecl * + (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 => + (∑ mdecl idecl, + declared_inductive Σ ci.(ci_ind) mdecl idecl * + wf_predicate mdecl idecl p * + wf_branch_context (ci.(ci_ind), mdecl, idecl, p) idecl.(ind_ctors) brs); + | tCtxProj p c => (wf_context c) } + (* | tCtxFix mfix n => tFix (fill_mfix_context mfix) n; *) + (* | tCtxCoFix mfix n => tCoFix (fill_mfix_context mfix) n } *) + + with wf_list_context (l : list_context) : Type@{wf_context_i} by struct l := + { | (tCtxHead ctx l) => (wf_context ctx); + | (tCtxTail hd ctx) => wf_list_context ctx } + + 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) => + Forall2 wf_branch cdecls l * + wf_predicate mdecl idecl p * + (case_branch_context ind mdecl p bctx cdecl = bfullctx) * + wf_branch_gen cdecl bctx * + wf_context ctx; + | p | cdecl :: cdecls | (tCtxTail_nat hd ctx) => + wf_branch cdecl hd * wf_branch_context p cdecls ctx }.*) + + Inductive contextual_closure (red : forall Γ, term -> term -> Type) : context -> term -> term -> Type@{wf_context_i} := | ctxclos_atom Γ t : atom t -> contextual_closure red Γ t t | ctxclos_ctx Γ (ctx : term_context) (u u' : term) : red (hole_context ctx Γ) u u' -> contextual_closure red Γ (fill_context u ctx) (fill_context u' ctx). @@ -521,23 +943,40 @@ Section ReductionCongruence. Arguments fill_list_context : simpl never. - Lemma contextual_closure_red Γ t u : contextual_closure (red Σ) Γ t u -> red Σ Γ t u. + (* 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. + induction ctors in b |- *; destruct b; simpl; auto; + destruct p as [[[? ?] ?] ?]. + - destruct p0 as [[? ?] ?]. + simpl. intros [[[[] ?] ?] ?]. + constructor; auto. + - intros []. constructor; auto. + Qed. *) + + Lemma contextual_closure_red Γ t u : + contextual_closure (red Σ) Γ t u -> red Σ Γ t u. Proof. induction 1; trea. apply clos_rt_rt1n in r. induction r; trea. apply clos_rt_rt1n_iff in r0. etransitivity; tea. constructor. clear -r. - set (P := fun ctx t => forall Γ y, red1 Σ (hole_context ctx Γ) x y -> - red1 Σ Γ t (fill_context y ctx)). + set (P := fun ctx t => + forall Γ y, red1 Σ (hole_context ctx Γ) x y -> + red1 Σ Γ t (fill_context y ctx)). set (P' := fun l fill_l => - forall Γ y, + forall Γ y, red1 Σ (hole_list_context l Γ) x y -> OnOne2 (red1 Σ Γ) fill_l (fill_list_context y l)). set (P'' := fun l fill_l => - forall Γ y, - red1 Σ (hole_list_nat_context l Γ) x y -> - OnOne2 (on_Trel_eq (red1 Σ Γ) snd fst) fill_l (fill_list_nat_context y l)). + forall Γ y, + red1 Σ (hole_branch_context l Γ) x y -> + OnOne2 (fun br br' => + let brctx := br.(bcontext) in + on_Trel_eq (red1 Σ (Γ ,,, brctx)) bbody bcontext br br') + fill_l (fill_branch_context y l)). (* set (Pfix := fun l fixc fill_l => *) (* forall Γ y, *) (* red1 Σ (hole_mfix_context l fixc Γ) x y -> *) @@ -548,6 +987,9 @@ Section ReductionCongruence. revert Γ y r. eapply (fill_context_elim x P P' P''); subst P P' P''; cbv beta; intros **; simp fill_context; cbn in *; auto; try solve [constructor; eauto]. + eapply case_red_brs. + specialize (X _ _ X0). + solve_all. Qed. Theorem red_contextual_closure_equiv Γ t u : red Σ Γ t u <~> contextual_closure (red Σ) Γ t u. @@ -557,8 +999,9 @@ Section ReductionCongruence. - apply contextual_closure_red. Qed. - Lemma red_ctx {Γ} {M M'} ctx : red Σ (hole_context ctx Γ) M M' -> - red Σ Γ (fill_context M ctx) (fill_context M' ctx). + Lemma red_ctx_congr {Γ} {M M'} ctx : + red Σ (hole_context ctx Γ) M M' -> + red Σ Γ (fill_context M ctx) (fill_context M' ctx). Proof. intros. apply red_contextual_closure_equiv. @@ -567,19 +1010,55 @@ Section ReductionCongruence. Section Congruences. - Inductive redl Γ {A} l : list (term × A) -> Type := - | refl_redl : redl Γ l l + Notation red1_one_term Γ := + (@OnOne2 (term × _) (Trel_conj (on_Trel (red1 Σ Γ) fst) (on_Trel eq snd))). + 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 Σ Γ := + (OnOne2_local_env (on_one_decl (fun Δ t t' => red Σ (Γ ,,, Δ) t t'))). + + Notation red_one_context_decl Γ := + (@OnOne2 (context × _) + (Trel_conj (on_Trel (red_ctx_rel Σ Γ) fst) (on_Trel eq snd))). + + Notation red1_one_branch Γ := + (@OnOne2 _ (fun br br' => + let ctx := snd br in + Trel_conj (on_Trel (red1 Σ (Γ ,,, ctx)) fst) (on_Trel eq snd) br br')). + Notation red_one_branch Γ := + (@OnOne2 _ (fun br br' => + let ctx := snd br in + Trel_conj (on_Trel (red Σ (Γ ,,, ctx)) fst) (on_Trel eq snd) br br')). + + Inductive redl {T A} {P} l : list (T × A) -> Type := + | refl_redl : redl l l | trans_redl : forall l1 l2, - redl Γ l l1 -> - OnOne2 (Trel_conj (on_Trel (red1 Σ Γ) fst) (on_Trel eq snd)) l1 l2 -> - redl Γ l l2. + redl l l1 -> + P l1 l2 -> + redl l l2. + Derive Signature for redl. + 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. + intros HP. induction 1; auto. + rewrite IHX. now apply HP. + Qed. + Definition redl_term {A} Γ := @redl term A (red1_one_term Γ). + Definition redl_context {A} Γ := @redl context A (red1_one_context_decl Γ). + Definition redl_branch Γ := @redl term _ (red1_one_branch Γ). + Lemma OnOne2_red_redl : forall Γ A (l l' : list (term × A)), - OnOne2 (Trel_conj (on_Trel (red Σ Γ) fst) (on_Trel eq snd)) l l' -> - redl Γ l l'. + red_one_term Γ l l' -> + redl_term Γ l l'. Proof. intros Γ A l l' h. induction h. @@ -598,16 +1077,175 @@ Section ReductionCongruence. + econstructor ; eauto. constructor ; eauto. Qed. + Definition cons_decl {A} (d : context_decl) (l : list (context × A)) := + match l with + | [] => [] + | (Γ , a) :: tl => (Γ ,, d, a) :: tl + end. + + Lemma redl_context_impl {A} Γ (l l' : list (context × A)) : + redl_context Γ l l' -> + forall d, redl_context Γ (cons_decl d l) (cons_decl d l'). + Proof. + induction 1; intros. + - constructor. + - econstructor. + * eapply IHX. + * depelim p; simpl. + + destruct hd, hd'. destruct p. + constructor; unfold on_Trel in *; simpl in *. + split; auto. now constructor. + + destruct hd. now constructor. + Qed. + + Lemma redl_context_trans {A} Γ (l l' l'' : list (context × A)) : + redl_context Γ l l' -> redl_context Γ l' l'' -> redl_context Γ l l''. + Proof. + intros Hl Hl'. + induction Hl' in l, Hl |- *; intros; tas. + econstructor. + * now eapply IHHl'. + * apply p. + Qed. + + Lemma red_one_context_redl : + forall Γ A (l l' : list (context × A)), + red_one_context_decl Γ l l' -> + redl_context Γ l l'. + Proof. + intros Γ A l l' h. + induction h. + - destruct p as [p1 p2]. + unfold on_Trel in p1, p2. + 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 p. unfold redl_context. + econstructor. + 2:{ constructor. unfold on_Trel. simpl. + instantiate (1 := (Γ0 ,, vass na t, a')). + simpl. intuition auto. constructor. + red. apply p. } + constructor. + * red in p. + destruct p as [<- [[]|[]]]; subst. + { econstructor. + 2:{ constructor. unfold on_Trel. simpl. + instantiate (1 := (Γ0 ,, vdef na b' t, a')). + simpl. intuition auto. constructor. simpl. + intuition auto. } + constructor. } + { econstructor. + 2:{ constructor. unfold on_Trel. simpl. + instantiate (1 := (Γ0 ,, vdef na b t', a')). + simpl. intuition auto. constructor. simpl. + intuition auto. } + constructor. } + * clear -IHr. + eapply (redl_context_impl _ _ _ IHr). + + constructor. + + eapply redl_context_trans; eauto. + - clear h. rename IHh into h. + induction h. + + constructor. + + econstructor ; eauto. constructor ; eauto. + Qed. + + Lemma red_one_decl_red_ctx_rel Γ : + inclusion (red_one_ctx_rel Σ Γ) (red_ctx_rel Σ Γ). + Proof. + intros x y h. + induction h. + - destruct p. subst. red. + eapply clos_rt_rt1n in r. + induction r. + * constructor 2. + * econstructor 3; tea. constructor. constructor; simpl. + split; pcuic. + - destruct p as [-> [[r <-]|[r <-]]]. + * eapply clos_rt_rt1n in r. + induction r. + + constructor 2. + + econstructor 3; tea. constructor. constructor; simpl. + split; pcuic. + * eapply clos_rt_rt1n in r. + induction r. + + constructor 2. + + econstructor 3; tea. + do 3 constructor; pcuic. + - red in IHh |- *. + eapply clos_rt_rtn1 in IHh. + eapply clos_rt_rtn1_iff. + clear -IHh. induction IHh; econstructor; eauto. + red. constructor. apply r. + Qed. + + Lemma OnOne2All_red_redl : + forall Γ (l l' : list (term × context)), + red_one_branch Γ l l' -> + redl_branch Γ l l'. + Proof. + intros Γ l l' h. + induction h. + - destruct p as [p1 p2]. + unfold on_Trel in p1, p2. + destruct hd as [t a], hd' as [t' a']. simpl in *; subst. + induction p1 using red_rect'. + + constructor. + + econstructor. + * eapply IHp1. + * constructor; intuition eauto. + depelim IHp1. + ++ split; auto. split; auto. + ++ split; auto. split; auto. + - clear h. rename IHh into h. + induction h. + + constructor. + + econstructor ; eauto. constructor ; eauto. + Qed. + + Lemma OnOne2_on_Trel_eq_unit : + forall A (R : A -> A -> Type) l l', + OnOne2 R l l' -> + OnOne2 (on_Trel_eq R (fun x => x) (fun x => tt)) l l'. + Proof. + intros A R l l' h. + eapply OnOne2_impl ; eauto. + Qed. + Lemma OnOne2_on_Trel_eq_red_redl : forall Γ A B (f : A -> term) (g : A -> B) l l', OnOne2 (on_Trel_eq (red Σ Γ) f g) l l' -> - redl Γ (map (fun x => (f x, g x)) l) (map (fun x => (f x, g x)) l'). + redl_term Γ (map (fun x => (f x, g x)) l) (map (fun x => (f x, g x)) l'). Proof. intros Γ A B f g l l' h. eapply OnOne2_red_redl. eapply OnOne2_map. eapply OnOne2_impl ; eauto. Qed. + Lemma OnOne2_context_redl Γ {A B} (f : A -> context) (g : A -> B) l l' : + OnOne2 (on_Trel_eq (red_ctx_rel Σ Γ) f g) l l' -> + redl_context Γ (map (fun x => (f x, g x)) l) (map (fun x => (f x, g x)) l'). + Proof. + intros h. eapply red_one_context_redl. + eapply OnOne2_map. + eapply OnOne2_impl; eauto. + Qed. + + Lemma OnOne2All_on_Trel_eq_red_redl : + forall Γ l l', + OnOne2 (fun br br' => + let ctx := br.(bcontext) in + on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') l l' -> + redl_branch Γ (map (fun x => (bbody x, bcontext x)) l) + (map (fun x => (bbody x, bcontext x)) l'). + Proof. + intros Γ l l' h. + eapply OnOne2All_red_redl. + eapply OnOne2_map. eapply OnOne2_impl ; eauto. + Qed. + Lemma OnOne2_prod_inv : forall A (P : A -> A -> Type) Q l l', OnOne2 (Trel_conj P Q) l l' -> @@ -666,27 +1304,66 @@ Section ReductionCongruence. destruct a, p. simpl in *. subst. reflexivity. Qed. - Notation swap := (fun x => (snd x, fst x)). - + Notation decomp_branch := (fun x : branch term => (bbody x, bcontext x)). + 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 A B (l l' : list (A × B)), - map swap l = map swap l' -> + forall l l', + map decomp_branch l = map decomp_branch l' -> l = l'. Proof. - intros A B l l' h. + intros l l' h. induction l in l', h |- *. - destruct l' ; try discriminate. reflexivity. - destruct l' ; try discriminate. cbn in h. inversion h. f_equal ; eauto. - destruct a, p. cbn in *. subst. reflexivity. + destruct a, b. cbn in *. subst. reflexivity. + Qed. + + Lemma list_map_swap_eq' : + forall l l', + map decomp_branch' l = map decomp_branch' l' -> + l = l'. + Proof. + intros l l' h. + induction l in l', h |- *. + - destruct l' ; try discriminate. reflexivity. + - destruct l' ; try discriminate. + cbn in h. inversion h. + f_equal ; eauto. + destruct a, b. cbn in *. subst. reflexivity. + Qed. + + Lemma map_recomp_decomp : + forall l, l = map decomp_branch (map recomp_branch l). + Proof. + induction l. + - reflexivity. + - cbn. destruct a. rewrite <- IHl. reflexivity. + Qed. + + Lemma map_recomp_decomp' : + forall l, l = map decomp_branch' (map recomp_branch' l). + Proof. + induction l. + - reflexivity. + - cbn. destruct a. rewrite <- IHl. reflexivity. Qed. - Lemma map_swap_invol : - forall A B (l : list (A × B)), - l = map swap (map swap l). + Lemma map_decomp_recomp : + forall l, l = map recomp_branch (map decomp_branch l). + Proof. + induction l. + - reflexivity. + - cbn. destruct a. rewrite <- IHl. reflexivity. + Qed. + + Lemma map_decomp_recomp' : + forall l, l = map recomp_branch' (map decomp_branch' l). Proof. - intros A B l. induction l. - reflexivity. - cbn. destruct a. rewrite <- IHl. reflexivity. @@ -712,8 +1389,8 @@ Section ReductionCongruence. -> red Σ Γ (tLambda na M N) (tLambda na M' N'). Proof. intros. transitivity (tLambda na M' N). - - now apply (red_ctx (tCtxLambda_l _ tCtxHole _)). - - now eapply (red_ctx (tCtxLambda_r _ _ tCtxHole)). + - now apply (red_ctx_congr (tCtxLambda_l _ tCtxHole _)). + - now eapply (red_ctx_congr (tCtxLambda_r _ _ tCtxHole)). Qed. Lemma red_app_r u v1 v2 : @@ -729,8 +1406,8 @@ Section ReductionCongruence. red Σ Γ (tApp M0 N0) (tApp M1 N1). Proof. intros; transitivity (tApp M1 N0). - - now apply (red_ctx (tCtxApp_l tCtxHole _)). - - now eapply (red_ctx (tCtxApp_r _ tCtxHole)). + - now apply (red_ctx_congr (tCtxApp_l tCtxHole _)). + - now eapply (red_ctx_congr (tCtxApp_r _ tCtxHole)). Qed. Fixpoint mkApps_context l := @@ -785,60 +1462,229 @@ Section ReductionCongruence. red Σ Γ (tLetIn na d0 t0 b0) (tLetIn na d1 t1 b1). Proof. intros; transitivity (tLetIn na d1 t0 b0). - - now apply (red_ctx (tCtxLetIn_l _ tCtxHole _ _)). + - now apply (red_ctx_congr (tCtxLetIn_l _ tCtxHole _ _)). - transitivity (tLetIn na d1 t1 b0). - + now eapply (red_ctx (tCtxLetIn_b _ _ tCtxHole _)). - + now eapply (red_ctx (tCtxLetIn_r _ _ _ tCtxHole)). + + 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' -> + red Σ Γ (tCase ci p c brs) (tCase ci (set_pparams p pars') c brs). + Proof. + intros ci p c l l' h. + apply OnOne2_on_Trel_eq_unit in h. + apply OnOne2_on_Trel_eq_red_redl in h. + dependent induction h. + - assert (p.(pparams) = l'). + { eapply map_inj ; eauto. + intros y z e. cbn in e. inversion e. eauto. + } subst. + destruct p; reflexivity. + - set (f := fun x : term => (x, tt)) in *. + set (g := (fun '(x, _) => x) : term × unit -> term). + assert (el : forall l, l = map f (map g l)). + { clear. intros l. induction l. + - reflexivity. + - cbn. destruct a, u. cbn. f_equal. assumption. + } + assert (el' : forall l, l = map g (map f l)). + { clear. intros l. induction l. + - reflexivity. + - cbn. f_equal. assumption. + } + eapply trans_red. + + eapply IHh; tas. symmetry. apply el. + + change (set_pparams p l') with (set_pparams (set_pparams p (map g l1)) l'). + econstructor. rewrite (el' l'). + eapply OnOne2_map. + eapply OnOne2_impl ; eauto. + intros [? []] [? []] [h1 h2]. + unfold on_Trel in h1, h2. cbn in *. + unfold on_Trel. cbn. assumption. + Qed. + + Lemma red_case_pars : + forall ci p c brs pars', + All2 (red Σ Γ) p.(pparams) pars' -> + red Σ Γ (tCase ci p c brs) (tCase ci (set_pparams p pars') c brs). + Proof. + intros ci p c brs pars' h. + apply All2_many_OnOne2 in h. + induction h. + - destruct p; reflexivity. + - eapply red_trans. + + eapply IHh. + + assert (set_pparams p z = set_pparams (set_pparams p y) z) as ->. + { now destruct p. } + eapply red_one_param; eassumption. + Qed. + + Coercion ci_ind : case_info >-> inductive. + + Lemma red_one_pcontext : + forall ci p c brs pcontext', + red1_ctx_rel Σ Γ p.(pcontext) pcontext' -> + red Σ Γ (tCase ci p c brs) (tCase ci (set_pcontext p pcontext') c brs). + Proof. + intros ci p c l l' h. + red in h. + constructor. + now constructor. + Qed. + + Lemma red_case_pcontext_red_ctx_rel : + forall ci p c brs pcontext', + red_ctx_rel Σ Γ p.(pcontext) pcontext' -> + red Σ Γ (tCase ci p c brs) (tCase ci (set_pcontext p pcontext') c brs). + Proof. + intros ci p c brs pars' h. + red in h. eapply clos_rt_rtn1_iff in h. + induction h. + - destruct p; reflexivity. + - eapply red_trans. + + eapply IHh. + + assert (set_pcontext p z = set_pcontext (set_pcontext p y) z) as ->. + { 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')) + p.(pcontext) pcontext' -> + red Σ Γ (tCase ci p c brs) (tCase ci (set_pcontext p pcontext') c brs). + Proof. + intros ci p c l l' h. + eapply red_one_decl_red_ctx_rel in h. + now eapply red_case_pcontext_red_ctx_rel. Qed. Lemma red_case_p : - forall indn p c brs p', - red Σ Γ p p' -> - red Σ Γ (tCase indn p c brs) (tCase indn p' c brs). + forall ci p c brs pret', + red Σ (Γ ,,, p.(pcontext)) p.(preturn) pret' -> + red Σ Γ (tCase ci p c brs) + (tCase ci (set_preturn p pret') c brs). Proof. - intros indn p c brs p' h. - rst_induction h; eauto with pcuic. + intros ci p c brs p' h. + 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. Qed. Lemma red_case_c : - forall indn p c brs c', + forall ci p c brs c', red Σ Γ c c' -> - red Σ Γ (tCase indn p c brs) (tCase indn p c' brs). + red Σ Γ (tCase ci p c brs) (tCase ci p c' brs). Proof. - intros indn p c brs c' h. + intros ci p c brs c' h. rst_induction h; eauto with pcuic. Qed. + + Lemma map_bcontext_redl {l l' : list (term * context)} : + @redl _ _ (red1_one_branch Γ) l l' -> map snd l = map snd l'. + Proof. + induction 1; auto. rewrite IHX. + clear -p . + induction p; simpl. + - destruct p as [? ?]. congruence. + - now f_equal. + Qed. - Derive Signature for redl. + (* Lemma wf_branches_to_gen idecl brs : + wf_branches idecl brs <-> + wf_branches_gen idecl.(ind_ctors) (map bcontext brs). + Proof. + split. + - induction 1; constructor; auto. + - unfold wf_branches_gen. + rewrite -(map_id (ind_ctors idecl)). + intros H; eapply Forall2_map_inv in H. red. + solve_all. + Qed. *) + + Lemma OnOne2All_disj_on_Trel_eq_red_redl : + forall l l', + OnOne2 (fun br br' => + let ctx := br.(bcontext) in + on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br' + + on_Trel_eq (red_ctx_rel Σ Γ) + bcontext bbody br br') l l' -> + OnOne2 (fun br br' => + let ctx := br.(bcontext) in + on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') l l' + + OnOne2 (on_Trel_eq (red_ctx_rel Σ Γ) + bcontext bbody) l l'. + Proof. + intros l l'; induction 1. + - destruct p; [left|right]; constructor; auto. + - destruct IHX; [left|right]; constructor; auto. + Qed. Lemma red_case_one_brs : - forall indn p c brs brs', - OnOne2 (on_Trel_eq (red Σ Γ) snd fst) brs brs' -> - red Σ Γ (tCase indn p c brs) (tCase indn p c brs'). + forall (ci : case_info) p c brs brs', + OnOne2 (fun br br' => + let brctx := br.(bcontext) in + on_Trel_eq (red Σ (Γ ,,, brctx)) bbody bcontext br br' + + on_Trel_eq (red_ctx_rel Σ Γ) bcontext bbody br br') + brs brs' -> + red Σ Γ (tCase ci p c brs) (tCase ci p c brs'). Proof. - intros indn p c brs brs' h. - apply OnOne2_on_Trel_eq_red_redl in h. - dependent induction h. - - apply list_map_swap_eq in H. now subst. - - etransitivity. - + eapply IHh. rewrite <- map_swap_invol. reflexivity. - + constructor. constructor. rewrite (map_swap_invol _ _ brs'). - eapply OnOne2_map. - eapply OnOne2_impl ; eauto. + intros ci p c brs brs' h. + apply OnOne2All_disj_on_Trel_eq_red_redl in h as [h|h]. + * apply OnOne2All_on_Trel_eq_red_redl in h. + dependent induction h. + - apply list_map_swap_eq in H. now subst. + - etransitivity. + + eapply IHh; eauto. rewrite <- map_recomp_decomp. reflexivity. + + constructor. econstructor; eauto. + rewrite (map_decomp_recomp brs'). + eapply OnOne2_map. + eapply OnOne2_impl ; eauto. unfold on_Trel. + intros [] [] []; simpl in *. subst. + intuition auto. + * eapply OnOne2_context_redl in h. + dependent induction h. + - apply list_map_swap_eq' in H. now subst. + - etransitivity. + + eapply IHh. rewrite <- map_recomp_decomp'. reflexivity. + + constructor. econstructor; eauto. + rewrite (map_decomp_recomp' brs'). + eapply OnOne2_map. + eapply OnOne2_impl; tea. unfold on_Trel. + intros [] [] []; simpl in *; subst. + intuition auto. Qed. - Inductive rtrans_clos {A} (R : A -> A -> Type) (x : A) : A -> Type := - | rtrans_clos_refl : rtrans_clos R x x - | rtrans_clos_trans : - forall y z, - rtrans_clos R x y -> - R y z -> - rtrans_clos R x z. + Lemma All3_length {A B C} {R : A -> B -> C -> Type} l l' l'' : + All3 R l l' l'' -> #|l| = #|l'| /\ #|l'| = #|l''|. + Proof. induction 1; simpl; intuition auto. Qed. - Lemma All2_many_OnOne2 : - forall A (R : A -> A -> Type) l l', - All2 R l l' -> - rtrans_clos (OnOne2 R) l l'. + Lemma All3_many_OnOne2All : + forall B A (R : B -> A -> A -> Type) lΔ l l', + All3 R lΔ l l' -> + rtrans_clos (OnOne2All R lΔ) l l'. + Proof. + intros B A R lΔ l l' h. + induction h. + - constructor. + - econstructor. + + constructor; [eassumption|]. + eapply All3_length in h; intuition eauto. now transitivity #|l'|. + + clear - IHh. rename IHh into h. + induction h. + * constructor. + * econstructor. + -- econstructor 2. eassumption. + -- eassumption. + Qed. + (* Lemma All2_many_OnOne2All : + forall B A (R : B -> A -> A -> Type) lΔ l l', + All2 (R l l' -> + rtrans_clos (OnOne2All R lΔ) l l'. Proof. intros A R l l' h. induction h. @@ -851,27 +1697,75 @@ Section ReductionCongruence. * econstructor. -- eassumption. -- econstructor. assumption. + Qed. *) + + Definition red_brs_disj Γ brs brs' := + OnOne2 (fun br br' => + let ctx := br.(bcontext) in + on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br' + + on_Trel_eq (red_ctx_rel Σ Γ) bcontext bbody br br') + brs brs'. + + Definition red_brs Γ brs brs' := + All2 (fun br br' => + Trel_conj (on_Trel (red Σ (Γ ,,, br.(bcontext))) bbody) + (on_Trel (red_ctx_rel Σ Γ) bcontext) br br') + brs brs'. + + 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. + Proof. + intros HR x y h. + eapply clos_rt_rtn1_iff in h. + induction h; eauto. + * econstructor. + * apply clos_rt_rtn1_iff. + apply clos_rt_rtn1_iff in IHh1. + apply clos_rt_rtn1_iff in IHh2. + now transitivity y. + Qed. + + Lemma red_brs_disj_red_brs brs brs' : + red_brs Γ brs brs' -> + rtrans_clos (red_brs_disj Γ) brs brs'. + Proof. + rewrite /red_brs. + intros h. + eapply All2_many_OnOne2 in h. + eapply rtrans_clos_incl; tea. clear h. + intros x y h. + eapply clos_rt_rtn1_iff. + induction h. + * destruct p. + etransitivity. + - constructor. constructor. left. + instantiate (1 := {| bcontext := bcontext hd; bbody := bbody hd' |}). + simpl. split; auto. + - constructor. + constructor. right. simpl. + split; auto. + * clear -IHh. rename IHh into h. + induction h. + - constructor 1. constructor 2. apply r. + - constructor 2. + - econstructor 3; eauto. Qed. Lemma red_case_brs : - forall indn p c brs brs', - All2 (on_Trel_eq (red Σ Γ) snd fst) brs brs' -> - red Σ Γ (tCase indn p c brs) (tCase indn p c brs'). + forall ci p c brs brs', + red_brs Γ brs brs' -> + red Σ Γ (tCase ci p c brs) (tCase ci p c brs'). Proof. - intros indn p c brs brs' h. - apply All2_many_OnOne2 in h. + intros ci p c brs brs' h. + eapply red_brs_disj_red_brs in h. induction h; trea. - eapply red_trans. - + eapply IHh. - + eapply red_case_one_brs. assumption. + + eapply red_trans. + * eapply IHh. + * eapply red_case_one_brs; eauto. Qed. - (* Fixpoint brs_n_context l := *) - (* match l with *) - (* | [] => tCtxHole *) - (* | hd :: tl => tCtxApp_l (mkApps_context tl) hd *) - (* end. *) - Lemma All2_ind_OnOne2 {A} P (l l' : list A) : All2 P l l' -> forall x a a', nth_error l x = Some a -> @@ -889,19 +1783,22 @@ Section ReductionCongruence. simpl. constructor. auto. Qed. - Lemma red_case : - forall indn p c brs p' c' brs', - red Σ Γ p p' -> - red Σ Γ c c' -> - All2 (on_Trel_eq (red Σ Γ) snd fst) brs brs' -> - red Σ Γ (tCase indn p c brs) (tCase indn p' c' brs'). + Lemma red_case {ci p c brs pars' pcontext' pret' c' brs'} : + red Σ (Γ ,,, p.(pcontext)) p.(preturn) pret' -> + red_ctx_rel Σ Γ p.(pcontext) pcontext' -> + All2 (red Σ Γ) p.(pparams) pars' -> + red Σ Γ c c' -> + red_brs Γ brs brs' -> + red Σ Γ (tCase ci p c brs) + (tCase ci {| pparams := pars'; puinst := p.(puinst); + pcontext := pcontext'; preturn := pret' |} c' brs'). Proof. - intros indn p c brs p' c' brs' h1 h2 h3. - eapply red_trans. - - eapply red_case_brs. eassumption. - - eapply red_trans. - + eapply red_case_c. eassumption. - + eapply red_case_p. assumption. + intros h1 h2 h3 h4 h5. + eapply red_trans; [eapply red_case_brs|]; eauto. + eapply red_trans; [eapply red_case_c|]; eauto. + eapply red_trans; [eapply red_case_p|]; eauto. + eapply red_trans; [eapply red_case_pars|]; eauto. + eapply red_trans; [eapply red_case_pcontext_red_ctx_rel|]; eauto. Qed. Lemma red1_it_mkLambda_or_LetIn : @@ -1052,7 +1949,7 @@ Section ReductionCongruence. - rewrite IHh. unfold fix_context. f_equal. assert (e : map snd l1 = map snd l2). - { clear - o. induction o. + { clear - p. induction p. - destruct p as [h1 h2]. unfold on_Trel in h2. cbn. f_equal. assumption. - cbn. f_equal. assumption. @@ -1237,7 +2134,7 @@ Section ReductionCongruence. - rewrite IHh. unfold fix_context. f_equal. assert (e : map snd l1 = map snd l2). - { clear - o. induction o. + { clear - p. induction p. - destruct p as [h1 h2]. unfold on_Trel in h2. cbn. f_equal. assumption. - cbn. f_equal. assumption. @@ -1362,15 +2259,6 @@ Section ReductionCongruence. - eapply red_prod_l. assumption. Qed. - Lemma OnOne2_on_Trel_eq_unit : - forall A (R : A -> A -> Type) l l', - OnOne2 R l l' -> - OnOne2 (on_Trel_eq R (fun x => x) (fun x => tt)) l l'. - Proof. - intros A R l l' h. - eapply OnOne2_impl ; eauto. - Qed. - Lemma red_one_evar : forall ev l l', OnOne2 (red Σ Γ) l l' -> @@ -1429,44 +2317,7 @@ Section ReductionCongruence. End Congruences. End ReductionCongruence. - -Lemma red_rel_all Σ Γ i body t : - option_map decl_body (nth_error Γ i) = Some (Some body) -> - red Σ Γ t (lift 1 i (t {i := body})). -Proof. - induction t using term_forall_list_ind in Γ, i |- *; intro H; cbn; - eauto using red_prod, red_abs, red_app, red_letin, red_proj_c. - - case_eq (i <=? n); intro H0. - + apply Nat.leb_le in H0. - case_eq (n - i); intros; cbn. - * apply red1_red. - rewrite simpl_lift; cbn; try lia. - assert (n = i) by lia; subst. now constructor. - * enough (nth_error (@nil term) n0 = None) as ->; - [cbn|now destruct n0]. - enough (i <=? n - 1 = true) as ->; try (apply Nat.leb_le; lia). - enough (S (n - 1) = n) as ->; try lia. auto. - + cbn. rewrite H0. auto. - - eapply red_evar. repeat eapply All2_map_right. - eapply All_All2; tea. intro; cbn; eauto. - - eapply red_case; eauto. repeat eapply All2_map_right. - eapply All_All2; tea. intro; cbn; eauto. - - eapply red_fix_congr. repeat eapply All2_map_right. - eapply All_All2; tea. intros; cbn in *; rdest; eauto. - rewrite map_length. eapply r0. - rewrite nth_error_app_context_ge; rewrite fix_context_length; try lia. - enough (#|m| + i - #|m| = i) as ->; tas; lia. - - eapply red_cofix_congr. repeat eapply All2_map_right. - eapply All_All2; tea. intros; cbn in *; rdest; eauto. - rewrite map_length. eapply r0. - rewrite nth_error_app_context_ge; rewrite fix_context_length; try lia. - enough (#|m| + i - #|m| = i) as ->; tas; lia. -Qed. - - - Hint Resolve All_All2 : all. - Hint Resolve All2_same : pred. Lemma OnOne2_All2 {A}: @@ -1488,6 +2339,39 @@ Ltac OnOne2_All2 := 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 -> + l = firstn n l ++ [t] ++ skipn (S n) l. +Proof. induction l in n |- *; destruct n; simpl; try congruence. + intros. specialize (IHl _ H). + now simpl in IHl. +Qed. + +Lemma split_nth {A B} {l : list A} (l' l'' : list B) : + (#|l| = #|l'| + S (#|l''|))%nat -> + ∑ x, (nth_error l #|l'| = Some x) * (l = firstn #|l'| l ++ x :: skipn (S #|l'|) l). +Proof. + induction l in l', l'' |- *; simpl; auto. + - rewrite Nat.add_succ_r //. + - rewrite Nat.add_succ_r => [= len]. + destruct l'; simpl. + * exists a; auto. + * simpl in len. rewrite -Nat.add_succ_r in len. + specialize (IHl _ _ len) as [x eq]. + 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 : + 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) * + (f lx l'x = x). +Proof. + induction l in l', n, x |- *; destruct l', n; simpl; auto => //. + intros [= <-]. + eexists _, _; intuition eauto. +Qed. + (* TODO Find a better place for this. *) Require Import PCUICPosition. Section Stacks. @@ -1495,49 +2379,82 @@ Section Stacks. Context (Σ : global_env_ext). Context `{checker_flags}. + Lemma red1_fill_context_hole Γ π pcontext u v : + red1 Σ (Γ,,, stack_context π,,, context_hole_context pcontext) u v -> + OnOne2_local_env (on_one_decl (fun Γ' => red1 Σ (Γ,,, stack_context π,,, Γ'))) + (fill_context_hole pcontext u) + (fill_context_hole pcontext v). + Proof. + intros r. + destruct pcontext as ((?&[])&pre); cbn -[app_context] in *. + all: rewrite - !app_context_assoc. + - induction pre; cbn. + + destruct body; constructor; cbn; intuition auto. + + apply onone2_localenv_cons_tl; auto. + - induction pre; cbn. + + constructor; cbn; intuition auto. + + apply onone2_localenv_cons_tl; auto. + Qed. + Lemma red1_context : forall Γ t u π, red1 Σ (Γ ,,, stack_context π) t u -> red1 Σ Γ (zip (t, π)) (zip (u, π)). Proof. intros Γ t u π h. - cbn. revert t u h. - induction π ; intros u v h. - all: try solve [ cbn ; apply IHπ ; constructor ; assumption ]. - - cbn. assumption. - - cbn. apply IHπ. constructor. - apply OnOne2_app. constructor. - simpl. intuition eauto. - - cbn. apply IHπ. eapply fix_red_body. - apply OnOne2_app. constructor. - simpl in *. - rewrite fix_context_fix_context_alt. - rewrite map_app. cbn. unfold def_sig at 2. simpl. - rewrite app_context_assoc in h. - intuition eauto. - - cbn. apply IHπ. constructor. - apply OnOne2_app. constructor. - simpl. intuition eauto. - - cbn. apply IHπ. eapply cofix_red_body. - apply OnOne2_app. constructor. - simpl in *. - rewrite fix_context_fix_context_alt. - rewrite map_app. cbn. unfold def_sig at 2. simpl. - rewrite app_context_assoc in h. - intuition eauto. - - cbn. apply IHπ. constructor. - apply OnOne2_app. constructor. - simpl. intuition eauto. + unfold zip. + simpl. revert t u h. + induction π ; intros u v h; auto. + simpl in *. + destruct a. + all: apply IHπ; simpl; pcuic. + - destruct mfix as ((?&[])&?); cbn in *; + [apply fix_red_ty|apply fix_red_body]. + all: apply OnOne2_app; constructor; cbn; auto. + intuition auto. + rewrite fix_context_fix_context_alt map_app. + unfold def_sig at 2. + cbn. + rewrite -app_context_assoc; auto. + - destruct mfix as ((?&[])&?); cbn in *; + [apply cofix_red_ty|apply cofix_red_body]. + all: apply OnOne2_app; constructor; cbn; auto. + intuition auto. + rewrite fix_context_fix_context_alt map_app. + unfold def_sig at 2. + cbn. + rewrite -app_context_assoc; auto. + - destruct p; cbn in *. + + apply case_red_param; cbn. + apply OnOne2_app. + constructor; auto. + + apply case_red_pcontext; cbn. + apply red1_fill_context_hole; auto. + rewrite -app_context_assoc; auto. + + apply case_red_return; cbn. + rewrite -app_assoc in h; auto. + - destruct brs as ((?&[])&?); cbn in *. + + apply case_red_brs. + apply OnOne2_app. + constructor; cbn. + right. + intuition auto. + apply red1_fill_context_hole; auto. + rewrite -app_context_assoc; auto. + + apply case_red_brs. + apply OnOne2_app. + constructor; cbn. + left. + rewrite -app_assoc in h; auto. Qed. - Corollary red_context : + Corollary red_context_zip : forall Γ t u π, red Σ (Γ ,,, stack_context π) t u -> red Σ Γ (zip (t, π)) (zip (u, π)). Proof. intros Γ t u π h. - rst_induction h; eauto with pcuic. - eapply red1_context. assumption. + rst_induction h; eauto using red1_context. Qed. Lemma red1_zipp : @@ -1589,8 +2506,9 @@ Section Stacks. End Stacks. +(** Not used anywhere *) +(* (* Properties about context closure *) - (** Reductions at top level *) Inductive tred1 (Σ : global_env) (Γ : context) : term -> term -> Type := @@ -1607,9 +2525,9 @@ Inductive tred1 (Σ : global_env) (Γ : context) : term -> term -> Type := tred1 Σ Γ (tRel i) (lift0 (S i) body) (** Case *) -| tred_iota ind pars c u args p brs : - tred1 Σ Γ (tCase (ind, pars) p (mkApps (tConstruct ind c u) args) brs) - (iota_red pars c args brs) +| tred_iota ci c u args p brs : + tred1 Σ Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + (iota_red ci.(ci_npar) c args brs) (** Fix unfolding, with guard *) | tred_fix mfix idx args narg fn : @@ -1632,7 +2550,7 @@ Inductive tred1 (Σ : global_env) (Γ : context) : term -> term -> Type := (** Constant unfolding *) | tred_delta c decl body (isdecl : declared_constant Σ c decl) u : decl.(cst_body) = Some body -> - tred1 Σ Γ (tConst c u) (subst_instance_constr u body) + tred1 Σ Γ (tConst c u) (subst_instance u body) (** Proj *) | tred_proj i pars narg args u arg: @@ -1705,4 +2623,6 @@ Proof. rewrite app_context_nil_l in h. econstructor. eapply OnOne2_app. constructor. cbn. intuition auto. + - Qed. +*) diff --git a/pcuic/theories/PCUICReflect.v b/pcuic/theories/PCUICReflect.v index b430b53f7..3c422c4eb 100644 --- a/pcuic/theories/PCUICReflect.v +++ b/pcuic/theories/PCUICReflect.v @@ -8,6 +8,7 @@ From MetaCoq.Template Require Export Reflect. Open Scope pcuic. + Local Ltac finish := let h := fresh "h" in right ; @@ -28,6 +29,7 @@ Local Ltac term_dec_tac term_dec := fcase (eq_dec x y) | x : list Level.t, y : Instance.t |- _ => fcase (eq_dec x y) + | x : list aname, y : list aname |- _ => fcase (eq_dec x y) | n : nat, m : nat |- _ => fcase (Nat.eq_dec n m) | i : ident, i' : ident |- _ => fcase (string_dec i i') | i : kername, i' : kername |- _ => fcase (kername_eq_dec i i') @@ -38,13 +40,36 @@ Local Ltac term_dec_tac term_dec := | i : inductive, i' : inductive |- _ => fcase (eq_dec i i') | x : inductive * nat, y : inductive * nat |- _ => fcase (eq_dec x y) - | x : (inductive * nat) * relevance, y : (inductive * nat) * relevance |- _ => + | x : case_info, y : case_info |- _ => fcase (eq_dec x y) | x : projection, y : projection |- _ => fcase (eq_dec x y) end. Derive NoConfusion NoConfusionHom for term. +Lemma eq_dec_ctx_IH ctx : + onctx (fun x : term => forall y : term, {x = y} + {x <> y}) ctx -> + forall ctx', + {ctx = ctx'} + {ctx <> ctx'}. +Proof. + induction 1. + - intros []; [left; reflexivity|right; discriminate]. + - intros []; [right; discriminate|]. + destruct p as [pty pbod]. + destruct x as [xna [xbod|] xty]; cbn in *. + destruct c as [cname [cbod|] cty]; cbn in *; nodec. + fcase (eq_dec xna cname). + destruct (pty cty) ; nodec. + destruct (pbod cbod); nodec. + destruct (IHX l0) ; nodec. + subst; left; reflexivity. + destruct c as [cname [cbod|] cty]; cbn in *; nodec. + fcase (eq_dec xna cname). + destruct (pty cty) ; nodec. + destruct (IHX l0) ; nodec. + subst; left; reflexivity. +Qed. + Instance EqDec_term : EqDec term. Proof. intro x; induction x using term_forall_list_ind ; intro t ; @@ -72,19 +97,38 @@ Proof. - destruct (IHx1 t1) ; nodec. destruct (IHx2 t2) ; nodec. subst. left. reflexivity. - - destruct (IHx1 t1) ; nodec. - destruct (IHx2 t2) ; nodec. - subst. revert brs. clear IHx1 IHx2. - induction X ; intro l0. + - destruct (IHx t) ; nodec. subst x. clear IHx. + destruct p, p0; subst; cbn. + term_dec_tac term_dec. + destruct X as (?&?&?). + destruct (s preturn0); cbn in * ; nodec. + subst. + assert ({pparams = pparams0} + {pparams <> pparams0}) as []; nodec. + { revert pparams0. + clear -a. + induction a. + - intros []; [left; reflexivity|right; discriminate]. + - intros []; [right; discriminate|]. + destruct (p t) ; nodec. + destruct (IHa l0) ; nodec. + subst; left; reflexivity. } + subst. + assert ({pcontext = pcontext0} + {pcontext <> pcontext0}) as []; nodec. + { revert pcontext0. now apply eq_dec_ctx_IH. } + subst pcontext. + revert brs. clear -X0. + induction X0 ; intro l0. + destruct l0. * left. reflexivity. * right. discriminate. + destruct l0. * right. discriminate. - * destruct (IHX l0) ; nodec. - destruct (p (snd p0)) ; nodec. - destruct (eq_dec (fst x) (fst p0)) ; nodec. - destruct x, p0. + * destruct (IHX0 l0) ; nodec. + destruct p as (hctx & hbod). + destruct (hbod (bbody b)) ; nodec. + assert ({bcontext x = bcontext b} + {bcontext x <> bcontext b}) as []; nodec. + { now apply eq_dec_ctx_IH. } + destruct x, b. left. cbn in *. subst. inversion e. reflexivity. - destruct (IHx t) ; nodec. @@ -125,6 +169,20 @@ Defined. Instance reflect_pcuic_term : ReflectEq term := let h := EqDec_ReflectEq term in _. +Instance eqb_ctx : ReflectEq context := _. + +Instance eq_predicate : EqDec (predicate term). +Proof. + intros [] []. + fcase (eq_dec pparams pparams0). + fcase (eq_dec puinst puinst0). + fcase (eq_dec pcontext pcontext0). + fcase (eq_dec preturn preturn0). +Defined. + +Global Instance branch_eq_dec : EqDec (branch term). +Proof. ltac:(Equations.Prop.Tactics.eqdec_proof). Qed. + Definition eqb_context_decl (x y : context_decl) := let (na, b, ty) := x in let (na', b', ty') := y in @@ -154,16 +212,37 @@ Proof. unfold eqb_constant_body; finish_reflect. Defined. +Local Infix "==?" := eqb (at level 20). + +Definition eqb_constructor_body (x y : constructor_body) := + x.(cstr_name) ==? y.(cstr_name) && + x.(cstr_args) ==? y.(cstr_args) && + x.(cstr_indices) ==? y.(cstr_indices) && + x.(cstr_type) ==? y.(cstr_type) && + x.(cstr_arity) ==? y.(cstr_arity). + +Instance reflect_constructor_body : ReflectEq constructor_body. +Proof. + refine {| eqb := eqb_constructor_body |}. + intros [] []. + unfold eqb_constructor_body; cbn -[eqb]. finish_reflect. +Defined. + Definition eqb_one_inductive_body (x y : one_inductive_body) := - let (n, t, k, c, p, r) := x in - let (n', t', k', c', p', r') := y in - eqb n n' && eqb t t' && eqb k k' && eqb c c' && eqb p p' && eqb r r'. + x.(ind_name) ==? y.(ind_name) && + x.(ind_indices) ==? y.(ind_indices) && + x.(ind_sort) ==? y.(ind_sort) && + x.(ind_type) ==? y.(ind_type) && + x.(ind_kelim) ==? y.(ind_kelim) && + x.(ind_ctors) ==? y.(ind_ctors) && + x.(ind_projs) ==? y.(ind_projs) && + x.(ind_relevance) ==? y.(ind_relevance). Instance reflect_one_inductive_body : ReflectEq one_inductive_body. Proof. refine {| eqb := eqb_one_inductive_body |}. intros [] []. - unfold eqb_one_inductive_body; finish_reflect. + unfold eqb_one_inductive_body; cbn -[eqb]; finish_reflect. Defined. Definition eqb_mutual_inductive_body (x y : mutual_inductive_body) := diff --git a/pcuic/theories/PCUICRename.v b/pcuic/theories/PCUICRename.v new file mode 100644 index 000000000..d6743f827 --- /dev/null +++ b/pcuic/theories/PCUICRename.v @@ -0,0 +1,1932 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Morphisms. +From MetaCoq.Template Require Import config utils. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction + PCUICLiftSubst PCUICUnivSubst PCUICContextRelation PCUICCumulativity + PCUICTyping PCUICClosed PCUICEquality PCUICWeakeningEnv + PCUICSigmaCalculus PCUICClosed PCUICOnFreeVars. + +Require Import ssreflect ssrbool. +From Equations Require Import Equations. +Require Import Equations.Prop.DepElim. +Set Equations With UIP. + +(** * Type preservation for σ-calculus operations *) + +Open Scope sigma_scope. +Set Keyed Unification. + +Set Default Goal Selector "!". + +Lemma rename_mkApps : + forall f t l, + rename f (mkApps t l) = mkApps (rename f t) (map (rename f) l). +Proof. + intros f t l. + autorewrite with sigma. f_equal. +Qed. + +Lemma rename_subst_instance : + forall u t f, + rename f (subst_instance u t) = subst_instance u (rename f t). +Proof. + intros u t f. + rewrite /subst_instance /=. + induction t in f |- * using term_forall_list_ind. + all: try solve [ + simpl ; + rewrite ?IHt ?IHt1 ?IHt2 ; + easy + ]. + - simpl. f_equal. induction X. + + reflexivity. + + simpl. f_equal ; easy. + - simpl. rewrite IHt. f_equal. + * unfold map_predicate, rename_predicate; destruct p; simpl; f_equal; solve_all. + * induction X0. + + reflexivity. + + simpl. f_equal. 2: easy. + destruct x. unfold rename_branch, map_branch. simpl in *. + f_equal; solve_all. + - simpl. f_equal. + rewrite map_length. + generalize #|m|. intro k. + induction X. 1: reflexivity. + destruct p, x. unfold map_def in *. + simpl in *. f_equal. all: easy. + - simpl. f_equal. + rewrite map_length. + generalize #|m|. intro k. + induction X. 1: reflexivity. + destruct p, x. unfold map_def in *. + simpl in *. f_equal. all: easy. +Qed. + +Definition rename_context f (Γ : context) : context := + fold_context_k (fun i => rename (shiftn i f)) Γ. + +Definition rename_decl f d := map_decl (rename f) d. + +Lemma rename_context_length : + forall σ Γ, + #|rename_context σ Γ| = #|Γ|. +Proof. + intros σ Γ. unfold rename_context. + apply fold_context_k_length. +Qed. +Hint Rewrite rename_context_length : sigma wf. + +Lemma rename_context_snoc0 : + forall f Γ d, + rename_context f (d :: Γ) = + rename_context f Γ ,, rename_decl (shiftn #|Γ| f) d. +Proof. + intros f Γ d. + unfold rename_context. now rewrite fold_context_k_snoc0. +Qed. +Hint Rewrite rename_context_snoc0 : sigma. + +Lemma rename_context_snoc r Γ d : rename_context r (Γ ,, d) = rename_context r Γ ,, map_decl (rename (shiftn #|Γ| r)) d. +Proof. + unfold snoc. apply rename_context_snoc0. +Qed. +Hint Rewrite rename_context_snoc : sigma. + +Lemma rename_context_alt r Γ : + rename_context r Γ = + mapi (fun k' d => map_decl (rename (shiftn (Nat.pred #|Γ| - k') r)) d) Γ. +Proof. + unfold rename_context. apply fold_context_k_alt. +Qed. + +Definition rename_telescope r Γ := + mapi (fun i => map_decl (rename (shiftn i r))) Γ. + +Lemma rename_context_telescope r Γ : List.rev (rename_context r Γ) = rename_telescope r (List.rev Γ). +Proof. + rewrite !rename_context_alt /rename_telescope. + rewrite mapi_rev. + f_equal. apply mapi_ext => k' d. + apply map_decl_ext => t. lia_f_equal. +Qed. + +Lemma rename_subst0 : + forall f l t, + rename f (subst0 l t) = + subst0 (map (rename f) l) (rename (shiftn #|l| f) t). +Proof. + intros f l t. + autorewrite with sigma. + eapply inst_ext. + now rewrite -ren_shiftn up_Upn Upn_comp; len. +Qed. + +Lemma rename_subst10 : + forall f t u, + rename f (t{ 0 := u }) = (rename (shiftn 1 f) t){ 0 := rename f u }. +Proof. + intros f t u. + eapply rename_subst0. +Qed. + +Lemma rename_context_nth_error : + forall f Γ i decl, + nth_error Γ i = Some decl -> + nth_error (rename_context f Γ) i = + Some (rename_decl (shiftn (#|Γ| - S i) f) decl). +Proof. + intros f Γ i decl h. + induction Γ in f, i, decl, h |- *. + - destruct i. all: discriminate. + - destruct i. + + simpl in h. inversion h. subst. clear h. + rewrite rename_context_snoc0. simpl. + f_equal. f_equal. f_equal. lia. + + simpl in h. rewrite rename_context_snoc0. simpl. + eapply IHΓ. eassumption. +Qed. + +Lemma rename_context_decl_body : + forall f Γ i body, + option_map decl_body (nth_error Γ i) = Some (Some body) -> + option_map decl_body (nth_error (rename_context f Γ) i) = + Some (Some (rename (shiftn (#|Γ| - S i) f) body)). +Proof. + intros f Γ i body h. + destruct (nth_error Γ i) eqn: e. 2: discriminate. + simpl in h. + eapply rename_context_nth_error with (f := f) in e. rewrite e. simpl. + destruct c as [na bo ty]. simpl in h. inversion h. subst. + simpl. reflexivity. +Qed. + +Lemma map_vass_map_def g l r : + (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) + (map (map_def (rename r) g) l)) = + (mapi (fun i d => map_decl (rename (shiftn i r)) d) + (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) l)). +Proof. + rewrite mapi_mapi mapi_map. apply mapi_ext. + intros. unfold map_decl, vass; simpl; f_equal. + sigma. rewrite -Upn_ren. now rewrite shiftn_Upn. +Qed. + +Lemma rename_fix_context r : + forall (mfix : list (def term)), + fix_context (map (map_def (rename r) (rename (shiftn #|mfix| r))) mfix) = + rename_context r (fix_context mfix). +Proof. + intros mfix. unfold fix_context. + rewrite map_vass_map_def rev_mapi. + fold (fix_context mfix). + rewrite (rename_context_alt r (fix_context mfix)). + unfold map_decl. now rewrite mapi_length fix_context_length. +Qed. + +Section Renaming. + +Context `{cf : checker_flags}. + +Lemma eq_term_upto_univ_rename Σ : + forall Re Rle napp u v f, + eq_term_upto_univ_napp Σ Re Rle napp u v -> + eq_term_upto_univ_napp Σ Re Rle napp (rename f u) (rename f v). +Proof. + intros Re Rle napp u v f h. + induction u in v, napp, Rle, f, h |- * using term_forall_list_ind. + all: dependent destruction h. + all: try solve [ + simpl ; constructor ; eauto + ]. + - simpl. constructor. + induction X in a, args' |- *. + + inversion a. constructor. + + inversion a. subst. simpl. constructor. + all: eauto. + - simpl. constructor. all: eauto. + * rewrite /rename_predicate. + destruct X; destruct e as [? [? [ectx ?]]]. + rewrite (All2_fold_length ectx). red. + intuition auto; simpl; solve_all. + eapply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea. + solve_all. eapply compare_decl_map. + eapply compare_decl_impl_ondecl; tea; solve_all. + * induction X0 in a, brs' |- *. + + inversion a. constructor. + + inversion a. subst. simpl. + destruct X1 as [a0 e0], p0. + constructor; eauto. + split; eauto. + ** solve_all. + eapply All2_fold_mapi. + eapply All2_fold_impl_onctx; tea. + solve_all. eapply compare_decl_map. + eapply compare_decl_impl_ondecl; tea; solve_all. + ** simpl. + rewrite (All2_fold_length a0). + now eapply e1. + - simpl. constructor. + apply All2_length in a as e. rewrite <- e. + generalize #|m|. intro k. + induction X in mfix', a, f, k |- *. + + inversion a. constructor. + + inversion a. subst. + simpl. constructor. + * unfold map_def. intuition eauto. + * eauto. + - simpl. constructor. + apply All2_length in a as e. rewrite <- e. + generalize #|m|. intro k. + induction X in mfix', a, f, k |- *. + + inversion a. constructor. + + inversion a. subst. + simpl. constructor. + * unfold map_def. intuition eauto. + * eauto. +Qed. + +(* 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 + 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 -> + 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 (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))). + +Lemma urenaming_impl : + forall (P P' : nat -> bool) Γ Δ f, + (forall i, P' i -> P i) -> + urenaming P Δ Γ f -> + urenaming P' Δ Γ f. +Proof. + intros P P' Γ Δ f hP h. + intros i decl p e. + specialize (h i decl (hP _ p) e) as [decl' [h1 [h2 h3]]]. + exists decl'. split ; [| split ]; eauto. +Qed. + +(* Definition of a good renaming with respect to typing *) +Definition renaming P Σ Γ Δ f := + wf_local Σ Γ × urenaming P Γ Δ f. + +Lemma inst_closed σ k t : closedn k t -> t.[⇑^k σ] = t. +Proof. + intros Hs. + induction t in σ, k, Hs |- * using term_forall_list_ind; intros; sigma; + simpl in *; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_branch_map_branch, + ?map_length, ?Nat.add_assoc in *; + unfold test_def, map_branch, test_branch_k, test_predicate_k in *; simpl in *; eauto with all; + simpl closed in *; repeat (rtoProp; f_equal; solve_all); try change_Sk. + + - revert Hs. + unfold Upn. + elim (Nat.ltb_spec n k) => //; intros; simpl in *. + now apply subst_idsn_consn_lt. + - specialize (IHt2 σ (S k) H0). rewrite -{2}IHt2. now sigma. + - specialize (IHt2 σ (S k) H0). rewrite -{2}IHt2. now sigma. + - specialize (IHt3 σ (S k) H0). rewrite -{2}IHt3. now sigma. + - eapply map_predicate_shift_id_spec. + * solve_all. + * solve_all. + * setoid_rewrite up_Upn; setoid_rewrite <- Upn_Upn. + fold (shiftf (fun k => inst (⇑^k σ)) k). + eapply mapi_context_eqP_test_id_spec; tea. simpl; solve_all. + * specialize (e σ (#|pcontext p| + k)). rewrite -{2}e; now sigma. + - eapply map_branch_shift_id_spec. + * setoid_rewrite up_Upn; setoid_rewrite <- Upn_Upn. + fold (shiftf (fun k => inst (⇑^k σ)) k). + eapply mapi_context_eqP_test_id_spec; tea. simpl; solve_all. + * specialize (b0 σ (#|bcontext x| + k)). + now rewrite up_Upn -Upn_Upn. + - rtoProp. specialize (b0 σ (#|m| + k) H0). + revert b0. now sigma. + - rtoProp. specialize (b0 σ (#|m| + k) H0). + revert b0. now sigma. +Qed. + +Lemma rename_closedn : + forall f n t, + closedn n t -> + rename (shiftn n f) t = t. +Proof. + intros f n t e. + autorewrite with sigma. + erewrite <- inst_closed with (σ := ren f) by eassumption. + eapply inst_ext. intro i. + unfold ren, shiftn, Upn, subst_consn, subst_compose, shift, shiftk. + rewrite idsn_length. + destruct (Nat.ltb_spec i n). + - rewrite nth_error_idsn_Some. all: auto. + - rewrite nth_error_idsn_None. 1: lia. + simpl. reflexivity. +Qed. + +Lemma rename_closed : + forall f t, + closed t -> + rename f t = t. +Proof. + intros f t h. + replace (rename f t) with (rename (shiftn 0 f) t). + - apply rename_closedn. assumption. + - now sigma. +Qed. + +Lemma rename_closed_decl k f d : closed_decl k d -> map_decl (rename (shiftn k f)) d = d. +Proof. + rewrite /map_decl. + destruct d as [? [] ?] => /=. + - move/andP=> [] clt clty. + rewrite !rename_closedn //. + - move=> clt. rewrite !rename_closedn //. +Qed. + +Lemma rename_closedn_ctx f n Γ : + closedn_ctx n Γ -> + rename_context (shiftn n f) Γ = Γ. +Proof. + rewrite test_context_k_eq /rename_context. + apply alli_fold_context_k. + intros. rewrite shiftn_add. + intros. apply rename_closed_decl. + now rewrite Nat.add_comm. +Qed. + +Lemma rename_closedn_terms f n ts : + forallb (closedn n) ts -> map (rename (shiftn n f)) ts = ts. +Proof. + solve_all. now apply rename_closedn. +Qed. + +Lemma rename_closed_extended_subst f Γ : + closed_ctx Γ -> + map (rename (shiftn (context_assumptions Γ) f)) (extended_subst Γ 0) = extended_subst Γ 0. +Proof. + intros cl. apply rename_closedn_terms. + now apply (closedn_extended_subst_gen Γ 0 0). +Qed. + +Arguments Nat.sub !_ !_. + +Lemma urenaming_vass : + forall P Γ Δ na A f, + urenaming P Γ Δ f -> + urenaming (shiftnP 1 P) (Γ ,, vass na (rename f A)) (Δ ,, vass na A) (shiftn 1 f). +Proof. + intros P Γ Δ na A f h. unfold urenaming in *. + intros [|i] decl hP e. + - simpl in e. inversion e. subst. clear e. + simpl. eexists. split. 1: reflexivity. + repeat split. + now sigma. + - simpl in e. simpl. + replace (i - 0) with i by lia. + eapply h in e as [decl' [? [? [h1 h2]]]]. + 2:{ unfold shiftnP in hP. simpl in hP. now rewrite Nat.sub_0_r in hP. } + eexists. split. 1: eassumption. + repeat split. + + tas. + + setoid_rewrite shiftn_1_S. + rewrite -rename_compose h1. + now sigma. + + move: h2. + destruct (decl_body decl) => /= //; destruct (decl_body decl') => /= //. + setoid_rewrite shiftn_1_S => [=] h2. + now rewrite -rename_compose h2; sigma. +Qed. + +Lemma renaming_vass : + forall P Σ Γ Δ na A f, + wf_local Σ (Γ ,, vass na (rename f A)) -> + renaming P Σ Γ Δ f -> + renaming (shiftnP 1 P) Σ (Γ ,, vass na (rename f A)) (Δ ,, vass na A) (shiftn 1 f). +Proof. + intros P Σ Γ Δ na A f hΓ [? h]. + split. 1: auto. + eapply urenaming_vass; assumption. +Qed. + +Lemma urenaming_vdef : + forall P Γ Δ na b B f, + urenaming P Γ Δ f -> + urenaming (shiftnP 1 P) (Γ ,, vdef na (rename f b) (rename f B)) (Δ ,, vdef na b B) (shiftn 1 f). +Proof. + intros P Γ Δ na b B f h. unfold urenaming in *. + intros [|i] decl hP e. + - simpl in e. inversion e. subst. clear e. + simpl. eexists. split. 1: reflexivity. + repeat split. + + now sigma. + + simpl. now sigma. + - simpl in e. simpl. + replace (i - 0) with i by lia. + eapply h in e as [decl' [? [? [h1 h2]]]]. + 2:{ rewrite /shiftnP /= Nat.sub_0_r // in hP. } + eexists. split. 1: eassumption. + repeat split => //. + + setoid_rewrite shiftn_1_S. + rewrite -rename_compose h1. + now sigma. + + move: h2. + destruct (decl_body decl) => /= //; destruct (decl_body decl') => /= //. + setoid_rewrite shiftn_1_S => [=] h2. + now rewrite -rename_compose h2; sigma. +Qed. + +Lemma renaming_vdef : + forall P Σ Γ Δ na b B f, + wf_local Σ (Γ ,, vdef na (rename f b) (rename f B)) -> + renaming P Σ Γ Δ f -> + renaming (shiftnP 1 P) Σ (Γ ,, vdef na (rename f b) (rename f B)) (Δ ,, vdef na b B) (shiftn 1 f). +Proof. + intros P Σ Γ Δ na b B f hΓ [? h]. + split. 1: auto. + eapply urenaming_vdef; assumption. +Qed. + +Lemma urenaming_ext : + forall P P' Γ Δ f g, + P =1 P' -> + f =1 g -> + urenaming P Δ Γ f -> + urenaming P' Δ Γ g. +Proof. + intros P P' Γ Δ f g hP hfg h. + intros i decl p e. + rewrite -hP in p. + specialize (h i decl p e) as [decl' [? [h1 [h2 h3]]]]. + exists decl'. repeat split => //. + - rewrite <- (hfg i). assumption. + - rewrite <- (hfg i). rewrite <- h2. + eapply rename_ext. intros j. symmetry. apply hfg. + - move: h3. destruct (decl_body decl) => /= //. + rewrite /rshiftk. + destruct (decl_body decl') => /= //. + intros [=]; f_equal. + now setoid_rewrite <- (hfg _). +Qed. + +Lemma renaming_extP P P' Σ Γ Δ f : + P =1 P' -> + renaming P Σ Γ Δ f -> renaming P' Σ Γ Δ f. +Proof. + intros hP; rewrite /renaming. + intros []; split; eauto. + eapply urenaming_ext; eauto. reflexivity. +Qed. + +Lemma urenaming_context : + forall P Γ Δ Ξ f, + urenaming P Δ Γ f -> + urenaming (shiftnP #|Ξ| P) (Δ ,,, rename_context f Ξ) (Γ ,,, Ξ) (shiftn #|Ξ| f). +Proof. + intros P Γ Δ Ξ f h. + induction Ξ as [| [na [bo|] ty] Ξ ih] in Γ, Δ, f, h |- *. + - simpl. eapply urenaming_ext. 3: eassumption. + * now rewrite shiftnP0. + * intros []. all: reflexivity. + - simpl. rewrite rename_context_snoc. + rewrite app_context_cons. simpl. unfold rename_decl. unfold map_decl. simpl. + eapply urenaming_ext. + 3:{ eapply urenaming_vdef; tea. eapply ih; assumption. } + * now rewrite shiftnP_add. + * now rewrite shiftn_add. + - simpl. rewrite rename_context_snoc. + rewrite app_context_cons. simpl. unfold rename_decl. unfold map_decl. simpl. + eapply urenaming_ext. + 3:{eapply urenaming_vass; tea. eapply ih; assumption. } + * now rewrite shiftnP_add. + * now rewrite shiftn_add. +Qed. + +Definition rename_branch := (map_branch_shift rename shiftn). + +(* TODO MOVE *) +Lemma isLambda_rename : + forall t f, + isLambda t -> + isLambda (rename f t). +Proof. + intros t f h. + destruct t. + all: try discriminate. + simpl. reflexivity. +Qed. + +(* TODO MOVE *) +Lemma rename_unfold_fix : + forall mfix idx narg fn f, + unfold_fix mfix idx = Some (narg, fn) -> + unfold_fix (map (map_def (rename f) (rename (shiftn #|mfix| f))) mfix) idx + = Some (narg, rename f fn). +Proof. + intros mfix idx narg fn f h. + unfold unfold_fix in *. rewrite nth_error_map. + case_eq (nth_error mfix idx). + 2: intro neq ; rewrite neq in h ; discriminate. + intros d e. rewrite e in h. + inversion h. clear h. + simpl. + f_equal. f_equal. + rewrite rename_subst0. rewrite fix_subst_length. + f_equal. + unfold fix_subst. rewrite map_length. + generalize #|mfix| at 2 3. intro n. + induction n. + - reflexivity. + - simpl. + f_equal. rewrite IHn. reflexivity. +Qed. + +(* TODO MOVE *) +Lemma decompose_app_rename : + forall f t u l, + decompose_app t = (u, l) -> + decompose_app (rename f t) = (rename f u, map (rename f) l). +Proof. + assert (aux : forall f t u l acc, + decompose_app_rec t acc = (u, l) -> + decompose_app_rec (rename f t) (map (rename f) acc) = + (rename f u, map (rename f) l) + ). + { intros f t u l acc h. + induction t in acc, h |- *. + all: try solve [ simpl in * ; inversion h ; reflexivity ]. + simpl. simpl in h. specialize IHt1 with (1 := h). assumption. + } + intros f t u l. + unfold decompose_app. + eapply aux. +Qed. + +(* TODO MOVE *) +Lemma isConstruct_app_rename : + forall t f, + isConstruct_app t -> + isConstruct_app (rename f t). +Proof. + intros t f h. + unfold isConstruct_app in *. + case_eq (decompose_app t). intros u l e. + apply decompose_app_rename with (f := f) in e as e'. + rewrite e'. rewrite e in h. simpl in h. + simpl. + destruct u. all: try discriminate. + simpl. reflexivity. +Qed. + +(* TODO MOVE *) +Lemma is_constructor_rename : + forall n l f, + is_constructor n l -> + is_constructor n (map (rename f) l). +Proof. + intros n l f h. + unfold is_constructor in *. + rewrite nth_error_map. + destruct nth_error. + - simpl. apply isConstruct_app_rename. assumption. + - simpl. discriminate. +Qed. + +(* TODO MOVE *) +Lemma rename_unfold_cofix : + forall mfix idx narg fn f, + unfold_cofix mfix idx = Some (narg, fn) -> + unfold_cofix (map (map_def (rename f) (rename (shiftn #|mfix| f))) mfix) idx + = Some (narg, rename f fn). +Proof. + intros mfix idx narg fn f h. + unfold unfold_cofix in *. rewrite nth_error_map. + case_eq (nth_error mfix idx). + 2: intro neq ; rewrite neq in h ; discriminate. + intros d e. rewrite e in h. + inversion h. + simpl. f_equal. f_equal. + rewrite rename_subst0. rewrite cofix_subst_length. + f_equal. + unfold cofix_subst. rewrite map_length. + generalize #|mfix| at 2 3. intro n. + induction n. + - reflexivity. + - simpl. + f_equal. rewrite IHn. reflexivity. +Qed. + +Definition rename_constructor_body mdecl f c := + map_constructor_body #|mdecl.(ind_params)| #|mdecl.(ind_bodies)| + (fun k => rename (shiftn k f)) c. + +Lemma map2_set_binder_name_fold bctx f Γ : + #|bctx| = #|Γ| -> + map2 set_binder_name bctx (fold_context_k f Γ) = + fold_context_k f (map2 set_binder_name bctx Γ). +Proof. + intros hl. + rewrite !fold_context_k_alt mapi_map2 -{1}(map_id bctx). + rewrite -mapi_cst_map map2_mapi. + rewrite map2_length; len => //. + eapply map2i_ext => i x y. + rewrite hl. + destruct y; reflexivity. +Qed. + +Lemma rename_subst : + forall f s n t, + rename (shiftn n f) (subst s n t) = + subst (map (rename f) s) n (rename (shiftn n (shiftn #|s| f)) t). +Proof. + intros f s n t. + autorewrite with sigma. + eapply inst_ext. intro i. unfold Upn. + unfold ren, subst_consn, shiftn, subst_compose. simpl. + rewrite nth_error_map. + destruct (Nat.ltb_spec i n). + - rewrite idsn_lt //. simpl. + destruct (Nat.ltb_spec i n) => //. lia. + - rewrite nth_error_idsn_None //. + destruct (Nat.ltb_spec (i - n) #|s|). + * rewrite nth_error_idsn_None //; try lia. + len. + replace (n + (i - n) - n) with (i - n) by lia. + destruct nth_error eqn:hnth => /=. + ** sigma. apply inst_ext. + intros k. cbn. + elim: (Nat.ltb_spec (n + k) n); try lia. + intros. eapply nth_error_Some_length in hnth. + unfold shiftk. lia_f_equal. + ** eapply nth_error_None in hnth. lia. + * len. + replace (n + (#|s| + f (i - n - #|s|)) - n) with + (#|s| + f (i - n - #|s|)) by lia. + rewrite nth_error_idsn_None; try lia. + destruct nth_error eqn:hnth. + ** eapply nth_error_Some_length in hnth. lia. + ** simpl. + eapply nth_error_None in hnth. + destruct nth_error eqn:hnth'. + + eapply nth_error_Some_length in hnth'. lia. + + simpl. unfold shiftk. + case: Nat.ltb_spec; try lia. + intros. lia_f_equal. + assert (n + (i - n - #|s|) - n = (i - n - #|s|)) as -> by lia. + lia. +Qed. + +Lemma rename_context_subst f s Γ : + rename_context f (subst_context s 0 Γ) = + subst_context (map (rename f) s) 0 (rename_context (shiftn #|s| f) Γ). +Proof. + rewrite !rename_context_alt !subst_context_alt. + rewrite !mapi_mapi. apply mapi_ext => i x. + rewrite /subst_decl !compose_map_decl. + apply map_decl_ext => t. + len. + generalize (Nat.pred #|Γ| - i). + intros. + now rewrite rename_subst. +Qed. + +Lemma rename_shiftnk : + forall f n k t, + rename (shiftn (n + k) f) (lift n k t) = lift n k (rename (shiftn k f) t). +Proof. + intros f n k t. + rewrite !lift_rename. + autorewrite with sigma. + rewrite - !Upn_ren. sigma. + rewrite Upn_compose. + rewrite -Upn_Upn Nat.add_comm Upn_Upn Upn_compose. + now rewrite shiftn_Upn. +Qed. + +Lemma rename_context_lift f n k Γ : + rename_context (shiftn (n + k) f) (lift_context n k Γ) = + lift_context n k (rename_context (shiftn k f) Γ). +Proof. + rewrite !rename_context_alt !lift_context_alt. + rewrite !mapi_mapi. apply mapi_ext => i x. + rewrite /lift_decl !compose_map_decl. + apply map_decl_ext => t; len. + generalize (Nat.pred #|Γ| - i). + intros. + rewrite shiftn_add. + rewrite (Nat.add_comm n k) Nat.add_assoc Nat.add_comm. + now rewrite rename_shiftnk shiftn_add. +Qed. + +Lemma rename_inds f ind pu bodies : map (rename f) (inds ind pu bodies) = inds ind pu bodies. +Proof. + unfold inds. + induction #|bodies|; simpl; auto. f_equal. + apply IHn. +Qed. + +Instance rename_context_ext : Proper (`=1` ==> Logic.eq ==> Logic.eq) rename_context. +Proof. + intros f g Hfg x y ->. + apply fold_context_k_ext => i t. + now rewrite Hfg. +Qed. + +Lemma rename_context_subst_instance f u Γ : + rename_context f (subst_instance u Γ) = + subst_instance u (rename_context f Γ). +Proof. unfold rename_context. + rewrite fold_context_k_map // [subst_instance _ _]map_fold_context_k. + now setoid_rewrite rename_subst_instance. +Qed. + +Lemma rename_context_subst_k f s k Γ : + rename_context (shiftn k f) (subst_context s k Γ) = + subst_context (map (rename f) s) k (rename_context (shiftn (k + #|s|) f) Γ). +Proof. + rewrite /rename_context /subst_context. + rewrite !fold_context_k_compose. + apply fold_context_k_ext => i t. + rewrite shiftn_add. + now rewrite rename_subst !shiftn_add Nat.add_assoc. +Qed. + +Lemma rename_cstr_args mdecl f cdecl : + cstr_args (rename_constructor_body mdecl f cdecl) = + rename_context (shiftn (#|mdecl.(ind_params)| + #|ind_bodies mdecl|) f) (cstr_args cdecl). +Proof. + simpl. unfold rename_context. + apply fold_context_k_ext => i t. + now rewrite shiftn_add Nat.add_assoc. +Qed. + +Lemma rename_case_branch_context_gen ind mdecl f p bctx cdecl : + closed_ctx (ind_params mdecl) -> + #|bctx| = #|cstr_args cdecl| -> + #|pparams p| = context_assumptions (ind_params mdecl) -> + rename_context f (case_branch_context ind mdecl p bctx cdecl) = + case_branch_context ind mdecl (rename_predicate f p) bctx + (rename_constructor_body mdecl f cdecl). +Proof. + intros clpars. unfold case_branch_context, case_branch_context_gen. + rewrite rename_cstr_args. + cbn -[fold_context_k]. + intros hlen hlen'. + rewrite map2_set_binder_name_fold //. + change (fold_context_k + (fun i : nat => rename (shiftn i (shiftn (ind_npars mdecl + #|ind_bodies mdecl|) f)))) with + (rename_context (shiftn (ind_npars mdecl + #|ind_bodies mdecl|) f)). + rewrite rename_context_subst map_rev //. f_equal. + unfold id. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + simpl. len. + rewrite rename_context_subst; len. + rewrite hlen'. + rewrite -{1}(context_assumptions_subst_instance (puinst p)). + rewrite rename_closed_extended_subst. + { now rewrite closedn_subst_instance_context. } + f_equal. + rewrite shiftn_add Nat.add_comm. + rewrite rename_context_lift. f_equal. + rewrite -rename_context_subst_instance. + rewrite rename_context_subst_k rename_inds. now len. +Qed. + +Lemma rename_reln f ctx n acc : + forallb (closedn (n + #|ctx|)) acc -> + map (rename (shiftn (n + #|ctx|) f)) (reln acc n ctx) = + reln acc n ctx. +Proof. + induction ctx in n, acc |- *; simpl; auto. + - intros clacc. solve_all. now rewrite rename_closedn. + - intros clacc. + destruct a as [? [] ?]. + * rewrite Nat.add_succ_r. + change (S (n + #|ctx|)) with (S n + #|ctx|). + rewrite Nat.add_1_r IHctx // /= -Nat.add_succ_r //. + * rewrite Nat.add_succ_r Nat.add_1_r. rewrite (IHctx (S n)) /= // -Nat.add_succ_r //. + simpl. rewrite clacc andb_true_r. + eapply Nat.ltb_lt. lia. +Qed. + +Lemma rename_to_extended_list f ctx : + map (rename (shiftn #|ctx| f)) (to_extended_list ctx) = to_extended_list ctx. +Proof. + unfold to_extended_list, to_extended_list_k. + now apply (rename_reln _ _ 0). +Qed. + +Lemma to_extended_list_rename f ctx : + to_extended_list (rename_context f ctx) = to_extended_list ctx. +Proof. + unfold to_extended_list, to_extended_list_k. + now rewrite (reln_fold _ _ 0). +Qed. + +Lemma forget_types_mapi_context (f : nat -> term -> term) (ctx : context) : + forget_types (mapi_context f ctx) = forget_types ctx. +Proof. + now rewrite /forget_types map_mapi_context /= mapi_cst_map. +Qed. + +Lemma forget_types_map_context (f : term -> term) (ctx : context) : + forget_types (map_context f ctx) = forget_types ctx. +Proof. + now rewrite /forget_types map_map_compose. +Qed. + +Lemma rename_case_predicate_context {Σ} {wfΣ : wf Σ} {ind mdecl idecl f p} : + declared_inductive Σ ind mdecl idecl -> + wf_predicate mdecl idecl p -> + rename_context f (case_predicate_context ind mdecl idecl p) = + case_predicate_context ind mdecl idecl (rename_predicate f p). +Proof. + intros decli wfp. + unfold case_predicate_context. simpl. + unfold id. unfold case_predicate_context_gen. + rewrite /rename_context. + rewrite -map2_set_binder_name_fold //. + - len. len. + now rewrite -(wf_predicate_length_pcontext wfp). + - f_equal. + { now rewrite forget_types_mapi_context. } + rewrite /pre_case_predicate_context_gen fold_context_k_snoc0 /= /snoc. + f_equal. + * rewrite /map_decl /=. f_equal. + len. rewrite rename_mkApps /=. f_equal. + rewrite !map_app !map_map_compose. f_equal. + + solve_all. + eapply All_refl => x. + apply rename_shiftn. + + now rewrite rename_to_extended_list. + * rewrite -/(rename_context f _). + rewrite rename_context_subst rename_context_subst_instance map_rev. + f_equal. f_equal. + rewrite List.rev_length rename_closedn_ctx //. + pose proof (closedn_ctx_expand_lets (ind_params mdecl) (ind_indices idecl) + (declared_inductive_closed_pars_indices _ decli)). + rewrite (wf_predicate_length_pars wfp). + now rewrite (declared_minductive_ind_npars decli). +Qed. + +Lemma rename_closed_constructor_body mdecl cdecl f : + closed_constructor_body mdecl cdecl -> + rename_constructor_body mdecl f cdecl = cdecl. +Proof. + rewrite /closed_constructor_body /rename_constructor_body /map_constructor_body. + move/andP=> [] /andP [] clctx clind clty. + destruct cdecl; cbn -[fold_context_k] in *; f_equal. + + move: clctx. rewrite test_context_k_eq. + apply alli_fold_context_k => i d cldecl. + rewrite rename_closed_decl //. + red; rewrite -cldecl; lia_f_equal. + + solve_all. rewrite rename_closedn //. + red; rewrite -H. lia_f_equal. + + now rewrite rename_closedn. +Qed. + +Lemma rename_mkLambda_or_LetIn f d t : + rename f (mkLambda_or_LetIn d t) = + mkLambda_or_LetIn (rename_decl f d) (rename (shiftn 1 f) t). +Proof. + destruct d as [na [] ty]; rewrite /= /mkLambda_or_LetIn /=; f_equal. +Qed. + +Lemma rename_it_mkLambda_or_LetIn f ctx t : + rename f (it_mkLambda_or_LetIn ctx t) = + it_mkLambda_or_LetIn (rename_context f ctx) (rename (shiftn #|ctx| f) t). +Proof. + move: t. + induction ctx; simpl => t. + - now rewrite shiftn0. + - rewrite /= IHctx rename_context_snoc /snoc /=. f_equal. + now rewrite rename_mkLambda_or_LetIn /= shiftn_add; len. +Qed. + +Lemma rename_mkProd_or_LetIn f d t : + rename f (mkProd_or_LetIn d t) = + mkProd_or_LetIn (rename_decl f d) (rename (shiftn 1 f) t). +Proof. + destruct d as [na [] ty]; rewrite /= /mkProd_or_LetIn /=; f_equal. +Qed. + +Lemma rename_it_mkProd_or_LetIn f ctx t : + rename f (it_mkProd_or_LetIn ctx t) = + it_mkProd_or_LetIn (rename_context f ctx) (rename (shiftn #|ctx| f) t). +Proof. + move: t. + induction ctx; simpl => t. + - now rewrite shiftn0. + - rewrite /= IHctx rename_context_snoc /snoc /=. f_equal. + now rewrite rename_mkProd_or_LetIn /= shiftn_add; len. +Qed. + +Lemma rename_wf_predicate mdecl idecl f p : + wf_predicate mdecl idecl p -> + wf_predicate mdecl idecl (rename_predicate f p). +Proof. + intros []. split. + - now len. + - rewrite forget_types_mapi_context. assumption. +Qed. + +Lemma rename_wf_branch cdecl f br : + wf_branch cdecl br -> + wf_branch cdecl (rename_branch f br). +Proof. + unfold wf_branch, wf_branch_gen. simpl. + rewrite /= forget_types_mapi_context. now simpl. +Qed. + +Lemma rename_wf_branches cdecl f brs : + wf_branches cdecl brs -> + wf_branches cdecl (map (rename_branch f) brs). +Proof. + unfold wf_branches, wf_branches_gen. + intros h. solve_all. eapply Forall2_map_right. + eapply Forall2_impl; eauto using rename_wf_branch. +Qed. + +Lemma rename_compose f f' x : rename f (rename f' x) = rename (f ∘ f') x. +Proof. now rewrite (rename_compose _ _ _). Qed. + +Lemma rename_predicate_set_pparams f p params : + rename_predicate f (set_pparams p params) = + set_pparams (rename_predicate f p) (map (rename f) params). +Proof. reflexivity. Qed. + +Lemma rename_predicate_set_pcontext f p pcontext' : + #|pcontext'| = #|p.(pcontext)| -> + rename_predicate f (set_pcontext p pcontext') = + set_pcontext (rename_predicate f p) + (mapi_context (fun k => rename (shiftn k f)) pcontext'). +Proof. rewrite /rename_predicate /= /set_pcontext. simpl. intros ->. reflexivity. Qed. + +Lemma rename_predicate_set_preturn f p pret : + rename_predicate f (set_preturn p pret) = + set_preturn (rename_predicate f p) (rename (shiftn #|pcontext p| f) pret). +Proof. reflexivity. Qed. + +Lemma rename_extended_subst f Γ : + map (rename (shiftn (context_assumptions Γ) f)) (extended_subst Γ 0) = extended_subst (rename_context f Γ) 0. +Proof. + induction Γ as [|[na [b|] ty] Γ]; auto; rewrite rename_context_snoc /=; len. + - rewrite rename_subst0. + rewrite IHΓ. len. f_equal. f_equal. + now rewrite shiftn_add Nat.add_comm rename_shiftnk. + - f_equal; auto. + rewrite !(lift_extended_subst _ 1). + rewrite map_map_compose. + setoid_rewrite <- (shiftn_add 1 (context_assumptions Γ)). + setoid_rewrite rename_shiftn. + rewrite -map_map_compose. now f_equal. +Qed. + +Lemma rename_iota_red : + forall f pars args br, + #|skipn pars args| = context_assumptions br.(bcontext) -> + #|bcontext br| = #|br.(bcontext)| -> + rename f (iota_red pars args br) = + iota_red pars (map (rename f) args) (rename_branch f br). +Proof. + intros f pars args br hlen hlen'. + unfold iota_red. + rewrite rename_subst0 map_rev map_skipn. f_equal. + rewrite List.rev_length /expand_lets /expand_lets_k. + rewrite rename_subst0. len. + rewrite shiftn_add -hlen Nat.add_comm rename_shiftnk. + rewrite hlen. rewrite rename_extended_subst. + now rewrite /rename_context mapi_context_fold. +Qed. + +Lemma rename_case_branch_type {Σ} {wfΣ : wf Σ} f (ci : case_info) mdecl idecl p br i cdecl : + declared_inductive Σ ci mdecl idecl -> + wf_predicate mdecl idecl p -> + wf_branch cdecl br -> + let ptm := it_mkLambda_or_LetIn (pcontext p) (preturn p) in + let p' := rename_predicate f p in + let ptm' := it_mkLambda_or_LetIn (pcontext p') (preturn p') in + case_branch_type ci mdecl idecl + (rename_predicate f p) + (map_branch_shift rename shiftn f br) + ptm' i (rename_constructor_body mdecl f cdecl) = + map_pair (rename_context f) (rename (shiftn #|bcontext br| f)) + (case_branch_type ci mdecl idecl p br ptm i cdecl). +Proof. + intros decli wfp wfb ptm p' ptm'. + rewrite /case_branch_type /case_branch_type_gen /map_pair /=. + rewrite rename_case_branch_context_gen //. + { eapply (declared_inductive_closed_params decli). } + { len; now apply wf_branch_length. } + { rewrite -(declared_minductive_ind_npars decli). + apply (wf_predicate_length_pars wfp). } + f_equal. + { now rewrite forget_types_mapi_context. } + rewrite rename_mkApps map_app map_map_compose. + rewrite (wf_branch_length wfb). + f_equal. + * rewrite /ptm' /ptm !lift_it_mkLambda_or_LetIn !rename_it_mkLambda_or_LetIn. + rewrite !lift_rename. f_equal. + ++ rewrite /p'. + epose proof (rename_context_lift f #|cstr_args cdecl| 0). + rewrite Nat.add_0_r in H. + rewrite H. len. + rewrite shiftn0 //. + rewrite mapi_context_fold //. + ++ rewrite /p'. rewrite Nat.add_0_r. simpl. len. + now rewrite - !lift_rename shiftn_add -rename_shiftnk Nat.add_comm. + * rewrite /= rename_mkApps /=. f_equal. + ++ rewrite !map_map_compose /id. apply map_ext => t. + rewrite /expand_lets /expand_lets_k. + rewrite -rename_subst_instance. len. + rewrite -shiftn_add -shiftn_add. + rewrite rename_subst map_rev. f_equal. + rewrite List.rev_length rename_subst. + rewrite (wf_predicate_length_pars wfp). + rewrite (declared_minductive_ind_npars decli). + rewrite -{2}(context_assumptions_subst_instance (puinst p) (ind_params mdecl)). + rewrite rename_closed_extended_subst. + { rewrite closedn_subst_instance_context. + apply (declared_inductive_closed_params decli). } + f_equal. len. rewrite !shiftn_add. + rewrite (Nat.add_comm _ (context_assumptions _)) rename_shiftnk. + f_equal. rewrite Nat.add_comm rename_subst. + rewrite rename_inds. f_equal. + rewrite shiftn_add. len. lia_f_equal. + ++ unfold id. f_equal. f_equal. + rewrite map_app map_map_compose. + rewrite map_map_compose. + setoid_rewrite rename_shiftn. len. f_equal. + rewrite rename_to_extended_list. + now rewrite /to_extended_list /to_extended_list_k reln_fold. +Qed. + +Lemma red1_rename : + forall P Σ Γ Δ u v f, + wf Σ -> + urenaming P Δ Γ f -> + on_free_vars P u -> + red1 Σ Γ u v -> + red1 Σ Δ (rename f u) (rename f v). +Proof using cf. + intros P Σ Γ Δ u v f hΣ hf hav h. + induction h using red1_ind_all in P, f, Δ, hav, hf |- *. + all: try solve [ + try (cbn in hav; rtoProp); + simpl ; constructor ; eapply IHh ; + try eapply urenaming_vass ; + try eapply urenaming_vdef ; + eassumption + ]. + all:simpl in hav |- *; try toAll. + - rewrite rename_subst10. constructor. + - rewrite rename_subst10. constructor. + - destruct (nth_error Γ i) eqn:hnth; noconf H. + unfold urenaming in hf. + specialize hf with (1 := hav) (2 := hnth). + destruct hf as [decl' [e' [? [hr hbo]]]]. + rewrite H /= in hbo. + rewrite lift0_rename. + destruct (decl_body decl') eqn:hdecl => //. noconf hbo. + sigma in H0. sigma. rewrite H0. + relativize (t.[_]). + 2:{ setoid_rewrite rshiftk_S. rewrite -rename_inst. + now rewrite -(lift0_rename (S (f i)) _). } + constructor. now rewrite e' /= hdecl. + - rewrite rename_mkApps. simpl. + rewrite rename_iota_red //. + change (bcontext br) with (bcontext (rename_branch f br)). + eapply red_iota; eauto. + + rewrite nth_error_map H /= //. + + simpl. now len. + - rewrite 2!rename_mkApps. simpl. + econstructor. + + eapply rename_unfold_fix. eassumption. + + eapply is_constructor_rename. assumption. + - rewrite 2!rename_mkApps. simpl. + eapply red_cofix_case. + eapply rename_unfold_cofix. eassumption. + - rewrite 2!rename_mkApps. simpl. + eapply red_cofix_proj. + eapply rename_unfold_cofix. eassumption. + - rewrite rename_subst_instance. + econstructor. + + eassumption. + + rewrite rename_closed. 2: assumption. + eapply declared_constant_closed_body. all: eauto. + - rewrite rename_mkApps. simpl. + econstructor. rewrite nth_error_map. rewrite H. reflexivity. + - move/and4P: hav=> [hpars hret hc hbrs]. + rewrite rename_predicate_set_pparams. econstructor. + simpl. eapply OnOne2_map. repeat toAll. + eapply OnOne2_All_mix_left in X; eauto. solve_all. red; eauto. + - move/and4P: hav=> [_ _ hpctx _]. + rewrite rename_predicate_set_pcontext. + { now rewrite -(length_of X). } + eapply case_red_pcontext. + eapply OnOne2_local_env_mapi_context. + eapply OnOne2_local_env_impl_test; tea. + clear -hf; unfold on_Trel; intros. + eapply on_one_decl_mapi_context. + eapply on_one_decl_test_impl; tea => /=. + intros ? ? ? ?. red. eapply X0; tea. + rewrite !mapi_context_fold Nat.add_0_r. + now eapply urenaming_context. + - move/and4P: hav=> [_ hret _ _]. + rewrite rename_predicate_set_preturn. + eapply case_red_return; eauto. + simpl. + eapply IHh; eauto. + rewrite mapi_context_fold. + now eapply urenaming_context. + - move/and5P: hav=> [_ _ _ _ hbrs]. + eapply case_red_brs; eauto. + eapply OnOne2_map. toAll. + eapply OnOne2_All_mix_left in X; tea. clear hbrs. + solve_all. + * left. simpl. split; auto; rewrite -b0 //. + eapply b1; tea. + rewrite mapi_context_fold. now eapply urenaming_context. + * right. simpl; rewrite -b1. + rewrite -(length_of a). split => //. + eapply OnOne2_local_env_mapi_context. + eapply OnOne2_local_env_impl_test; tea. + clear -hf; unfold on_Trel; intros. + eapply on_one_decl_mapi_context. + eapply on_one_decl_test_impl; tea => /=. + intros ? ? ? ?. red. eapply X0; tea. + rewrite !mapi_context_fold Nat.add_0_r. + now eapply urenaming_context. + - eapply OnOne2_All_mix_left in X; eauto. + constructor. + eapply OnOne2_map. solve_all. red. eauto. + - eapply OnOne2_All_mix_left in X; eauto. + apply OnOne2_length in X as hl. rewrite <- hl. clear hl. + generalize #|mfix0|. intro n. + constructor. eapply OnOne2_map. solve_all. + red. simpl. destruct x, y; simpl in *; noconf b0. split; auto. + rewrite /test_def /= in b. move/andP: b => [hty hbod]. + eauto. + - eapply OnOne2_All_mix_left in X; eauto. + apply OnOne2_length in X as hl. rewrite <- hl. clear hl. + eapply fix_red_body. eapply OnOne2_map. solve_all. + red. simpl. destruct x, y; simpl in *; noconf b0. split; auto. + rewrite /test_def /= in b. move/andP: b => [hty hbod]. + eapply b1. + * rewrite rename_fix_context. rewrite <- fix_context_length. + now eapply urenaming_context. + * now len. + - eapply OnOne2_All_mix_left in X; eauto. + apply OnOne2_length in X as hl. rewrite <- hl. clear hl. + generalize #|mfix0|. intro n. + constructor. eapply OnOne2_map. solve_all. + red. simpl. destruct x, y; simpl in *; noconf b0. split; auto. + rewrite /test_def /= in b. move/andP: b => [hty hbod]. + eauto. + - eapply OnOne2_All_mix_left in X; eauto. + apply OnOne2_length in X as hl. rewrite <- hl. clear hl. + eapply cofix_red_body. eapply OnOne2_map. solve_all. + red. simpl. destruct x, y; simpl in *; noconf b0. split; auto. + rewrite /test_def /= in b. move/andP: b => [hty hbod]. + eapply b1. + * rewrite rename_fix_context. rewrite <- fix_context_length. + now eapply urenaming_context. + * now len. +Qed. + +Lemma conv_renameP : + forall P Σ Γ Δ f A B, + wf Σ.1 -> + urenaming P Δ Γ f -> + on_free_vars P A -> + on_free_vars P B -> + on_ctx_free_vars P Γ -> + Σ ;;; Γ |- A = B -> + Σ ;;; Δ |- rename f A = rename f B. +Proof. + intros P Σ Γ Δ f A B hΣ hf hA hB hΓ h. + induction h. + - eapply conv_refl. eapply eq_term_upto_univ_rename. assumption. + - eapply conv_red_l. + + eapply red1_rename. all: try eassumption. + + apply IHh. + * eapply (red1_on_free_vars hA); tea. + * auto. + - eapply conv_red_r. + + eapply IHh; eauto. eapply (red1_on_free_vars hB); tea. + + eapply red1_rename. all: try eassumption. +Qed. + +Lemma cumul_renameP : + forall P Σ Γ Δ f A B, + wf Σ.1 -> + urenaming P Δ Γ f -> + on_free_vars P A -> + on_free_vars P B -> + on_ctx_free_vars P Γ -> + Σ ;;; Γ |- A <= B -> + Σ ;;; Δ |- rename f A <= rename f B. +Proof. + intros P Σ Γ Δ f A B hΣ hf hA hB hΓ h. + induction h. + - eapply cumul_refl. eapply eq_term_upto_univ_rename. assumption. + - eapply cumul_red_l. + + eapply red1_rename. all: try eassumption. + + apply IHh. + * eapply (red1_on_free_vars hA); tea. + * auto. + - eapply cumul_red_r. + + eapply IHh; eauto. eapply (red1_on_free_vars hB); tea. + + eapply red1_rename. all: try eassumption. +Qed. + +Lemma cumul_decls_renameP {P Σ Γ Γ' Δ Δ' f} d d' : + wf Σ.1 -> + urenaming P Δ Γ f -> + urenaming P Δ' Γ' f -> + on_free_vars_decl P d -> + on_free_vars_decl P d' -> + on_ctx_free_vars P Γ -> + cumul_decls Σ Γ Γ' d d' -> + cumul_decls Σ Δ Δ' (rename_decl f d) (rename_decl f d'). +Proof. + intros wf uren uren' ond ond' onΓ Hd; depelim Hd; constructor; tas; + (eapply conv_renameP || eapply cumul_renameP); tea. + * now move/andP: ond => []. + * now move/andP: ond' => []. + * now move/andP: ond => []. + * now move/andP: ond' => []. +Qed. + +Lemma conv_decls_renameP {P Σ Γ Γ' Δ Δ' f} d d' : + wf Σ.1 -> + urenaming P Δ Γ f -> + urenaming P Δ' Γ' f -> + on_free_vars_decl P d -> + on_free_vars_decl P d' -> + on_ctx_free_vars P Γ -> + conv_decls Σ Γ Γ' d d' -> + conv_decls Σ Δ Δ' (rename_decl f d) (rename_decl f d'). +Proof. + intros wf uren uren' ond ond' onΓ Hd; depelim Hd; constructor; tas; + (eapply conv_renameP || eapply cumul_renameP); tea. + * now move/andP: ond => []. + * now move/andP: ond' => []. + * now move/andP: ond => []. + * now move/andP: ond' => []. +Qed. + +Lemma on_free_vars_ctx_onctx_k P ctx : + reflectT (onctx_k (fun k => on_free_vars (shiftnP k P)) 0 ctx) + (on_free_vars_ctx P ctx). +Proof. + rewrite -test_context_k_on_free_vars_ctx. + apply (onctx_k_P reflectT_pred2). +Qed. + +Lemma Alli_helper Q Γ : + Alli (fun (i : nat) (d : context_decl) => ondecl (Q (#|Γ| - i + 0)) d) 1 Γ -> + onctx_k Q 0 Γ. +Proof. + move/(Alli_shiftn_inv 0 _ 1) => H. + eapply Alli_impl; tea => n x /=. + now replace (#|Γ| - S n + 0) with (Nat.pred #|Γ| - n + 0) by lia. +Qed. + +Lemma All2_fold_impl_ind_onctx_k Q P P' Γ Δ : + onctx_k Q 0 Γ -> + onctx_k Q 0 Δ -> + All2_fold P Γ Δ -> + (forall Γ Δ d d', + All2_fold P Γ Δ -> + onctx_k Q 0 Γ -> + All2_fold P' Γ Δ -> + ondecl (Q #|Γ|) d -> + ondecl (Q #|Δ|) d' -> + P Γ Δ d d' -> + P' Γ Δ d d') -> + All2_fold P' Γ Δ. +Proof. + intros qΓ qΔ cr Hcr. + induction cr in qΓ, qΔ |- *; constructor; depelim qΓ; depelim qΔ; intuition eauto; + rewrite -> Nat.sub_0_r, Nat.add_0_r in *; + apply Alli_helper in qΓ; apply Alli_helper in qΔ; + simpl in *; eauto. +Qed. + +Lemma ondecl_on_free_vars_decl P d : + ondecl (on_free_vars P) d -> + on_free_vars_decl P d. +Proof. + rewrite /on_free_vars_decl. + now case: (ondeclP reflectT_pred). +Qed. + +Lemma conv_ctx_renameP {Σ : global_env_ext} {P} {Γ Δ} {L R} f : + wf Σ.1 -> + urenaming P Δ Γ f -> + on_free_vars_ctx P L -> + on_free_vars_ctx P R -> + on_ctx_free_vars P Γ -> + conv_context Σ (Γ ,,, L) (Γ ,,, R) -> + conv_context Σ (Δ ,,, rename_context f L) (Δ ,,, rename_context f R). +Proof. + intros wf uren onL onL' onΓ H. + rewrite /rename_context - !mapi_context_fold. + pose proof (All2_fold_length H) as hlen. + len in hlen. assert (#|L| = #|R|) by lia. + eapply All2_fold_app_inv in H as [_ H] => //. + eapply All2_fold_app; len => //; pcuic. + { eapply conv_ctx_refl'. } + move/on_free_vars_ctx_onctx_k: onL => onL. + move/on_free_vars_ctx_onctx_k: onL' => onR. + + eapply All2_fold_mapi. + eapply All2_fold_impl_ind_onctx_k; tea => + /= L' R' d d' IH onL' IH' ond ond'. + simpl. + rewrite !mapi_context_fold -/(rename_context f L') -/(rename_context f R'). + eapply conv_decls_renameP; eauto. + + now eapply urenaming_context. + + rewrite (All2_fold_length IH). + now eapply urenaming_context. + + now eapply ondecl_on_free_vars_decl. + + rewrite (All2_fold_length IH'). + now eapply ondecl_on_free_vars_decl. + + eapply on_ctx_free_vars_extend => //. + now move/on_free_vars_ctx_onctx_k: onL'. +Qed. + +Lemma cumul_ctx_renameP {Σ : global_env_ext} {P} {Γ Δ} {L R} f : + wf Σ.1 -> + urenaming P Δ Γ f -> + on_free_vars_ctx P L -> + on_free_vars_ctx P R -> + on_ctx_free_vars P Γ -> + cumul_context Σ (Γ ,,, L) (Γ ,,, R) -> + cumul_context Σ (Δ ,,, rename_context f L) (Δ ,,, rename_context f R). +Proof. + intros wf uren onL onL' onΓ H. + rewrite /rename_context - !mapi_context_fold. + pose proof (All2_fold_length H) as hlen. + len in hlen. assert (#|L| = #|R|) by lia. + eapply All2_fold_app_inv in H as [_ H] => //. + eapply All2_fold_app; len => //; pcuic. + { eapply cumul_ctx_refl'. } + move/on_free_vars_ctx_onctx_k: onL => onL. + move/on_free_vars_ctx_onctx_k: onL' => onR. + + eapply All2_fold_mapi. + eapply All2_fold_impl_ind_onctx_k; tea => + /= L' R' d d' IH onL' IH' ond ond'. + simpl. + rewrite !mapi_context_fold -/(rename_context f L') -/(rename_context f R'). + eapply cumul_decls_renameP; eauto. + + now eapply urenaming_context. + + rewrite (All2_fold_length IH). + now eapply urenaming_context. + + now eapply ondecl_on_free_vars_decl. + + rewrite (All2_fold_length IH'). + now eapply ondecl_on_free_vars_decl. + + eapply on_ctx_free_vars_extend => //. + now move/on_free_vars_ctx_onctx_k: onL'. +Qed. + +Axiom fix_guard_rename : forall P Σ Γ Δ mfix f, + renaming P Σ Γ Δ f -> + let mfix' := map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in + fix_guard Σ Δ mfix -> + fix_guard Σ Γ mfix'. + +Axiom cofix_guard_rename : forall P Σ Γ Δ mfix f, + renaming P Σ Γ Δ f -> + let mfix' := map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in + cofix_guard Σ Δ mfix -> + cofix_guard Σ Γ mfix'. + +Lemma subst1_inst : + forall t n u, + t{ n := u } = t.[⇑^n (u ⋅ ids)]. +Proof. + intros t n u. + unfold subst1. rewrite subst_inst. + eapply inst_ext. intro i. + unfold Upn, subst_compose, subst_consn. + destruct (Nat.ltb_spec0 i n). + - rewrite -> nth_error_idsn_Some by assumption. reflexivity. + - rewrite -> nth_error_idsn_None by lia. + rewrite idsn_length. + destruct (Nat.eqb_spec (i - n) 0). + + rewrite e. simpl. reflexivity. + + replace (i - n) with (S (i - n - 1)) by lia. simpl. + destruct (i - n - 1) eqn: e. + * simpl. reflexivity. + * simpl. reflexivity. +Qed. +(* Hint Rewrite @subst1_inst : sigma. *) + +Lemma rename_predicate_preturn f p : + rename (shiftn #|p.(pcontext)| f) (preturn p) = + preturn (rename_predicate f p). +Proof. reflexivity. Qed. + +Lemma wf_local_app_renaming P Σ Γ Δ : + All_local_env (lift_typing (fun (Σ : global_env_ext) (Γ' : context) (t T : term) => + forall P (Δ : PCUICEnvironment.context) (f : nat -> nat), + renaming (shiftnP #|Γ ,,, Γ'| P) Σ Δ (Γ ,,, Γ') f -> Σ ;;; Δ |- rename f t : rename f T) Σ) + Δ -> + forall Δ' f, + renaming (shiftnP #|Γ| P) Σ Δ' Γ f -> + wf_local Σ (Δ' ,,, rename_context f Δ). +Proof. + intros. destruct X0. + induction X. + - apply a. + - simpl. destruct t0 as [s Hs]. + rewrite rename_context_snoc /=. constructor; auto. + red. simpl. exists s. + eapply (Hs P (Δ' ,,, rename_context f Γ0) (shiftn #|Γ0| f)). + split => //. + eapply urenaming_ext. + { len. now rewrite -shiftnP_add. } + { reflexivity. } now eapply urenaming_context. + - destruct t0 as [s Hs]. red in t1. + rewrite rename_context_snoc /=. constructor; auto. + * red. exists s. + apply (Hs P (Δ' ,,, rename_context f Γ0) (shiftn #|Γ0| f)). + split => //. + eapply urenaming_ext. + { len; now rewrite -shiftnP_add. } + { reflexivity. } now eapply urenaming_context. + * red. apply (t1 P). split => //. + eapply urenaming_ext. + { len; now rewrite -shiftnP_add. } + { reflexivity. } now eapply urenaming_context. +Qed. + +Lemma rename_decompose_prod_assum f Γ t : + decompose_prod_assum (rename_context f Γ) (rename (shiftn #|Γ| f) t) + = let '(Γ, t) := decompose_prod_assum Γ t in (rename_context f Γ, rename (shiftn #|Γ| f) t). +Proof. + induction t in Γ |- *. all: try reflexivity. + - specialize (IHt2 (Γ ,, vass na t1)). + rewrite rename_context_snoc /= in IHt2. + simpl. now rewrite shiftn_add IHt2. + - specialize (IHt3 (Γ ,, vdef na t1 t2)). + rewrite rename_context_snoc /= in IHt3. + simpl. now rewrite shiftn_add IHt3. +Qed. + +Lemma rename_app_context f Γ Δ : + rename_context f (Γ ,,, Δ) = + rename_context f Γ ,,, rename_context (shiftn #|Γ| f) Δ. +Proof. + rewrite /rename_context fold_context_k_app /app_context. f_equal. + apply fold_context_k_ext. intros i x. now rewrite shiftn_add. +Qed. + +Lemma rename_smash_context f Γ Δ : + rename_context f (smash_context Γ Δ) = + smash_context (rename_context (shiftn #|Δ| f) Γ) (rename_context f Δ). +Proof. + induction Δ as [|[na [b|] ty] Δ] in Γ |- *; simpl; auto; + rewrite ?shiftn0 // ?rename_context_snoc IHΔ /=; len. + - f_equal. now rewrite rename_context_subst /= shiftn_add. + - f_equal. rewrite rename_app_context /map_decl /= /app_context. + f_equal. + * now rewrite shiftn_add. + * rewrite /rename_context fold_context_k_tip /map_decl /=. do 2 f_equal. + now rewrite shiftn0. +Qed. + +Lemma nth_error_rename_context f Γ n : + nth_error (rename_context f Γ) n = + option_map (map_decl (rename (shiftn (#|Γ| - S n) f))) (nth_error Γ n). +Proof. + induction Γ in n |- *; intros. + - 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 *; (lia || congruence). +Qed. + +Lemma rename_check_one_fix f (mfix : mfixpoint term) d x : + check_one_fix d = Some x -> + check_one_fix (map_def (rename f) (rename (shiftn #|mfix| f)) d) = Some x. +Proof. + destruct d; simpl. + move: (rename_decompose_prod_assum f [] dtype). + rewrite shiftn0. intros ->. + destruct decompose_prod_assum. + rewrite -(rename_smash_context f []). + destruct nth_error eqn:hnth => //. + pose proof (nth_error_Some_length hnth). len in H. + simpl in H. + destruct (nth_error (List.rev (rename_context _ _)) _) eqn:hnth'. + 2:{ eapply nth_error_None in hnth'. len in hnth'. simpl in hnth'. lia. } + rewrite nth_error_rev_inv in hnth; len; auto. + len in hnth. simpl in hnth. + rewrite nth_error_rev_inv in hnth'; len; auto. + len in hnth'. simpl in hnth'. + rewrite nth_error_rename_context /= hnth /= in hnth'. noconf hnth'. + simpl. + destruct decompose_app eqn:da. len. + destruct t0 => /= //. + eapply decompose_app_inv in da. rewrite da. + rewrite rename_mkApps. simpl. rewrite decompose_app_mkApps //. +Qed. + +Lemma rename_check_one_cofix f (mfix : mfixpoint term) d x : + check_one_cofix d = Some x -> + check_one_cofix (map_def (rename f) (rename (shiftn #|mfix| f)) d) = Some x. +Proof. + destruct d; simpl. + move: (rename_decompose_prod_assum f [] dtype). + rewrite shiftn0. intros ->. + destruct decompose_prod_assum. + destruct decompose_app eqn:da. + destruct t0 => /= //. + eapply decompose_app_inv in da. rewrite da /=. + rewrite rename_mkApps. simpl. rewrite decompose_app_mkApps //. +Qed. + +Lemma rename_wf_fixpoint Σ f mfix : + wf_fixpoint Σ mfix -> + wf_fixpoint Σ (map (map_def (rename f) (rename (shiftn #|mfix| f))) mfix). +Proof. + unfold wf_fixpoint. + rewrite map_map_compose. + destruct (map_option_out (map check_one_fix mfix)) as [[]|] eqn:hmap => //. + eapply map_option_out_impl in hmap. + 2:{ intros x y. apply (rename_check_one_fix f mfix). } + now rewrite hmap. +Qed. + +Lemma rename_wf_cofixpoint Σ f mfix : + wf_cofixpoint Σ mfix -> + wf_cofixpoint Σ (map (map_def (rename f) (rename (shiftn #|mfix| f))) mfix). +Proof. + rewrite /wf_cofixpoint map_map_compose. + destruct (map_option_out (map check_one_cofix mfix)) as [[]|] eqn:hmap => //. + eapply map_option_out_impl in hmap. + 2:{ intros x y. apply (rename_check_one_cofix f mfix). } + now rewrite hmap. +Qed. + +Lemma rename_subst_telescope f s Γ : + rename_telescope f (subst_telescope s 0 Γ) = + subst_telescope (map (rename f) s) 0 + (rename_telescope (shiftn #|s| f) Γ). +Proof. + rewrite /rename_telescope /subst_telescope. + rewrite !mapi_compose. apply mapi_ext => k' d. + rewrite !compose_map_decl; apply map_decl_ext => t'. + now rewrite Nat.add_0_r rename_subst. +Qed. + +Lemma mapi_cons {A B} (f : nat -> A -> B) a l : + mapi f (a :: l) = f 0 a :: mapi (fun x => f (S x)) l. +Proof. + now rewrite /mapi /= mapi_rec_Sk. +Qed. + +Instance rename_telescope_ext : Proper (`=1` ==> `=1`) rename_telescope. +Proof. + intros f g Hfg Γ. + rewrite /rename_telescope. apply mapi_ext => n x. + now rewrite Hfg. +Qed. + +Lemma rename_telescope_shiftn0 f Γ : rename_telescope (shiftn 0 f) Γ = rename_telescope f Γ. +Proof. now sigma. Qed. + +Lemma rename_telescope_cons f d Γ : + rename_telescope f (d :: Γ) = rename_decl f d :: rename_telescope (shiftn 1 f) Γ. +Proof. + rewrite /rename_telescope mapi_cons /rename_decl. + f_equal; sigma => //. + apply mapi_ext => i x. now rewrite shiftn_add Nat.add_1_r. +Qed. + +Hint Rewrite <- Upn_ren : sigma. + +(** For an unconditional renaming defined on all variables in the source context *) +Lemma typing_rename_prop : env_prop + (fun Σ Γ t A => + forall P Δ f, + renaming (shiftnP #|Γ| P) Σ Δ Γ f -> + Σ ;;; Δ |- rename f t : rename f A) + (fun Σ Γ => + wf_local Σ Γ × + All_local_env + (lift_typing (fun (Σ : global_env_ext) (Γ : context) (t T : term) + => + forall P (Δ : PCUICEnvironment.context) (f : nat -> nat), + renaming (shiftnP #|Γ| P) Σ Δ Γ f -> + Σ;;; Δ |- rename f t : rename f T) Σ) Γ). +Proof. + apply typing_ind_env. + + - intros Σ wfΣ Γ wfΓ HΓ. split; auto. + induction HΓ; constructor; firstorder eauto. + + - intros Σ wfΣ Γ wfΓ n decl isdecl ihΓ P Δ f hf. + simpl in *. + eapply hf in isdecl as h => //. + 2:{ rewrite /shiftnP. eapply nth_error_Some_length in isdecl. now nat_compare_specs. } + destruct h as [decl' [isdecl' [? [h1 h2]]]]. + rewrite lift0_rename rename_compose h1 -lift0_rename. + econstructor. all: auto. apply hf. + + - intros Σ wfΣ Γ wfΓ l X H0 P Δ f [hΔ hf]. + simpl. constructor. all: auto. + + - intros Σ wfΣ Γ wfΓ na A B s1 s2 X hA ihA hB ihB P Δ f hf. + rewrite /=. econstructor. + + eapply ihA; eauto. + + eapply ihB; eauto. + simpl. + eapply renaming_extP. { now rewrite -(shiftnP_add 1). } + eapply renaming_vass. 2: eauto. + constructor. + * destruct hf as [hΔ hf]. auto. + * simpl. exists s1. eapply ihA; eauto. + - intros Σ wfΣ Γ wfΓ na A t s1 B X hA ihA ht iht P Δ f hf. + simpl. + (* /andP [_ havB]. *) + simpl. econstructor. + + eapply ihA; eauto. + + eapply iht; eauto; simpl. + eapply renaming_extP. { now rewrite -(shiftnP_add 1). } + eapply renaming_vass. 2: eauto. + constructor. + * destruct hf as [hΔ hf]. auto. + * simpl. exists s1. eapply ihA; eauto. + - intros Σ wfΣ Γ wfΓ na b B t s1 A X hB ihB hb ihb ht iht P Δ f hf. + simpl. econstructor. + + eapply ihB; tea. + + eapply ihb; tea. + + eapply iht; tea. + eapply renaming_extP. { now rewrite -(shiftnP_add 1). } + eapply renaming_vdef. 2: eauto. + constructor. + * destruct hf. assumption. + * simpl. eexists. eapply ihB; tea. + * simpl. eapply ihb; tea. + - intros Σ wfΣ Γ wfΓ t na A B s u X hty ihty ht iht hu ihu P Δ f hf. + simpl. eapply meta_conv. + + eapply type_App. + * simpl in ihty. eapply ihty; tea. + * simpl in iht. eapply iht. eassumption. + * eapply ihu. eassumption. + + autorewrite with sigma. rewrite !subst1_inst. sigma. + eapply inst_ext => i. + unfold subst_cons, ren, shiftn, subst_compose. simpl. + destruct i. + * simpl. reflexivity. + * simpl. replace (i - 0) with i by lia. + reflexivity. + - intros Σ wfΣ Γ wfΓ cst u decl X X0 isdecl hconst P Δ f hf. + simpl. eapply meta_conv. + + constructor. all: eauto. apply hf. + + rewrite rename_subst_instance. f_equal. + rewrite rename_closed. 2: auto. + eapply declared_constant_closed_type. all: eauto. + - intros Σ wfΣ Γ wfΓ ind u mdecl idecl isdecl X X0 hconst P Δ σ hf. + simpl. eapply meta_conv. + + econstructor. all: eauto. apply hf. + + rewrite rename_subst_instance. f_equal. + rewrite rename_closed. 2: auto. + eapply declared_inductive_closed_type. all: eauto. + - intros Σ wfΣ Γ wfΓ ind i u mdecl idecl cdecl isdecl X X0 hconst P Δ f hf. + simpl. eapply meta_conv. + + econstructor. all: eauto. apply hf. + + rewrite rename_closed. 2: reflexivity. + eapply declared_constructor_closed_type. all: eauto. + - intros Σ wfΣ Γ wfΓ ci p c brs indices ps mdecl idecl isdecl HΣ. + intros [_ IHΔ] ci_npar predctx wfp cup [wfpctx Hpctx] convctx Hpret + IHpret [wfpredctx IHpredctx] isallowed. + intros Hcxti IHctxi Hc IHc iscof ptm wfbrs Hbrs P Δ f Hf. + simpl. + rewrite rename_mkApps. + rewrite map_app. simpl. + rewrite /ptm. rewrite rename_it_mkLambda_or_LetIn. + relativize #|predctx|. + * erewrite rename_predicate_preturn. + replace (rename_context f (pcontext p)) with (pcontext (rename_predicate f p)). + 2:{ destruct p => //. simpl. rewrite mapi_context_fold //. } + rewrite /predctx. + eapply type_Case; eauto. + + now eapply rename_wf_predicate. + + simpl. rewrite mapi_context_fold. + apply All_local_env_app_inv in Hpctx as []. + eapply wf_local_app_renaming; eauto. apply a0. + + simpl. + rewrite -rename_case_predicate_context //. + rewrite mapi_context_fold -/(rename_context f _). + eapply conv_ctx_renameP; eauto. + ++ eapply Hf. + ++ eapply closed_wf_local in wfpctx => //. + rewrite closedn_ctx_app in wfpctx. + move/andP: wfpctx => [clΓ clpctx]. + now eapply closedn_ctx_on_free_vars_shift in clpctx. + ++ move/closed_wf_local: wfpredctx => //. + rewrite closedn_ctx_app => /andP [] _. + now move/closedn_ctx_on_free_vars_shift. + ++ pose proof (closed_ctx_on_free_vars P _ (closed_wf_local _ (typing_wf_local Hc))). + rewrite -{2}(app_context_nil_l Γ). + apply on_ctx_free_vars_extend => //. + + eapply IHpret => //. + rewrite /= mapi_context_fold -/(rename_context f _). + split. + ++ apply All_local_env_app_inv in Hpctx as []. + eapply wf_local_app_renaming; eauto. apply a0. + ++ rewrite /predctx. + eapply urenaming_ext. + { len. now rewrite -shiftnP_add. } + { reflexivity. } + eapply urenaming_context. apply Hf. + + rewrite -rename_case_predicate_context //. + eapply All_local_env_app_inv in IHpredctx as []. + eapply wf_local_app_renaming; eauto. apply a0. + + revert IHctxi. + rewrite /= /id -map_app. + rewrite -{2}[subst_instance _ _](rename_closedn_ctx f 0). + { pose proof (declared_inductive_closed_pars_indices _ isdecl). + now rewrite closedn_subst_instance_context. } + rewrite rename_context_telescope. + rewrite rename_telescope_shiftn0. + clear -P Δ f Hf. + induction 1. + { constructor; auto. } + { simpl. rewrite rename_telescope_cons. + constructor; cbn; eauto. + now rewrite rename_subst_telescope /= in IHIHctxi. } + { simpl. rewrite rename_telescope_cons. + constructor; cbn; eauto. + now rewrite rename_subst_telescope /= in IHIHctxi. } + + simpl. unfold id. + specialize (IHc _ _ _ Hf). + now rewrite rename_mkApps map_app in IHc. + + now eapply rename_wf_branches. + + eapply Forall2_All2 in wfbrs. + eapply All2i_All2_mix_left in Hbrs; eauto. + eapply All2i_nth_hyp in Hbrs. + eapply All2i_map_right, (All2i_impl Hbrs) => i cdecl br. + set (brctxty := case_branch_type _ _ _ _ _ _ _ _). + move=> [Hnth [wfbr [[[wfbctx Hbr] Hconv] [[IHbr [wfbrctxty Hbrctxty]] [IHbod [Hbty IHbty]]]]]]. + rewrite -(rename_closed_constructor_body mdecl cdecl f). + { eapply (declared_constructor_closed (c:=(ci.(ci_ind),i))); eauto. + split; eauto. } + rewrite rename_case_branch_type //. + rewrite -/brctxty. intros brctx'. + assert (wf_local Σ (Δ,,, brctx'.1)). + { rewrite /brctx'. cbn. + apply All_local_env_app_inv in Hbrctxty as []. + eapply wf_local_app_renaming; tea. apply a0. } + assert (wf_local Σ (Δ,,, bcontext (rename_branch f br))). + { apply All_local_env_app_inv in Hbr as []. + cbn. rewrite mapi_context_fold. + eapply wf_local_app_renaming; tea. apply a0. } + repeat split => //. + ++ cbn. rewrite mapi_context_fold. + { eapply conv_ctx_renameP in Hconv; eauto. + - eapply Hf. + - eapply closed_wf_local in wfbctx => //. + rewrite closedn_ctx_app in wfbctx. + move/andP: wfbctx => [clΓ clbctx]. + eapply closedn_ctx_on_free_vars_shift in clbctx; tea. + - move/closed_wf_local: wfbrctxty => //. + rewrite closedn_ctx_app => /andP [] _. + now move/closedn_ctx_on_free_vars_shift. + - pose proof (closed_ctx_on_free_vars P _ (closed_wf_local _ (typing_wf_local Hc))). + rewrite -{2}(app_context_nil_l Γ). + apply on_ctx_free_vars_extend => //. } + ++ eapply IHbod => //. + split => //. + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + rewrite /= mapi_context_fold. + eapply urenaming_context, Hf. + ++ eapply IHbty. split=> //. + rewrite /brctx'; cbn. + rewrite (wf_branch_length wfbr). + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + rewrite mapi_context_fold. + rewrite -(wf_branch_length wfbr). + rewrite -/(rename_context f _). + eapply urenaming_context, Hf. + * rewrite /predctx case_predicate_context_length //. + - intros Σ wfΣ Γ wfΓ p c u mdecl idecl pdecl isdecl args X X0 hc ihc e ty + P Δ f hf. + simpl. eapply meta_conv. + + econstructor. + * eassumption. + * eapply meta_conv. + -- eapply ihc; tea. + -- rewrite rename_mkApps. simpl. reflexivity. + * rewrite map_length. assumption. + + rewrite rename_subst0. simpl. rewrite map_rev. f_equal. + rewrite rename_subst_instance. f_equal. + rewrite rename_closedn. 2: reflexivity. + eapply declared_projection_closed_type in isdecl. + rewrite List.rev_length. rewrite e. assumption. + + - intros Σ wfΣ Γ wfΓ mfix n decl types H1 hdecl [_ X] ihmfixt ihmfixb wffix P Δ f hf. + apply All_local_env_app_inv in X as [_ X]. + eapply wf_local_app_renaming in X; tea. + simpl. eapply meta_conv. + + eapply type_Fix. + * eapply fix_guard_rename; eauto. + * rewrite nth_error_map. rewrite hdecl. simpl. reflexivity. + * apply hf. + * apply All_map, (All_impl ihmfixt). + intros x [s [Hs IHs]]. + exists s. now eapply IHs. + * apply All_map, (All_impl ihmfixb). + intros x [Hb IHb]. + destruct x as [na ty bo rarg]. simpl in *. + rewrite rename_fix_context. + eapply meta_conv. + ++ apply (IHb P (Δ ,,, rename_context f types) (shiftn #|mfix| f)). + split; auto. subst types. rewrite -(fix_context_length mfix). + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + apply urenaming_context; auto. apply hf. + ++ len. now sigma. + * now eapply rename_wf_fixpoint. + + reflexivity. + + - intros Σ wfΣ Γ wfΓ mfix n decl types guard hdecl [_ X] ihmfixt ihmfixb wfcofix P Δ f hf. + apply All_local_env_app_inv in X as [_ X]. + eapply wf_local_app_renaming in X; eauto. + simpl. eapply meta_conv. + + eapply type_CoFix; auto. + * eapply cofix_guard_rename; eauto. + * rewrite nth_error_map. rewrite hdecl. simpl. reflexivity. + * apply hf. + * apply All_map, (All_impl ihmfixt). + intros x [s [Hs IHs]]. + exists s. now eapply IHs. + * apply All_map, (All_impl ihmfixb). + intros x [Hb IHb]. + destruct x as [na ty bo rarg]. simpl in *. + rewrite rename_fix_context. + eapply meta_conv. + ++ apply (IHb P (Δ ,,, rename_context f types) (shiftn #|mfix| f)). + split; auto. subst types. rewrite -(fix_context_length mfix). + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + apply urenaming_context; auto. apply hf. + ++ len. now sigma. + * now eapply rename_wf_cofixpoint. + + reflexivity. + + - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht htB ihB cum P Δ f hf. + eapply type_Cumul. + + eapply iht; tea. + + eapply ihB; tea. + + eapply cumul_renameP. all: try eassumption. + * apply hf. + * 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))). + rewrite -{2}(app_context_nil_l Γ). + eapply on_ctx_free_vars_extend => //. +Qed. + +Lemma typing_rename_P {P Σ Γ Δ f t A} {wfΣ : wf Σ.1} : + renaming (shiftnP #|Γ| P) Σ Δ Γ f -> + Σ ;;; Γ |- t : A -> + Σ ;;; Δ |- rename f t : rename f A. +Proof. + intros hf h. + revert Σ wfΣ Γ t A h P Δ f hf. + apply typing_rename_prop. +Qed. + +Lemma typing_rename {Σ Γ Δ f t A} {wfΣ : wf Σ.1} : + renaming (closedP #|Γ| xpredT) Σ Δ Γ f -> + Σ ;;; Γ |- t : A -> + Σ ;;; Δ |- rename f t : rename f A. +Proof. + intros hf h. + eapply (typing_rename_P (P:=fun _ => false)) ; eauto. +Qed. + +End Renaming. diff --git a/pcuic/theories/PCUICSN.v b/pcuic/theories/PCUICSN.v index ca2de8ef7..b7d85b67e 100644 --- a/pcuic/theories/PCUICSN.v +++ b/pcuic/theories/PCUICSN.v @@ -221,17 +221,15 @@ Section Alpha. intros Γ. induction Γ as [| [na [b|] A] Γ ih ]. - constructor. - - simpl. constructor; simpl; try apply binder_anonymize. - + eapply eq_term_upto_univ_tm_nl. + - simpl. constructor; simpl; try apply binder_anonymize; tas. + + constructor; tas; auto. eapply eq_term_upto_univ_tm_nl. all: auto. - + simpl. eapply eq_term_upto_univ_tm_nl. + eapply eq_term_upto_univ_tm_nl. all: auto. - + assumption. - - simpl. constructor. + - simpl. constructor; auto. constructor. + apply binder_anonymize. + simpl. eapply eq_term_upto_univ_tm_nl. all: auto. - + assumption. Qed. Lemma cored_cored'_nl : diff --git a/pcuic/theories/PCUICSR.v b/pcuic/theories/PCUICSR.v index b2e62e973..f17f86bf9 100644 --- a/pcuic/theories/PCUICSR.v +++ b/pcuic/theories/PCUICSR.v @@ -6,11 +6,11 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICUtils PCUICAlpha PCUICEquality PCUICValidity PCUICParallelReductionConfluence PCUICConfluence PCUICContextConversion PCUICUnivSubstitution PCUICConversion PCUICInversion PCUICContexts PCUICArities - PCUICParallelReduction PCUICSpine PCUICInductives PCUICInductiveInversion - PCUICCtxShape. + PCUICParallelReduction PCUICSpine PCUICInductives PCUICInductiveInversion. Require Import ssreflect. From Equations Require Import Equations. +From Equations.Type Require Import Relation Relation_Properties. Require Import Equations.Prop.DepElim. Local Set SimplIsCbn. @@ -24,7 +24,7 @@ Ltac pcuic := intuition eauto 3 with pcuic || Arguments Nat.sub : simpl nomatch. Arguments Universe.sort_of_product : simpl nomatch. -Hint Rewrite subst_instance_context_assumptions : len. +Hint Rewrite subst_instance_assumptions : len. Hint Rewrite projs_length : len. (** The subject reduction property of the system: *) @@ -167,22 +167,554 @@ Hint Extern 4 (∑ s : Universe.t, typing _ _ ?T (tSort s)) => end : pcuic. Ltac unfold_pcuic := - progress (unfold lift_typing, PCUICTypingDef.conv, PCUICTypingDef.cumul, PCUICTypingDef.typing, - PCUICTypingDef.wf_universe, PCUICTypingDef.closedn in * ). + progress (unfold lift_typing, PCUICConversionPar.conv, PCUICConversionPar.cumul, PCUICTypingDef.typing, + PCUICTypingDef.wf_universe in * ). Hint Extern 10 => unfold_pcuic : pcuic. Hint Resolve red_conv red1_red red_cumul : pcuic. Hint Transparent global_env_ext : pcuic. -Hint Constructors All_local_env context_relation : pcuic. +Hint Constructors All_local_env All2_fold : pcuic. Ltac pcuics := try typeclasses eauto with pcuic. +Lemma declared_projection_declared_constructor {cf} + {Σ} {wfΣ : wf Σ} {i pars narg mdecl mdecl' idecl idecl' pdecl cdecl} : + declared_projection Σ (i, pars, narg) mdecl idecl pdecl -> + declared_constructor Σ (i, 0) mdecl' idecl' cdecl -> + mdecl = mdecl' /\ idecl = idecl'. +Proof. + intros [] []. + pose proof (declared_inductive_inj H H1). intuition auto. +Qed. + +Ltac hide H := + match type of H with + | ?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} : + All2i P k l l' -> + nth_error l n = Some x -> + nth_error l' n = Some c -> + P (k + n)%nat x c. +Proof. + induction 1 in n |- *. + * rewrite !nth_error_nil => //. + * destruct n. + + simpl. intros [= <-] [= <-]. now rewrite Nat.add_0_r. + + simpl. intros hnth hnth'. specialize (IHX _ hnth hnth'). + now rewrite Nat.add_succ_r. +Qed. +From MetaCoq.PCUIC Require Import PCUICSigmaCalculus. + +Lemma conv_context_smash_end {cf Σ} {wfΣ : wf Σ} (Γ Δ Δ' : context) : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ') -> + conv_context Σ (Γ ,,, smash_context [] Δ) (Γ ,,, smash_context [] Δ'). +Proof. + intros wf wf' cv. + eapply conv_context_app. + apply conv_context_rel_app in cv. + eapply conv_ctx_rel_smash => //. +Qed. + +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 = + 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 Γ : + 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} {Σ} Γ Δ Δ' : + conv_context_rel Σ Γ Δ Δ' -> + forall acc n, reln acc n Δ = reln acc n Δ'. +Proof. + induction 1. + - constructor. + - intros acc n; destruct p; simpl; auto. +Qed. + +Lemma conv_context_rel_to_extended_list {cf} {Σ} Γ Δ Δ' : + conv_context_rel Σ Γ Δ Δ' -> + to_extended_list Δ = to_extended_list Δ'. +Proof. + unfold to_extended_list, to_extended_list_k. + intros; now eapply conv_context_rel_reln. +Qed. + +Lemma eq_context_alpha_conv {cf} {Σ} Γ Δ Δ' : + All2 (compare_decls eq eq) Δ Δ' -> + conv_context_rel Σ Γ Δ Δ'. +Proof. + induction 1. + - constructor. + - destruct r; repeat constructor; subst; auto; reflexivity. +Qed. + +Lemma eq_context_alpha_reln Δ Δ' : + All2 (compare_decls eq eq) Δ Δ' -> + forall acc n, reln acc n Δ = reln acc n Δ'. +Proof. + induction 1. + - constructor. + - intros acc n; destruct r; simpl; auto. +Qed. + +Lemma eq_context_alpha_to_extended_list Δ Δ' : + All2 (compare_decls eq eq) Δ Δ' -> + to_extended_list Δ = to_extended_list Δ'. +Proof. + unfold to_extended_list, to_extended_list_k. + intros; now eapply eq_context_alpha_reln. +Qed. + +Lemma eq_binder_annots_eq nas Γ : + All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Γ -> + All2 (compare_decls eq eq) (map2 set_binder_name nas Γ) Γ. +Proof. + induction 1; simpl; constructor; auto. + destruct x, y as [na [b|] ty]; simpl; constructor; auto. +Qed. + +Lemma to_extended_list_case_branch_context ci mdecl p brctx cdecl : + All2 (fun x y => eq_binder_annot x y.(decl_name)) brctx (cstr_args cdecl) -> + to_extended_list (case_branch_context ci mdecl p brctx cdecl) = + to_extended_list (cstr_args cdecl). +Proof. + intros hlen. + rewrite /to_extended_list /case_branch_context /case_branch_context_gen. + rewrite to_extended_list_k_subst /expand_lets_ctx /expand_lets_k_ctx + to_extended_list_k_subst to_extended_list_k_lift_context to_extended_list_k_subst + PCUICLiftSubst.map_subst_instance_to_extended_list_k. + apply eq_context_alpha_to_extended_list. + now apply eq_binder_annots_eq. +Qed. + +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. + intros sp. pose proof (spine_subst_subst_to_extended_list_k sp). + rewrite -H. + rewrite /expand_lets_ctx /expand_lets_k_ctx /=. + rewrite -map_rev. + rewrite subst_context_subst_context. len. + rewrite subst_context_lift_context_cancel. now len. + f_equal. + rewrite map_rev. rewrite H. + apply context_subst_subst_extended_subst. apply sp. +Qed. + +Lemma spine_subst_inst_subst_term {cf} {Σ} {Γ inst s Δ Δ'} : + spine_subst Σ Γ inst s Δ -> + subst s 0 Δ' = subst (List.rev inst) 0 (expand_lets Δ Δ'). +Proof. + intros sp. pose proof (spine_subst_subst_to_extended_list_k sp). + rewrite -H. + rewrite /expand_lets_ctx /expand_lets_k_ctx /=. + rewrite -map_rev. + rewrite distr_subst. len. + rewrite simpl_subst_k. now len. + f_equal. + 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; + rewrite -{1}(Nat.add_0_r (#|Γ'| + k)) distr_subst_rec; lia_f_equal. +Qed. + +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. + intros sp. pose proof (spine_subst_subst_to_extended_list_k sp). + rewrite -H. + rewrite /expand_lets_ctx /expand_lets_k_ctx /=. + rewrite -map_rev. + rewrite subst_context_subst_context. len. + rewrite subst_context_lift_context_cancel. now len. + f_equal. + rewrite map_rev. rewrite H. + apply context_subst_subst_extended_subst. apply sp. +Qed. + +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. + intros sp. pose proof (spine_subst_subst_to_extended_list_k sp). + rewrite -H. + rewrite /expand_lets_ctx /expand_lets_k_ctx /=. + rewrite -map_rev /expand_lets_k. + rewrite -{2}(Nat.add_0_r k) distr_subst_rec. len. + rewrite simpl_subst_k. now len. + f_equal. + rewrite map_rev. rewrite H. + apply context_subst_subst_extended_subst. apply sp. +Qed. + +(** 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 -> + R_ind_universes Σ ci (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' -> + R_global_instance Σ.1 (eq_universe Σ) (eq_universe Σ) (ConstructRef ci c) + (ind_npars mdecl + context_assumptions (cstr_args cdecl)) u u'. +Proof. + intros declc. + pose proof (on_declared_constructor declc). + pose proof (on_declared_constructor declc) as [[onind oib] [ctor_sorts [hnth onc]]]. + intros Hu. pose proof (R_global_instance_length _ _ _ _ _ _ _ Hu). + rewrite /R_global_instance /R_opt_variance /= /lookup_constructor. + rewrite (declared_inductive_lookup_inductive declc) (proj2 declc). + rewrite -(cstr_args_length onc). + case: leb_spec_Set; try lia. move=> _ /=; cbn. + now apply R_universe_instance_variance_irrelevant. +Qed. + +Lemma wf_pre_case_branch_context {cf} {Σ} {wfΣ : wf Σ} {Γ ci mdecl p} {br : branch term} {cdecl} : + wf_branch_gen cdecl (forget_types (bcontext br)) -> + wf_local Σ (Γ,,, case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl) -> + wf_local Σ (Γ,,, pre_case_branch_context ci mdecl (pparams p) (puinst p) cdecl). +Proof. + move=> wfbr wf. + eapply wf_local_alpha; tea. + eapply All2_app. 2:eapply All2_refl; reflexivity. + eapply All2_symP. tc. + now apply pre_case_branch_context_eq. +Qed. + +Lemma conv_refl' {cf} {Σ} {wfΣ : wf Σ} {Γ x y} : + x = y -> + Σ ;;; Γ |- x = y. +Proof. now intros ->. Qed. + +Lemma expand_lets_lift_cancel Γ x : + expand_lets Γ (lift0 #|Γ| x) = lift0 (context_assumptions Γ) x. +Proof. + rewrite /expand_lets /expand_lets_k. + simpl. rewrite simpl_lift; try lia. + rewrite Nat.add_comm. + rewrite -(simpl_lift _ _ _ _ 0); try lia. + rewrite simpl_subst_k //. now len. +Qed. + +Lemma context_assumptions_expand_lets_k_ctx {Γ k Δ} : + context_assumptions (expand_lets_k_ctx Γ k Δ) = context_assumptions Δ. +Proof. + now rewrite /expand_lets_k_ctx; len. +Qed. +Hint Rewrite @context_assumptions_expand_lets_k_ctx : len. + +Lemma closedn_expand_lets (k : nat) (Γ : context) (t : term) : + closedn_ctx k Γ -> + closedn (k + #|Γ|) t -> + closedn (k + context_assumptions Γ) (expand_lets Γ t). +Proof. + rewrite /expand_lets /expand_lets_k. + intros clΓ cl. + eapply closedn_subst0. + eapply (closedn_extended_subst_gen _ _ 0) => //. + len. + rewrite Nat.add_comm Nat.add_assoc. eapply closedn_lift. + now rewrite Nat.add_comm. +Qed. + +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 []) + (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) ,,, + (subst_context (ind_subst mdecl ind u)) #|ind_params mdecl| (subst_instance u (cstr_args cdecl))). +Proof. + intros decl cu. + pose proof (on_constructor_inst decl _ cu) as [wf _]. + rewrite !subst_instance_app_ctx in wf. + rewrite -app_context_assoc -(app_context_nil_l (_ ,,, _)) app_context_assoc in wf. + eapply substitution_wf_local in wf; tea. + 2:eapply (subslet_inds _ _ _ _ _ _ decl cu). + rewrite app_context_nil_l subst_context_app closed_ctx_subst in wf. + rewrite closedn_subst_instance_context. eapply (declared_inductive_closed_params decl). + now simpl in wf; len in wf. +Qed. + +Instance conv_context_refl {cf} Σ {wfΣ : wf Σ} : CRelationClasses.Reflexive (All2_fold (conv_decls Σ)). +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. +Qed. + +Instance conv_context_trans {cf} Σ {wfΣ : wf Σ} : CRelationClasses.Transitive (All2_fold (conv_decls Σ)). +Proof. + intros x y z. now apply conv_context_trans. +Qed. + +Lemma conv_ctx_set_binder_name {cf} (Σ : global_env_ext) (Γ Δ : context) (nas : list aname) : + All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ -> + conv_context_rel Σ Γ Δ (map2 set_binder_name nas Δ). +Proof. + induction 1. + * constructor. + * destruct x, y as [na [b|] ty]; cbn; constructor; cbn; auto. + constructor; cbn; auto. now symmetry. + constructor; cbn; auto. now symmetry. +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 -> + (forall x y, R2 x y -> R3 x y) -> + (forall x y z, R1 x y -> R2 x z -> R3 y z) -> + All2 R3 l2 l3. +Proof. + intros o. induction o in l3 |- *. + intros H; depelim H. + intros Hf Hf'. specialize (Hf' _ _ _ p r). constructor; auto. + eapply All2_impl; eauto. + intros H; depelim H. + intros Hf. specialize (IHo _ H Hf). + constructor; auto. +Qed. + +Lemma OnOne2_All2i_All2i {A B : Type} {l1 l2 : list A} {l3 : list B} {R1 : A -> A -> Type} + {R2 R3 : nat -> B -> A -> Type} {n} : + OnOne2 R1 l1 l2 -> + All2i R2 n l3 l1 -> + (forall n x y, R2 n x y -> R3 n x y) -> + (forall n x y z, R1 x y -> R2 n z x -> R3 n z y) -> + All2i R3 n l3 l2. +Proof. + intros o. induction o in n, l3 |- *. + intros H; depelim H. + intros Hf Hf'. specialize (Hf' _ _ _ _ p r0). constructor; auto. + eapply All2i_impl; eauto. + intros H; depelim H. + intros Hf. specialize (IHo _ _ H Hf). + constructor; auto. +Qed. + +Lemma conv_context_set_binder_name {cf} {Σ} {wfΣ : wf Σ} {Δ 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. + intros hlen h. induction h in nas, hlen |- *; case: nas hlen => //. + * constructor. + * move=> a l /= h. depelim h. + * move=> h'; depelim h'. + * move=> a l /= h'. depelim h'. + destruct p; cbn; constructor; try constructor; cbn; eauto; try reflexivity. + eapply IHh; eauto. + specialize (IHh _ h'). now symmetry. + eapply IHh; eauto. + now symmetry. +Qed. + +Lemma conv_context_set_binder_name_inv {cf} {Σ} {wfΣ : wf Σ} {Δ 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. + intros hlen h. induction Γ' in nas, Γ, h, hlen |- *. + * case: nas h hlen => h; depelim h; try constructor. + move=> l h /= //. + * depelim hlen. depelim h. depelim a0. + destruct a => //; noconf H. + constructor; auto. eapply IHΓ'; tea. constructor; auto. simpl in e. + now transitivity x. + destruct a as [na' [b''|] ty']; noconf H. + constructor; auto. eapply IHΓ'; tea. constructor; auto. + now transitivity x. +Qed. + +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. + induction 1; simpl. + - depelim p; subst; auto. + - depelim p; subst; auto. + - f_equal; auto. +Qed. + +(* 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 Σ) Γ -> + 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'. +Proof. + intros o a H. + induction o in a |- *; simpl. + - depelim p; depelim a; constructor; auto. + destruct l as [s Hs]; exists s. eauto. + specialize (H Γ t t' (Some (tSort s))). simpl in H. eauto. + - depelim p; subst; auto. depelim a. + destruct l as [s' Hs]. + 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. + +Lemma red_one_decl_conv_context {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : + OnOne2_local_env (on_one_decl (fun Δ : context => red1 Σ (Γ ,,, Δ))) Δ Δ' -> + conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). +Proof. + intros o. + eapply red_ctx_conv_context. + eapply red_ctx_red_context. + eapply red_context_app. reflexivity. + apply red_ctx_rel_red_context_rel; tea. + constructor. exact o. +Qed. + +Lemma red1_it_mkLambda_or_LetIn_ctx {cf} {Σ} {wfΣ : wf Σ} Γ Δ Δ' u : + OnOne2_local_env (on_one_decl (fun Δ : context => red1 Σ (Γ ,,, Δ))) Δ Δ' -> + red1 Σ Γ (it_mkLambda_or_LetIn Δ u) + (it_mkLambda_or_LetIn Δ' u). +Proof. + induction 1 in u |- *. + - depelim p; subst; rewrite /it_mkLambda_or_LetIn /=. eapply red1_it_mkLambda_or_LetIn. + simpl. now constructor. + - depelim p; subst; rewrite /=; eapply red1_it_mkLambda_or_LetIn. + destruct s as [[red ->]|[red ->]]; constructor; auto. + - simpl. apply IHX. +Qed. + +Lemma onone_red_cont_context_subst {cf} {Σ} {wfΣ : wf Σ} Γ s s' Δ Δ' : + wf_local Σ (Γ ,,, Δ' ,,, Δ) -> + untyped_subslet Γ (List.rev s) Δ' -> + untyped_subslet Γ (List.rev s') Δ' -> + OnOne2 (red1 Σ Γ) s s' -> + conv_context Σ (Γ ,,, subst_context (List.rev s) 0 Δ) + (Γ ,,, subst_context (List.rev s') 0 Δ). +Proof. + intros wf us us'. + intros. + eapply conv_context_app. + eapply (conv_ctx_subst (Γ'' := [])). exact wf. + eapply conv_context_rel_app. reflexivity. + eapply All2_rev. eapply OnOne2_All2; tea. + intros. now eapply red_conv, red1_red. reflexivity. + all:tea. +Qed. + +Lemma ctx_inst_merge {cf} {Σ} {wfΣ : wf Σ} Γ inst inst' Δ : + wf_local Σ (Γ ,,, (List.rev Δ)) -> + PCUICTyping.ctx_inst + (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + forall u : term, red1 Σ Γ t u → Σ;;; Γ |- u : T) Σ Γ inst Δ -> + ctx_inst Σ Γ inst Δ -> + OnOne2 (red1 Σ Γ) inst inst' -> + ctx_inst Σ Γ inst' Δ. +Proof. + intros wf c. + induction c in inst', wf |- *; intros ctxi; depelim ctxi; intros o. + - depelim o. + - 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. + eapply ctx_inst_cumul. + 2:{ instantiate (1:=subst_context [i] 0 (List.rev Δ)). + rewrite -subst_telescope_subst_context List.rev_involutive. exact ctxi. } + eapply cumul_ctx_rel_app. + eapply conv_cumul_context. + eapply (onone_red_cont_context_subst _ [i] [hd']); tea. + repeat constructor. repeat constructor. constructor. auto. + eapply wf_local_app_inv. eapply substitution_wf_local; tea. + repeat (constructor; tea). rewrite subst_empty; tea. + eapply wf_local_app_inv. eapply substitution_wf_local; tea. + repeat (constructor; tea). rewrite subst_empty; tea. now eapply t0. + constructor; auto. eapply IHc. + rewrite -subst_context_subst_telescope. + eapply substitution_wf_local; tea. + repeat (constructor; tea). rewrite subst_empty; tea. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + exact wf. tas. tas. + - constructor. eapply IHc; eauto. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + rewrite -subst_context_subst_telescope. + eapply substitution_wf_local; tea. + repeat (constructor; tea). eapply subslet_def. constructor. + all:rewrite !subst_empty //. + eapply wf_local_app_inv in wf as [wf _]. now depelim wf. +Qed. + +Lemma ctx_inst_merge' {cf} {Σ} {wfΣ : wf Σ} Γ inst inst' Δ : + wf_local Σ (Γ ,,, Δ) -> + PCUICTyping.ctx_inst + (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + forall u : term, red1 Σ Γ t u → Σ;;; Γ |- u : T) Σ Γ inst (List.rev Δ) -> + ctx_inst Σ Γ inst (List.rev Δ) -> + OnOne2 (red1 Σ Γ) inst inst' -> + ctx_inst Σ Γ inst' (List.rev Δ). +Proof. + intros. eapply ctx_inst_merge; try rewrite ?(List.rev_involutive Δ) //; tea. +Qed. + +Lemma All2i_All2i_mix {A B} {P Q : nat -> A -> B -> Type} + {n} {l : list A} {l' : list B} : + All2i P n l l' -> All2i Q n l l' -> All2i (fun i x y => (P i x y * Q i x y)%type) n l l'. +Proof. + induction 2; simpl; intros; constructor. + inv X; intuition auto. + apply IHX0. inv X; intuition auto. +Qed. + +Definition conj_impl {A B} : A -> (A -> B) -> A × B := fun x f => (x, f x). + Lemma sr_red1 {cf:checker_flags} : env_prop SR_red1 - (fun Σ Γ wfΓ => - All_local_env_over typing (fun Σ Γ _ t T _ => SR_red1 Σ Γ t T) Σ Γ wfΓ). + (fun Σ Γ => wf_local Σ Γ × + (forall Γ' Δ' Δ, + Γ = Γ' ,,, Δ' -> + OnOne2_local_env (on_one_decl (fun Δ : context => red1 Σ (Γ',,, Δ))) Δ' Δ -> + wf_local_rel Σ Γ' Δ)). Proof. - apply typing_ind_env; intros Σ wfΣ Γ wfΓ; unfold SR_red1; intros **; rename_all_hyps; auto; - match goal with + apply typing_ind_env; intros Σ wfΣ Γ wfΓ; unfold SR_red1; intros **; rename_all_hyps; auto. + 2-15:match goal with | [H : (_ ;;; _ |- _ <= _) |- _ ] => idtac | _ => depelim Hu; try solve [apply mkApps_Fix_spec in x; noconf x]; @@ -198,16 +730,48 @@ Proof. ] end. - - (* Rel *) + - (* Contexts *) + split; auto. intros Γ' Δ' Δ ->. + induction 1. + * depelim p. subst. depelim X. constructor. + now eapply wf_local_app_inv. + exists tu.π1. now eapply t1. + * depelim X. + constructor. now eapply wf_local_app_inv. + depelim p. destruct s as [[red <-]|[red <-]]; subst. + exists tu.π1. now eapply t2. + exact tu. + do 2 red. depelim p. destruct s as [[red <-]|[red <-]]; subst. + specialize (t2 _ red). eapply type_Cumul; tea. now eapply red_cumul. + now eapply t1. + * depelim X; specialize (IHX0 _ X). + + constructor; auto. clear X. + eapply wf_local_app_inv in all as []. + eapply wf_local_app in IHX0; tea. + destruct tu as [s Hs]. exists s. + eapply context_conversion; tea. + now eapply red_one_decl_conv_context. + + constructor; auto. clear X. + eapply wf_local_app_inv in all as []. + eapply wf_local_app in IHX0; tea. + destruct tu as [s Hs]. exists s. + eapply context_conversion; tea. + now eapply red_one_decl_conv_context. + red. + clear X; eapply wf_local_app_inv in all as []. + eapply wf_local_app in IHX0; tea. + eapply context_conversion; tea. + now eapply red_one_decl_conv_context. + + - (* Rel delta reduction *) rewrite heq_nth_error in e. destruct decl as [na b ty]; noconf e. simpl. - pose proof (nth_error_All_local_env_over heq_nth_error X); eauto. - destruct lookup_wf_local_decl; cbn in *. + pose proof (PCUICValidity.nth_error_All_local_env heq_nth_error wfΓ); eauto. + cbn in *. rewrite <- (firstn_skipn (S n) Γ). eapply weakening_length; auto. { rewrite firstn_length_le; auto. apply nth_error_Some_length in heq_nth_error. auto with arith. } now unfold app_context; rewrite firstn_skipn. - apply o. - (* Prod *) constructor; eauto. @@ -217,7 +781,7 @@ Proof. eapply type_Cumul'. eapply type_Lambda; eauto. unshelve eapply (context_conversion _ typeb); pcuics. assert (Σ ;;; Γ |- tLambda n t b : tProd n t bty). econstructor; pcuics. - now eapply validity_term in X0. + now eapply validity in X0. eapply cumul_red_r. apply cumul_refl'. constructor. apply Hu. @@ -226,7 +790,7 @@ Proof. apply (substitution_let _ Γ n b b_ty b' b'_ty wf typeb'). specialize (typing_wf_local typeb') as wfd. assert (Σ ;;; Γ |- tLetIn n b b_ty b' : tLetIn n b b_ty b'_ty). econstructor; eauto. - edestruct (validity _ wf _ _ _ X0). apply i. + eapply (validity X0). eapply cumul_red_r. apply cumul_refl'. constructor. @@ -235,7 +799,7 @@ Proof. econstructor; eauto. unshelve eapply (context_conversion _ typeb'); pcuics. assert (Σ ;;; Γ |- tLetIn n b b_ty b' : tLetIn n b b_ty b'_ty). econstructor; eauto. - edestruct (validity _ wf _ _ _ X0). apply i. + eapply (validity X0). eapply cumul_red_r. apply cumul_refl'. now constructor. @@ -249,7 +813,7 @@ Proof. constructor; pcuic. eapply type_Cumul'. eauto. all:pcuic. assert (Σ ;;; Γ |- tLetIn n b b_ty b' : tLetIn n b b_ty b'_ty). econstructor; eauto. - edestruct (validity _ wf _ _ _ X0). apply i. + eapply (validity X). eapply cumul_red_r. apply cumul_refl'. now constructor. @@ -258,7 +822,7 @@ Proof. pose proof typet as typet'. eapply inversion_Lambda in typet' as [s1 [B' [Ht [Hb HU]]]]=>//. apply cumul_Prod_inv in HU as [[eqann eqA] leqB] => //. - destruct (validity _ wf _ _ _ typet). + pose proof (validity typet) as i. eapply isType_tProd in i as [Hdom Hcodom]; auto. eapply type_Cumul'; eauto. unshelve eapply (context_conversion _ Hb); pcuics. @@ -270,13 +834,13 @@ Proof. epose (last_nonempty_eq H0). rewrite <- Hu in e1. rewrite <- e1. clear e1. specialize (inversion_mkApps wf typet) as [T' [appty spty]]. - specialize (validity _ wf _ _ _ appty) as [_ vT']. + have vT' := (validity appty). eapply type_tFix_inv in appty as [T [arg [fn' [[[Hnth wffix] Hty]]]]]; auto. rewrite e in Hnth. noconf Hnth. eapply type_App; eauto. eapply type_mkApps. eapply type_Cumul'; eauto. eapply spty. - - (* Congruence *) + - (* Application congruence for argument *) eapply type_Cumul'; [eapply type_App| |]; eauto with wf. eapply validity. eauto. eauto. eapply type_App; eauto. eapply red_cumul_inv. @@ -288,479 +852,654 @@ Proof. destruct decl0 as [ty body' univs]; simpl in *; subst body'. eapply on_declared_constant in H; tas; cbn in H. rewrite <- (app_context_nil_l Γ). - apply typecheck_closed in H as H'; tas. - destruct H' as [_ H']. apply andb_and in H'. - replace (subst_instance_constr u body) - with (lift0 #|Γ| (subst_instance_constr u body)). - replace (subst_instance_constr u ty) - with (lift0 #|Γ| (subst_instance_constr u ty)). - 2-3: rewrite lift_subst_instance_constr lift_closed; cbnr; apply H'. + apply subject_closed in H as clb; tas. + apply type_closed in H as clty; tas. + replace (subst_instance u body) + with (lift0 #|Γ| (subst_instance u body)). + replace (subst_instance u ty) + with (lift0 #|Γ| (subst_instance u ty)). + 2-3: rewrite -subst_instance_lift lift_closed; cbnr; tas. eapply weakening; tea. now rewrite app_context_nil_l. eapply typing_subst_instance_decl with (Γ0:=[]); tea. - (* iota reduction *) - subst npar. clear forall_u forall_u0 X X0. + destruct X1 as [wfpctx X1]. + destruct X4 as [wfcpc IHcpc]. + hide X9. pose proof typec as typec''. - unfold iota_red. rename args into iargs. rename args0 into cargs. + unfold iota_red. pose proof typec as typec'. eapply inversion_mkApps in typec as [A [tyc tyargs]]; auto. - eapply (inversion_Construct Σ wf) in tyc as [mdecl' [idecl' [cdecl' [wfl [declc [Hu tyc]]]]]]. + eapply (inversion_Construct Σ wf) in tyc as [mdecl' [idecl' [cdecl [wfl [declc [Hu tyc]]]]]]. + eapply typing_spine_strengthen in tyargs; tea. + clear tyc. unshelve eapply Construct_Ind_ind_eq in typec'; eauto. - unfold on_declared_constructor in typec'. - destruct declc as [decli declc]. - unfold on_declared_inductive in typec'. - destruct declared_constructor_inv as [cs [Hnth onc]]. - simpl in typec'. - destruct (declared_inductive_inj isdecl decli) as []; subst mdecl' idecl'. - set(oib := declared_inductive_inv _ _ _ _) in *. clearbody oib. - eapply (build_branches_type_lookup _ Γ ind mdecl idecl cdecl' _ _ _ brs) in heq_map_option_out; eauto. - 2:{ eapply All2_impl; eauto. simpl; intuition eauto. } - unshelve eapply build_case_predicate_type_spec in heq_build_case_predicate_type as - [parsubst [csubst ptyeq]]. 2:exact oib. subst pty. - destruct heq_map_option_out as [nargs [br [brty [[[Hbr Hbrty] brbrty] brtys]]]]. - unshelve eapply (branch_type_spec Σ.1) in brtys; eauto. 2:eapply on_declared_inductive; eauto. - destruct (nth_nth_error' (@eq_refl _ (nth c0 brs (0, tDummy)))) => //. - 2:{ simpl in Hbr. rewrite Hbr in a. intuition discriminate. } - assert (H : ∑ t', nth_error btys c0 = Some t'). - pose proof (All2_length _ _ X5). eapply nth_error_Some_length in e. rewrite H in e. - destruct (nth_error_spec btys c0). eexists; eauto. elimtype False; lia. - destruct H as [t' Ht']. - rewrite Hbr in e. noconf e. simpl in H. rewrite <- H. simpl. - clear H. - destruct brtys as [-> brtys]. - specialize (brtys _ csubst). - simpl in brtys. subst brty. - eapply type_mkApps. eauto. - set argctx := cshape_args cs. - clear Hbr brbrty Hbrty X5 Ht'. - destruct typec' as [[[[_ equ] cu] eqargs] [cparsubst [cargsubst [iparsubst [iidxsubst ci]]]]]. - destruct ci as ((([cparsubst0 iparsubst0] & idxsubst0) & subsidx) & [s [typectx [Hpars Hargs]]]). - pose proof (context_subst_fun csubst (iparsubst0.(inst_ctx_subst))). subst iparsubst. - unshelve epose proof (constructor_cumulative_indices wf isdecl oib onc _ Hu cu equ _ _ _ _ _ cparsubst0 iparsubst0 Hpars). - { eapply (weaken_lookup_on_global_env' _ _ _ wf (proj1 decli)). } + pose proof (declared_inductive_inj isdecl (proj1 declc)) as [-> ->]. + destruct typec' as [[[[_ equ] cu] eqargs] [cparsubst [cargsubst [iparsubst [iidxsubst ci']]]]]. + destruct ci' as ((([cparsubst0 iparsubst0] & idxsubst0) & subsidx) & [s [typectx [Hpars Hargs]]]). + pose proof (on_declared_constructor declc) as [[onind oib] [ctor_sorts [hnth onc]]]. + (* pose proof (PCUICContextSubst.context_subst_fun csubst (iparsubst0.(inst_ctx_subst))). subst iparsubst. *) + unshelve epose proof (constructor_cumulative_indices wf declc _ Hu cu equ _ _ _ _ _ cparsubst0 iparsubst0 Hpars). + { eapply (weaken_lookup_on_global_env' _ _ _ wf (proj1 isdecl)). } set (argctxu1 := subst_context _ _ _) in X |- *. set (argctxu := subst_context _ _ _) in X |- *. simpl in X. set (pargctxu1 := subst_context cparsubst 0 argctxu1) in X |- *. - set (pargctxu := subst_context parsubst 0 argctxu) in X |- *. + set (pargctxu := subst_context iparsubst 0 argctxu) in X |- *. destruct X as [cumargs convidx]; eauto. - assert(wfparu : wf_local Σ (subst_instance_context u (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 typep; auto. eapply PCUICWfUniverses.isType_wf_universes in typep. - rewrite PCUICWfUniverses.wf_universes_it_mkProd_or_LetIn in typep. - move/andb_and: typep => /= [_ /andb_and[_ typep]]. - now apply (ssrbool.elimT PCUICWfUniverses.wf_universe_reflect) in typep. auto. } - eapply wf_arity_spine_typing_spine => //. - split. - { (* Predicate instantiation is well typed *) - exists (sort_of_products s ps). - eapply type_it_mkProd_or_LetIn_sorts; eauto. - assert (wf_local Σ (Γ ,,, pargctxu)). - { eapply sorts_local_ctx_wf_local in typectx; eauto. } - assert (#|argctx| = #|pargctxu|). - { now rewrite /argctx /pargctxu /argctxu /argctx; autorewrite with len. } - eapply type_mkApps. - eapply weakening_gen; eauto. - eapply wf_arity_spine_typing_spine => //. - split. - ** eapply validity in typep. eapply isType_lift. len. lia. - all:auto. rewrite skipn_all_app_eq //. - ** rewrite lift_it_mkProd_or_LetIn. - pose proof onc as onc'. - eapply on_constructor_inst_pars_indices in onc'; eauto. - 2:{ simpl. eapply on_declared_inductive; eauto. } - destruct onc' as [wfparsargs [inst sp]]. - eapply arity_spine_it_mkProd_or_LetIn => //. - simpl in sp. rewrite !map_map_compose in sp. eapply sp. - autorewrite with len. - simpl. constructor. - 2:{ simpl; constructor; auto. } - rewrite lift_mkApps subst_mkApps. - simpl. eapply type_mkApps. econstructor; eauto. - split; eauto. - eapply wf_arity_spine_typing_spine; eauto. - split; eauto. eapply declared_constructor_valid_ty; eauto. - split; eauto. - unfold type_of_constructor. - rewrite [cdecl'.1.2](onc.(cstr_eq)). - rewrite subst_instance_constr_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. - eapply arity_spine_it_mkProd_or_LetIn; eauto. - simpl. eapply spine_subst_weakening in iparsubst0. 3:eapply X. all:eauto. - rewrite closed_ctx_lift in iparsubst0. - now eapply closed_wf_local. - rewrite -H in iparsubst0. - rewrite closed_ctx_subst. now eapply closed_wf_local. eapply iparsubst0. - rewrite subst_instance_constr_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn. - autorewrite with len. - rewrite -(app_nil_r (to_extended_list pargctxu)). - pose proof (spine_subst_to_extended_list_k _ _ _ wf X). - rewrite {6}/pargctxu in X0. - rewrite distr_lift_subst_context in X0. - rewrite closed_ctx_lift in X0. - { rewrite /argctxu. rewrite -(context_subst_length csubst). - rewrite subst_instance_context_length. rewrite Nat.add_comm. eapply closedn_ctx_subst. - 2:eapply declared_minductive_closed_inds; eauto. - rewrite /argctx. autorewrite with len. simpl. - pose proof (on_declared_inductive wf isdecl) as [onind _]. - pose proof (on_constructor_inst u wf isdecl onind oib onc cu) as [wfcl _]; auto. - eapply closed_wf_local in wfcl; auto. - rewrite !subst_instance_context_app in wfcl. - rewrite closedn_ctx_app in wfcl. - move/andb_and: wfcl => []. autorewrite with len. now auto. } - eapply arity_spine_it_mkProd_or_LetIn; eauto. - { unfold to_extended_list, to_extended_list_k. rewrite /argctxu in X0. simpl. rewrite -H in X0. - eapply X0. } - epose proof (to_extended_list_map_lift _ 0 _) as Hl; rewrite Nat.add_0_r in Hl. - rewrite map_app. - rewrite <- Hl. clear Hl. - rewrite !map_app. - rewrite (map_map_compose _ _ _ _ (lift #|argctx| _)). - epose proof (simpl_lift_ext #|ind_indices oib| 0 #|argctx| #|ind_indices oib|). - do 2 forward H0 by lia. - rewrite (map_ext _ _ _ H0). clear H0. - rewrite (Nat.add_comm (#|argctx|)). - rewrite -(map_ext _ _ _ (simpl_lift_ext _ 0 _ 0 _ _)); try lia. - rewrite -(map_map_compose _ _ _ _ (lift0 #|ind_indices oib|)). - rewrite map_map_compose. rewrite map_subst_lift_id_eq. - rewrite (subslet_length sp). now autorewrite with len. - rewrite /to_extended_list -(PCUICSubstitution.map_subst_instance_constr_to_extended_list_k u (ind_indices oib)). - rewrite -(to_extended_list_k_subst parsubst 0 (subst_instance_context _ _)_). - rewrite -(to_extended_list_k_lift_context (subst_context _ _ _) 0 #|cshape_args cs|). - erewrite subst_to_extended_list_k. - 2:{ eapply make_context_subst_spec_inv. rewrite List.rev_involutive. eapply sp. } - rewrite map_lift0. - rewrite subst_instance_constr_mkApps !subst_mkApps. - rewrite /cstr_concl_head. - rewrite subst_inds_concl_head. simpl. - { simpl. destruct decli. now eapply nth_error_Some_length in H2. } - simpl. - constructor. exists (subst_instance_univ u (ind_sort oib)). - { red. eapply type_mkApps. econstructor; eauto. - eapply wf_arity_spine_typing_spine; eauto. - constructor. epose proof (oib.(onArity)). - rewrite (oib.(ind_arity_eq)) !subst_instance_constr_it_mkProd_or_LetIn. - pose proof (on_declared_inductive wf decli) as [ondi oni]. - generalize (on_inductive_inst _ _ _ u _ _ wf X (proj1 decli) ondi oib cu). - now rewrite subst_instance_context_app it_mkProd_or_LetIn_app. - rewrite (oib.(ind_arity_eq)) !subst_instance_constr_it_mkProd_or_LetIn. - eapply arity_spine_it_mkProd_or_LetIn; eauto. - { eapply spine_subst_weakening in iparsubst0. - rewrite closed_ctx_lift in iparsubst0. - eapply closed_wf_local; eauto. - rewrite H; eapply iparsubst0. all:eauto. } - rewrite subst_it_mkProd_or_LetIn. - eapply arity_spine_it_mkProd_or_LetIn_Sort => //. - simpl in sp. - pose proof (on_declared_inductive wf decli) as [ondi oni]. - eapply (on_inductive_sort_inst); eauto. - instantiate (1:=inst). - eapply spine_subst_eq; [eapply sp|]. - rewrite distr_lift_subst_context -H. f_equal. - rewrite -(context_subst_length iparsubst0). - autorewrite with len. rewrite closed_ctx_lift //. - epose proof (on_minductive_wf_params_indices_inst _ _ u _ _ _ (proj1 decli) oib cu). - rewrite subst_instance_context_app in X1. eapply closed_wf_local in X1; eauto. - rewrite closedn_ctx_app in X1. autorewrite with len in X1. - now move/andb_and: X1 => []. - } - simpl. - eapply conv_cumul; apply mkApps_conv_args; auto. - rewrite !map_app. eapply All2_app. - **** - eapply (All2_impl (P:=fun x y => x = y)). - 2:{ intros ? ? ->. reflexivity. } - eapply All2_eq_eq. - rewrite subst_instance_to_extended_list_k. - rewrite -to_extended_list_k_map_subst; [autorewrite with len; lia|]. - rewrite -[subst_instance_context _ _](closed_ctx_lift #|argctx| 0) => //. - eapply closed_wf_local; eauto. - erewrite subst_to_extended_list_k. - 2:{ eapply make_context_subst_spec_inv. rewrite List.rev_involutive. - eapply spine_subst_weakening in iparsubst0; eauto. - rewrite H; eapply iparsubst0; eauto. } - rewrite map_map_compose. - rewrite map_subst_lift_id_eq. now autorewrite with len. - now rewrite H. - **** - rewrite -H in X0. - rewrite map_map_compose. - eapply All2_map. - assert (All (fun x => closedn (#|parsubst| + #|argctx|) x) (map - (subst (inds (inductive_mind ind) u (PCUICAst.ind_bodies mdecl)) - (#|cshape_args cs| + #|ind_params mdecl|) - ∘ subst_instance_constr u) (cshape_indices cs))). - { pose proof (positive_cstr_closed_indices wf onc). - eapply All_map. - eapply All_map_inv in X1. - eapply (All_impl X1) => x cl. - eapply (closedn_expand_lets 0) in cl. - rewrite subst_closedn closedn_subst_instance_constr. - now len in cl. - rewrite -(context_subst_length iparsubst0). - autorewrite with len. now rewrite Nat.add_comm; len in cl. } - rewrite !map_map_compose. apply (All_All2 X1). - intros x cl. - pose proof (all_rels_subst Σ pargctxu Γ (subst parsubst #|argctx| x) wf X) as X2. - eapply red_conv in X2. - assert(subst (map (lift0 #|argctx|) parsubst) #|cshape_args cs| x = - (lift #|argctx| #|argctx| (subst parsubst #|argctx| x))) as ->. - { epose proof (distr_lift_subst_rec _ _ #|argctx| #|argctx| 0) as l. - rewrite Nat.add_0_r in l. rewrite -> l. f_equal. - rewrite lift_closed. eapply closed_upwards; eauto. lia. reflexivity. } - symmetry. now rewrite -H in X2. } - - rewrite -(app_nil_r (skipn _ _)). - have argsubst := spine_subst_smash wf idxsubst0. - eapply (spine_subst_cumul _ _ _ _ (smash_context [] pargctxu)) in argsubst; first last. - 4-5:apply smash_context_assumption_context; constructor. all:auto. - { eapply on_constructor_inst in onc; eauto. - 2:{ simpl. eapply on_declared_inductive; eauto. } - destruct onc as [wfc [inst spc]]. - rewrite !subst_instance_context_app in wfc. - rewrite -(app_context_nil_l (_ ,,, _)) in wfc. - rewrite -app_context_assoc in wfc. - rewrite app_context_assoc in wfc. - eapply (substitution_wf_local _ []) in wfc; eauto. - 2:eapply subslet_inds; eauto. - simpl in wfc. rewrite subst_context_app in wfc. - autorewrite with len in wfc. - rewrite closed_ctx_subst in wfc. - eapply closed_wf_local; eauto. - eapply (weaken_wf_local Γ) in wfc; eauto. - rewrite app_context_nil_l !app_context_assoc in wfc. - eapply substitution_wf_local in wfc; eauto. - 2:eapply iparsubst0. - eapply wf_local_smash_end; eauto. } - apply argsubst. - eapply arity_spine_it_mkProd_or_LetIn_smash => //. - apply argsubst. + { 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). + unfold hidebody in X9. + set (ptm := it_mkLambda_or_LetIn _ _). + rename c0 into c. + rename u0 into u. + assert (isType Σ Γ (mkApps ptm (indices ++ [mkApps (tConstruct ci c u) args]))). + { eapply validity. econstructor; eauto. apply (All2i_impl X9). intuition auto. } + eapply All2i_nth_error in X9; tea. + 2:{ destruct declc. simpl in e1. exact e1. } + cbn in X9. + destruct X9 as [[[wfbrctx IHbrctx] convbrctx] [[bodty [wfcbc IHcbc]] [IHbody [cbty IHcbty]]]]. + clear IHcbty IHbody IHbrctx IHcbc. + move: bodty. + intros hb. + eapply typing_expand_lets in hb. + eapply context_conversion in hb. + 3:{ eapply conv_context_smash_end; tea. } + 2:{ eapply wf_local_smash_end; tea. } + rewrite -> case_branch_type_fst in *. + set (brctx := (pre_case_branch_context ci mdecl (pparams p) (puinst p) cdecl)). + assert (convbrctx' : conv_context Σ (Γ ,,, bcontext br) (Γ ,,, brctx)). + { etransitivity; tea. + apply conv_context_app, eq_context_alpha_conv. + rewrite /brctx. eapply All2_symP. tc. + apply pre_case_branch_context_eq. + eapply Forall2_All2, All2_nth_error in H4; tea. + eapply declc. } + assert (convbrctx'' : conv_context Σ (Γ ,,, case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl) + (Γ ,,, brctx)). + { etransitivity; tea. symmetry. tea. } + assert (wfbr : wf_branch cdecl br). + { eapply Forall2_All2, All2_nth_error in H4; tea. + eapply declc. } + assert (wfbrctx' : wf_local Σ (Γ ,,, brctx)). + { rewrite /brctx. eapply wf_pre_case_branch_context; tea. } + assert (convbrctxsmash : conv_context Σ (Γ ,,, smash_context [] (case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl)) + (Γ ,,, smash_context [] brctx)). + { eapply conv_context_smash_end; tea. } + assert (spbrctx : spine_subst Σ Γ (skipn (ind_npars mdecl) args) (List.rev (skipn (ind_npars mdecl) args)) + (smash_context [] brctx)). + { pose proof (spine_subst_smash _ idxsubst0). + eapply spine_subst_cumul in X0. eapply X0. all:tea. + 1-2:apply smash_context_assumption_context; pcuic. + eapply X0. + apply wf_local_smash_end; tea. + move: cumargs. + rewrite /pargctxu /argctxu. + move: iparsubst0. + rewrite (firstn_app_left _ 0). + now rewrite (wf_predicate_length_pars H0). + intros iparsubst0. + clear X6. unshelve epose proof (ctx_inst_spine_subst _ X5). + eapply weaken_wf_local; tea. exact (on_minductive_wf_params_indices_inst isdecl _ cu). + rewrite (spine_subst_inst_subst iparsubst0) /= app_nil_r. + intros cum. + eapply cumul_ctx_rel_trans; tea. + apply cumul_ctx_rel_app. reflexivity. } + eapply context_conversion in hb. 3:tea. + 2:{ eapply wf_local_smash_end; tea. } + eapply (PCUICSubstitution.substitution _ Γ _ _ []) in hb. + 3:exact spbrctx. 2:tea. + cbn -[case_branch_type_gen] in hb. + rewrite subst_context_nil -heq_ind_npars in hb *. + eapply type_Cumul'. exact hb. + assumption. clear hb. + rewrite /case_branch_type. + set cbtyg := (case_branch_type_gen _ _ _ _ _ _ _ _ _). + (* Move back to the canonical branch context for the rest of the proof *) + transitivity (subst0 (List.rev (skipn (ind_npars mdecl) args)) (expand_lets brctx cbtyg.2)). + { eapply conv_cumul. + eapply (substitution_conv _ _ _ []). 3:eapply spbrctx. all:tea. + { eapply wf_local_smash_end => //. } + symmetry. eapply conv_expand_lets_conv_ctx; tea. reflexivity. + eapply conv_context_rel_app. now symmetry. } + cbn. rewrite lift_mkApps !subst_mkApps. - constructor. - { exists ps. red. - eapply type_mkApps; eauto. - eapply wf_arity_spine_typing_spine; eauto. - split. eapply validity; eauto. - eapply arity_spine_it_mkProd_or_LetIn; eauto. - simpl. constructor. - 2:{ constructor; pcuic. } - rewrite subst_mkApps /= map_app. unfold to_extended_list. - generalize (spine_subst_subst_to_extended_list_k subsidx). - rewrite to_extended_list_k_subst - PCUICSubstitution.map_subst_instance_constr_to_extended_list_k => ->. - move: (subslet_length subsidx). autorewrite with len => <-. - now rewrite map_map_compose map_subst_lift_id firstn_skipn. } - eapply conv_cumul. eapply mkApps_conv_args; auto. - { rewrite /pargctxu /argctxu. autorewrite with len. - rewrite simpl_lift; try lia. rewrite subst_subst_lift //; try reflexivity. - autorewrite with len. rewrite skipn_length. lia. - unfold argctx. lia. } - { rewrite !map_app. eapply All2_app. - * eapply All2_transitivity. intros x y z; eapply conv_trans; eauto. - 2:eauto. - (* 1: cshape indices are closed w.r.t. inds. - 2: parsubst and cparsubst are convertible - *) - pose proof (positive_cstr_closed_indices wf onc). - rewrite -(map_map_compose _ _ _ (subst (inds _ _ _) _ ∘ (subst_instance_constr u)) (subst parsubst #|argctx|)). - rewrite -(map_map_compose _ _ _ (subst_instance_constr u)). - rewrite (map_subst_closedn (inds _ _ _)). - { apply All_forallb. apply All_map. - eapply All_map_inv in X; eapply (All_impl X). - intros x Px. - eapply (closedn_expand_lets 0) in Px. - len in Px. - rewrite closedn_subst_instance_constr. - now rewrite /argctx; autorewrite with len. } - rewrite -(map_map_compose _ _ _ (subst (inds _ _ _) _ ∘ (subst_instance_constr u1)) (subst _ _)). - rewrite -(map_map_compose _ _ _ (subst_instance_constr u1)). - rewrite (map_subst_closedn (inds _ _ _)). - { apply All_forallb. apply All_map. - eapply All_map_inv in X; eapply (All_impl X). - intros x Px. - eapply (closedn_expand_lets 0) in Px. - len in Px. - rewrite closedn_subst_instance_constr. - now rewrite /argctx; autorewrite with len. } - rewrite (map_map_compose _ _ _ _ (subst0 (extended_subst pargctxu 0))). - change (fun x => subst0 (extended_subst pargctxu 0) _ ) with (expand_lets pargctxu). - rewrite -map_subst_app_simpl -(map_map_compose _ _ _ _ (subst0 cargsubst)) /=. - rewrite (subslet_length idxsubst0); autorewrite with len. - eapply All2_symmetry. intros x y. now symmetry. - pose proof (spine_subst_extended_subst idxsubst0). - unfold ind_subst in argctxu1; fold argctxu1 pargctxu1 in H. rewrite H. - eapply spine_subst_smash in idxsubst0; eauto. - epose proof (conv_terms_subst _ Γ (smash_context [] pargctxu1) (smash_context [] pargctxu) [] _ _ _ _ wf) as cv. - simpl in cv. forward cv. - eapply idxsubst0; eauto. - specialize (cv idxsubst0 argsubst). - forward cv. eapply All2_rev; auto. eapply All2_refl. reflexivity. - specialize (cv convidx). clear convidx. rewrite subst_context_nil /= in cv. - rewrite /pargctxu /argctx. assert (#|cshape_args cs| = #|argctxu|) as lenargctxu. - { rewrite /argctxu; autorewrite with len. reflexivity. } - rewrite lenargctxu. - assert(context_assumptions (cshape_args cs) = context_assumptions argctxu1). - { rewrite /argctxu1; autorewrite with len. reflexivity. } - rewrite {1}H0 in cv. - rewrite -(map_expand_lets_subst_comm _ _ _) in cv. - rewrite (map_expand_lets_subst_comm _ _ _). - assert(#|argctxu| = #|argctxu1|). - { rewrite /argctxu /argctxu1; autorewrite with len. reflexivity. } - assert(context_assumptions argctxu = context_assumptions (cshape_args cs)) as ->. - { rewrite /argctxu /argctxu1; autorewrite with len. reflexivity. } - rewrite -H2 in cv. - rewrite /pargctxu1. - epose proof (map_subst_expand_lets (List.rev (skipn (ind_npars mdecl) cargs)) - (subst_context cparsubst 0 argctxu1)). - change (All2 (fun x y : term => Σ;;; Γ |- x = y) ?t ?u) with (conv_terms Σ Γ t u). - eapply conv_terms_Proper. - rewrite H3. - 2:{ autorewrite with len. rewrite -H0 (context_subst_length2 idxsubst0). - autorewrite with len. rewrite context_assumptions_smash_context. - autorewrite with len. now simpl. } - rewrite -map_map_compose {1}/argctxu. reflexivity. reflexivity. - autorewrite with len. clear H3. - now rewrite {1}/argctx lenargctxu. - - * simpl. rewrite lift_mkApps !subst_mkApps /=. - constructor. 2:constructor. - assert (R_global_instance Σ.1 (eq_universe (global_ext_constraints Σ)) (eq_universe (global_ext_constraints Σ)) - (ConstructRef ind c0) (ind_npars mdecl + (context_assumptions (cshape_args cs))) u1 u). - { unfold R_ind_universes in equ. clear -equ onc eqargs isdecl declc. - rewrite /R_ind_universes /R_global_instance. - assert (global_variance Σ.1 (ConstructRef ind c0) - (ind_npars mdecl + context_assumptions (cshape_args cs)) = Some []). - { unfold global_variance, lookup_constructor, lookup_inductive, lookup_minductive. - change (fst_ctx Σ) with Σ.1. - destruct isdecl as [lookmind looki]. - red in lookmind. rewrite lookmind looki declc. - rewrite (cstr_args_length onc). - elim: leb_spec_Set; auto. unfold cdecl_args. lia. } - rewrite H. apply R_universe_instance_variance_irrelevant. - now apply R_global_instance_length in equ. } - transitivity (mkApps (tConstruct ind c0 u) cargs); first last. - symmetry. constructor. eapply eq_term_upto_univ_mkApps. - constructor. rewrite eqargs. apply H. - eapply All2_refl. intros; reflexivity. - eapply mkApps_conv_args; eauto. - rewrite 3!map_app. rewrite 3!map_map_compose. - rewrite /pargctxu /argctxu; autorewrite with len. - rewrite map_subst_subst_lift_lift. autorewrite with len. - rewrite skipn_length eqargs; try lia. subst argctx. lia. - set (ctx := subst_context parsubst 0 _). - pose proof (map_subst_extended_subst_lift_to_extended_list_k ctx). - unfold ctx in H0. autorewrite with len in H0. - rewrite {}H0 /to_extended_list. - erewrite spine_subst_subst_to_extended_list_k. - 2:eapply argsubst. - rewrite -{2}(firstn_skipn (ind_npars mdecl) cargs). - eapply All2_app; auto. apply All2_symmetry => //. - intros x y conv; now symmetry. - eapply All2_refl. intros; reflexivity. } + pose proof (wf_branch_length wfbr). + have lenskip: #|skipn (ind_npars mdecl) args| = (context_assumptions (cstr_args cdecl)). + { rewrite List.skipn_length eqargs; lia. } + have lenfirst: #|firstn (ind_npars mdecl) args| = (context_assumptions (ind_params mdecl)). + { rewrite firstn_length_le; try lia. now rewrite -(declared_minductive_ind_npars isdecl). } + have brctxlen : #|brctx| = #|cstr_args cdecl|. + { now rewrite /brctx !lengths. } + have pparamsl : #|pparams p| = context_assumptions (ind_params mdecl). + { move: (wf_predicate_length_pars H0). + now rewrite (declared_minductive_ind_npars isdecl). } + + rewrite simpl_lift; try lia. + rewrite subst_subst_lift // !lengths -H //; try lia. + rewrite map_app /= !map_app. eapply conv_cumul. + have wfparsargs : wf_local Σ + (subst_instance u (ind_params mdecl),,, + subst_context (inds (inductive_mind ci) u (ind_bodies mdecl)) + #|ind_params mdecl| (subst_instance u (cstr_args cdecl))). + { exact (on_constructor_wf_args declc Hu). } + have wfparsargs' : wf_local Σ + (subst_instance (puinst p) (ind_params mdecl),,, + 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 mkApps_conv_args; tea. reflexivity. + rewrite (firstn_app_left _ 0) ?Nat.add_0_r // /= ?app_nil_r in iparsubst0. + rewrite (firstn_app_left _ 0) ?Nat.add_0_r // /= ?app_nil_r in Hpars. + rewrite (skipn_all_app_eq) // in subsidx. + have brctxass : context_assumptions brctx = context_assumptions (cstr_args cdecl). + { now rewrite /brctx !lengths. } + eapply All2_app. + * set(indsub := inds _ _ _). + rewrite H. + relativize (map (subst0 _) _). + 2:{ + rewrite !map_map_compose. apply map_ext => x. + symmetry. + rewrite -/(subst_let_expand _ _ _) -/(subst_let_expand_k _ _ _ _). + rewrite -brctxass -brctxlen -expand_lets_eq. + rewrite {1 2}/brctx {1 2}/pre_case_branch_context {1}subst_context_length. + rewrite /subst_let_expand_k (expand_lets_subst_comm _ _ _) !lengths. + relativize (context_assumptions _). + erewrite <- subst_app_simpl. 2:now rewrite !lengths. + rewrite subst_app_decomp. + relativize #|cstr_args cdecl|. + erewrite subst_let_expand_app. + 2-4:rewrite ?lengths; try lia; reflexivity. + rewrite /subst_let_expand. + reflexivity. } + move: Hargs. + move: convidx. + change (fun x y => Σ ;;; Γ |- x = y) with (conv Σ Γ). + intros cv convidx. + eapply (conv_terms_subst _ _ _ _ []) in cv. + 4:{ exact (spine_subst_smash _ idxsubst0). } + 4:{ exact (spine_subst_smash _ idxsubst0). } + all:tea. 2:{ eapply wf_local_smash_end; tea. eapply idxsubst0. } + 2:{ eapply All2_rev. eapply All2_refl. reflexivity. } + rewrite subst_context_nil /= in cv. simpl in cv. + rewrite skipn_all_app_eq // in convidx. + + assert(conv_terms Σ Γ + (map + (fun x : term => + subst0 (List.rev args) + (expand_lets (argctxu1 ++ subst_instance u (ind_params mdecl)) (subst_instance u x))) + (cstr_indices cdecl)) indices). + { etransitivity; tea. + pose proof (positive_cstr_closed_indices _ declc). + eapply All2_map. eapply All_map_inv in X0. + eapply All_All2; tea. intros x. + cbn. intros cl. + eapply conv_refl'. + epose proof + (spine_subst_app Σ Γ (subst_instance u (ind_params mdecl)) + (subst_context + (inds (inductive_mind ci) u (ind_bodies mdecl)) + #|ind_params mdecl| (subst_instance u (cstr_args cdecl))) + (firstn (ind_npars mdecl) args) + (skipn (ind_npars mdecl) args) (cargsubst ++ cparsubst) wf + ). + rewrite lenfirst in X3. len in X3. + specialize (X3 eq_refl). + forward X3. { rewrite -app_context_assoc. eapply weaken_wf_local; tea. } + forward X3. split. + rewrite skipn_all_app_eq; len. + now rewrite -(PCUICContextSubst.context_subst_length idxsubst0); len. + apply cparsubst0. + pose proof (PCUICContextSubst.context_subst_length idxsubst0). + len in H3. + rewrite firstn_app H3 firstn_all Nat.sub_diag /= app_nil_r skipn_all_app_eq //. + rewrite firstn_skipn in X3. + rewrite (spine_subst_inst_subst_term X3). + f_equal. + pose proof (PCUICInductiveInversion.on_constructor_wf_args declc). + eapply closed_wf_local in X4; tea. + rewrite !closedn_ctx_app /= in X4 *. + move/andb_and: X4 => [] /andb_and [] clar clp clargs. + len in clargs. + rewrite -(subst_closedn (inds (inductive_mind ci) u (ind_bodies mdecl)) + (context_assumptions (ind_params mdecl ,,, cstr_args cdecl)) + (expand_lets _ _)). + { rewrite /argctxu1. + relativize (context_assumptions _). + eapply (closedn_expand_lets 0). + rewrite !closedn_ctx_app /=. + apply andb_true_iff; split. + rewrite closedn_subst_instance_context. + eapply (declared_inductive_closed_params isdecl). + rewrite subst_instance_length. + eapply (closedn_ctx_subst 0). simpl. + rewrite /ind_subst inds_length. + now rewrite closedn_subst_instance_context. + eapply (declared_minductive_closed_inds isdecl). + rewrite /= app_length subst_context_length !subst_instance_length. + eapply (PCUICSpine.closedn_expand_lets 0) in cl. + rewrite closedn_subst_instance. + now rewrite /= app_length in cl. + rewrite /= !context_assumptions_app /= context_assumptions_subst_context // + !context_assumptions_subst_instance //. } + (* 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 + !context_assumptions_subst_context !context_assumptions_subst_instance. } + f_equal. + * rewrite subst_context_app closed_ctx_subst. + rewrite closedn_subst_instance_context. + now apply (declared_inductive_closed_params isdecl). + f_equal. len. + rewrite closed_ctx_subst //. + rewrite /argctxu1. simpl. + eapply (closedn_ctx_subst 0). simpl. + rewrite /ind_subst inds_length closedn_subst_instance_context //. + eapply (declared_minductive_closed_inds isdecl). + * now rewrite /argctxu1; len. } + clear convidx. + etransitivity; tea. + transitivity (map (subst0 (List.rev (skipn (ind_npars mdecl) args))) + (map (subst iparsubst (context_assumptions (cstr_args cdecl))) + (map (expand_lets argctxu) + (map (subst_instance (puinst p)) (cstr_indices cdecl))))). + 2:{ + rewrite !map_map_compose. + eapply All2_map. + rewrite !map_map_compose in cv. + eapply All2_map_inv in cv. + eapply All2_All in cv. + eapply All_All2; tea. cbn. + intros x Hx. + etransitivity. symmetry; tea. + rewrite (spine_subst_inst_subst_term_k cparsubst0). + pose proof (subst_let_expand_app). + relativize (context_assumptions (cstr_args cdecl)). + erewrite <-subst_app_simpl. 2:now len. + rewrite -List.rev_app_distr firstn_skipn. len. + rewrite lenskip expand_lets_app /argctxu1. + now 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 All2_map. + eapply All_All2. + exact (All_map_inv _ _ _ (positive_cstr_closed_indices _ declc)). + cbn => x. + rewrite -(closed_ctx_subst indsub 0 (subst_instance _ _ ,,, _)). + { now eapply closed_wf_local in wfparsargs'. } + relativize (#|ind_params _| + _). + erewrite expand_lets_subst_comm; rewrite !lengths. + 2:rewrite !lengths; lia. + rewrite -context_assumptions_app. + move/(PCUICSpine.closedn_expand_lets 0) => /=; rewrite /= !lengths => clx. + rewrite (subst_closedn indsub (_ + _)). + relativize (_ + _). eapply (closedn_expand_lets 0). + 2-3:rewrite /= !lengths // closedn_subst_instance //. + eapply closed_wf_local; tea. + rewrite (spine_subst_inst_subst_term_k iparsubst0). + change (ind_subst _ _ _) with indsub. + relativize (context_assumptions _). + erewrite <-subst_app_simpl. 2:now len. + rewrite List.rev_length lenskip /=. + relativize (context_assumptions _). + erewrite <- expand_lets_app. + 2:now rewrite !lengths. + reflexivity. + + * rewrite lift_mkApps /= !subst_mkApps /=. constructor. 2:constructor. + rewrite H. + 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 _). + relativize (to_extended_list (cstr_args cdecl)). + erewrite map_expand_lets_to_extended_list. + 2:{ etransitivity. + 2:apply to_extended_list_case_branch_context. + eapply conv_context_rel_to_extended_list. + apply conv_context_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 _ _ _). + now rewrite subst_let_expand_lift_id //; len. } + rewrite map_id. + transitivity (mkApps (tConstruct ci c (puinst p)) args). + rewrite -(firstn_skipn (ind_npars mdecl) args). + eapply mkApps_conv_args; tea. reflexivity. + eapply All2_app. eapply All2_symP => //. intro; now symmetry. + rewrite firstn_skipn. eapply All2_refl; reflexivity. + rewrite firstn_skipn. constructor. + eapply eq_term_upto_univ_mkApps. + 2:reflexivity. + 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] ?] ?]] => //. unfold unfold_cofix in e. rewrite Hnth in e. noconf e. - clear heq_map_option_out X5 heq_build_case_predicate_type forall_u. eapply typing_spine_strengthen in t; eauto. clear c. eapply wf_cofixpoint_typing_spine in t; eauto. - 2:eapply validity_term; eauto. + 2:eapply validity; eauto. unfold check_recursivity_kind in t. rewrite isdecl.p1 in t. apply Reflect.eqb_eq in t. rewrite t /= in heq_isCoFinite. discriminate. - - - (* Case congruence on the predicate *) - eapply (type_Cumul _ _ _ (mkApps p' (skipn npar args ++ [c]))). - eapply build_branches_type_red in heq_map_option_out as [brtys' [eqbrtys alleq]]; eauto. - eapply type_Case; eauto. - * eapply All2_trans'; eauto. simpl. - intros. destruct X1 as ((((? & ?) & ?) & [s [Hs IH]]) & ? & ?). - specialize (IH _ r). - intuition auto. now transitivity y.1. - eapply type_Cumul'; eauto. now exists s. - now eapply conv_cumul, red_conv, red1_red. - now exists s. - * pose proof typec as typec'. - eapply (env_prop_typing _ _ validity) in typec' as wat; auto. - unshelve eapply isType_mkApps_Ind in wat as [parsubst [argsubst wat]]; eauto. - set (oib := on_declared_inductive wf isdecl) in *. clearbody oib. - destruct oib as [onind oib]. - destruct wat as [[spars sargs] cu]. - unshelve eapply (build_case_predicate_type_spec (Σ.1, _)) in heq_build_case_predicate_type as [parsubst' [cparsubst Hpty]]; eauto. - rewrite {}Hpty in typep. - subst npar. - assert (wfps : wf_universe Σ ps). - { eapply validity in typep; auto. eapply PCUICWfUniverses.isType_wf_universes in typep. - rewrite PCUICWfUniverses.wf_universes_it_mkProd_or_LetIn in typep. - move/andb_and: typep => /= [_ /andb_and[_ typep]]. - now apply (ssrbool.elimT PCUICWfUniverses.wf_universe_reflect) in typep. auto. } - pose proof (context_subst_fun cparsubst spars). subst parsubst'. clear cparsubst. - eapply type_mkApps. eauto. - eapply wf_arity_spine_typing_spine; eauto. - split. apply (env_prop_typing _ _ validity) in typep as ?; eauto. - eapply arity_spine_it_mkProd_or_LetIn; eauto. - simpl. constructor; [ |constructor]. - rewrite subst_mkApps. simpl. - rewrite map_app. rewrite map_map_compose. - rewrite map_subst_lift_id_eq. now rewrite (subslet_length sargs); autorewrite with len. - move: (spine_subst_subst_to_extended_list_k sargs). - rewrite to_extended_list_k_subst PCUICSubstitution.map_subst_instance_constr_to_extended_list_k. - move->. now rewrite firstn_skipn. - * now eapply conv_cumul, conv_sym, red_conv, red_mkApps_f, red1_red. - + + - (* Case congruence on a parameter *) + destruct X1, X4. + assert (isType Σ Γ (mkApps (it_mkLambda_or_LetIn (pcontext p) (preturn p)) (indices ++ [c]))). + { eapply validity. econstructor; eauto. + eapply (All2i_impl X9); intuition auto. } + set (ptm := it_mkLambda_or_LetIn _ _) in *. + cbn -[ptm it_mkLambda_or_LetIn] in *. + have wfparinds : wf_local Σ + (Γ,,, subst_instance (puinst p) (ind_params mdecl,,, ind_indices idecl)). + { eapply weaken_wf_local; tea. + eapply (on_minductive_wf_params_indices_inst isdecl _ H1). } + have ctxi' : ctx_inst Σ Γ (params' ++ indices) + (List.rev + (subst_instance p.(puinst) (ind_params mdecl,,, ind_indices idecl))). + { eapply OnOne2_app_r in o. + unshelve eapply (ctx_inst_merge' _ _ _ _ _ X6 X5). 2:tea. + unshelve eapply (ctx_inst_spine_subst _ X5); tea. } + pose proof X5 as X5'. + unshelve epose proof (ctx_inst_spine_subst _ X5); tea. + eapply spine_subst_smash in X3; 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. + pose proof (declared_minductive_ind_npars isdecl). + have lenidx : (#|List.rev indices| = (context_assumptions (ind_indices idecl))) by (len; lia). + rewrite subst_instance_app smash_context_app_expand in X3. + eapply spine_subst_app_inv in X3 as [sppars spargs]; tea. 2:len. + len in sppars. len in spargs. + 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. + have lenpars' := (OnOne2_length o). + unshelve epose proof (ctx_inst_spine_subst _ ctxi');tea. + pose proof (spine_codom_wf _ _ _ _ _ X3);tea. + pose proof (spine_subst_smash _ X3); tea. all:tea. + rewrite subst_instance_app smash_context_app_expand in X7. + eapply spine_subst_app_inv in X7 as [sppars' spargs']; tea. + 2:len. len in sppars'. len in spargs'. + 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'. + have wfp' : wf_predicate mdecl idecl (set_pparams p params'). + { move: H0. rewrite /wf_predicate /wf_predicate_gen /=. + rewrite (OnOne2_length o). intuition auto. } + have convctx' : + conv_context Σ (p.(pcontext) ++ Γ) + (case_predicate_context ci mdecl idecl (set_pparams p params') ++ Γ). + { move: X2 => cv. + eapply conv_context_app. + eapply conv_context_set_binder_name. + eapply All2_map_left, All2_same. intros; reflexivity. + eapply conv_context_rel_app in cv. + eapply conv_context_set_binder_name_inv in cv. + 2:{ destruct H0 as [_ wfnas]. + eapply Forall2_All2 in wfnas. + move: wfnas. simpl. + intros wfa. + rewrite /pre_case_predicate_context_gen. + depelim wfa. rewrite H0. constructor; auto. + now eapply All2_eq_binder_subst_context_inst. } + (* move: X6. *) + eapply conv_context_rel_app. + eapply conv_context_rel_app in cv. + etransitivity; tea. + eapply conv_context_rel_app. + rewrite /pre_case_predicate_context_gen. + (* We need to reason on the argument spines *) + + constructor. clear X9. + match goal with + |- All2_fold _ ?X ?Y => + change (conv_context_rel Σ Γ X Y) + end. + apply conv_context_rel_app. + eapply onone_red_cont_context_subst. + 2:{ eapply subslet_untyped_subslet, sppars. } + 2:{ eapply subslet_untyped_subslet, sppars'. } + rewrite subst_instance_expand_lets_ctx. + eapply wf_local_expand_lets. now rewrite subst_instance_app app_context_assoc in X4. + tas. all:tea. all:len. + constructor; auto. + eapply mkApps_conv_args; tea. reflexivity. + eapply All2_app. eapply All2_map. + eapply OnOne2_All2; tea. + intros. eapply red_conv. + eapply weakening_red_0. now rewrite !lengths. + now eapply red1_red. reflexivity. + eapply All2_refl. reflexivity. } + have isty' : isType Σ Γ (mkApps (tInd ci (puinst p)) (params' ++ indices)). + { eexists; eapply isType_mkApps_Ind; tea. } + have wfcpc' : wf_local Σ (Γ ,,, case_predicate_context ci mdecl idecl (set_pparams p params')). + { eapply wf_case_predicate_context; tea. } + have typec' : Σ;;; Γ |- c : mkApps (tInd ci (puinst p)) (params' ++ indices). + { eapply type_Cumul'; tea. + eapply conv_cumul. eapply mkApps_conv_args; pcuic. + eapply All2_app. 2:eapply All2_refl; reflexivity. + eapply OnOne2_All2; tea. all:pcuic. } + eapply type_Cumul'; [econstructor; cbn -[it_mkLambda_or_LetIn]; eauto|..]; tea. + 2:{ reflexivity. } + (* The branches contexts also depend on the parameters. *) + epose proof (wf_case_branches_types (p:=set_pparams p params') ps _ brs isdecl isty' wfp'). + specialize (X7 IHp convctx' H4). + eapply All2i_All2_mix_left in X7; tea. + 2:now eapply Forall2_All2 in H4. + eapply All2i_All2i_mix in X9; tea. clear X7. + eapply (All2i_impl X9); clear X9. intros cstr cdecl br. cbv zeta. + rewrite !case_branch_type_fst. + do 2 case. move=> wfbr. case => wfcbc' wfcbcty'. + case. case. case => wfbctx _ cvbrp. + move=> [] [] brty [] wfcbc IHcbc [] IHbody [] brtys IHbrtys. + eapply conj_impl. solve_all. + * now eapply typing_wf_local in wfcbcty'. + * etransitivity; tea. + rewrite /case_branch_context /case_branch_context_gen. + eapply onone_red_cont_context_subst. + 2:{ eapply subslet_untyped_subslet, sppars. } + 2:{ eapply subslet_untyped_subslet, sppars'. } + 2:{ cbn; tea. } + eapply wf_local_expand_lets => //. + * move=> [wfbrctx [wfcbc'' cv]]. split => //. + eapply type_Cumul'; tea. + + eexists; tea. red. eapply context_conversion; tea. + now symmetry. + + (* Preservation of case branch type *) + eapply conv_cumul. + eapply conv_conv_ctx; tea. + 2:{ symmetry. exact cv. } + eapply mkApps_conv_args; tea. reflexivity. + eapply All2_app. eapply All2_map. + eapply All2_map. eapply All2_refl. + intros x. eapply red_conv. + relativize #|cstr_args cdecl|. + eapply (red_red _ Γ _ _); tea. eapply All2_rev => //. + eapply OnOne2_All2; tea; intros; pcuic. + eapply subslet_untyped_subslet, sppars. + eapply (case_branch_context_length_args); tea. + constructor. eapply mkApps_conv_args; tea; try reflexivity. + eapply All2_app. eapply All2_map. + eapply OnOne2_All2; tea; intros; try reflexivity. + eapply red_conv. + eapply weakening_red_0. symmetry. + now eapply case_branch_context_length_args. + now eapply red1_red. eapply All2_refl. reflexivity. + constructor. + + eapply context_conversion; tea. + now symmetry. + + - (* Case congruence on the return clause context *) + destruct X1, X4 as []. + set (ptm := it_mkLambda_or_LetIn _ _). + assert (isType Σ Γ (mkApps ptm (indices ++ [c]))). + { eapply validity. econstructor; eauto. + apply (All2i_impl X9). intuition auto. } + eapply type_Cumul'; tea. + * eapply type_Case; eauto. + + rewrite /wf_predicate /wf_predicate_gen. + now rewrite -(OnOne2_local_env_forget_types _ _ _ o). + + simpl. + eapply wf_local_app; tea. + eapply w; tea; reflexivity. + + cbn -[case_predicate_context]. + etransitivity; tea. + eapply red_one_decl_conv_context in o. + symmetry. exact o. + rewrite /case_predicate_context /=. + now rewrite -(OnOne2_local_env_forget_types _ _ _ o). + + cbn. eapply context_conversion; tea. + eapply wf_local_app; tea. + eapply w; tea; reflexivity. + now eapply red_one_decl_conv_context in o. + + rewrite /case_predicate_context. + now rewrite -(OnOne2_local_env_forget_types _ _ _ o). + + eapply Forall2_All2 in H4. + eapply All2i_All2_mix_left in X9; tea. eapply (All2i_impl X9); intuition auto. + rewrite case_branch_type_fst. + set (cbty := case_branch_type _ _ _ _ _ _ _). + assert (Σ ;;; Γ ,,, bcontext y |- (cbty x).2 : tSort ps). + { eapply b3. + rewrite /cbty /case_branch_type /=. + eapply red1_mkApps_f. + relativize #|cstr_args x|. + eapply (weakening_red1 _ []); tea. 2:tas. + now eapply red1_it_mkLambda_or_LetIn_ctx. + apply (wf_branch_length a2). } + solve_all. + eapply type_Cumul; tea. + rewrite /cbty /case_branch_type. + eapply conv_cumul; cbn. + eapply mkApps_conv_args; tea. + 2:{ eapply All2_refl. reflexivity. } + relativize #|cstr_args x|. + eapply (weakening_conv _ _ []); tea. 2:tas. + eapply it_mkLambda_or_LetIn_conv; tea. 2:reflexivity. + now eapply red_one_decl_conv_context. + apply (wf_branch_length a2). + * eapply conv_cumul. + eapply mkApps_conv_args; tea. + 2:{ eapply All2_refl; reflexivity. } + eapply it_mkLambda_or_LetIn_conv; tea. 2:reflexivity. + simpl. + eapply red_one_decl_conv_context in o. + now symmetry. + + - (* Case congruence on the return clause type *) + destruct X1, X4 as []. + set (ptm := it_mkLambda_or_LetIn _ _). + assert (isType Σ Γ (mkApps ptm (indices ++ [c]))). + { eapply validity. econstructor; eauto. + apply (All2i_impl X9). intuition auto. } + eapply type_Cumul'; tea. + * eapply type_Case; eauto. + eapply All2i_All2_mix_left in X9; tea. + 2:{ eapply Forall2_All2 in H4. exact H4. } + eapply (All2i_impl X9); intuition auto. + all:set (brty := case_branch_type _ _ _ _ _ _ _ _). + pose proof (wf_branch_length a2). + + assert (Σ ;;; (Γ ,,, bcontext y) |- brty.2 : tSort ps). + { eapply b3. + rewrite /brty /case_branch_type /=. + eapply red1_mkApps_f. + relativize #|cstr_args x|. + eapply (weakening_red1 _ []); tea. 2:tas. + now eapply red1_it_mkLambda_or_LetIn. } + intuition auto. + eapply type_Cumul; tea. + rewrite /brty. + rewrite /case_branch_type /case_branch_type_gen /=. + eapply conv_cumul. + eapply mkApps_conv_args; tea. + 2:{ eapply All2_refl. reflexivity. } + relativize #|cstr_args x|. + eapply (weakening_conv _ _ []); tea. 2:tas. + eapply it_mkLambda_or_LetIn_conv; tea. reflexivity. + eapply red_conv; tea. now eapply red1_red. + * eapply conv_cumul, mkApps_conv_args; tea; try reflexivity. + eapply it_mkLambda_or_LetIn_conv; tea. reflexivity. + eapply conv_conv_ctx; tea. symmetry. + eapply red_conv => //. simpl. now eapply red1_red. + reflexivity. + eapply All2_same; reflexivity. + - (* Case congruence on discriminee *) - eapply type_Cumul. eapply type_Case; eauto. - * solve_all. destruct b0 as [s Hs]; exists s; pcuic. - * pose proof typec as typec'. - eapply (env_prop_typing _ _ validity) in typec' as wat; auto. - unshelve eapply isType_mkApps_Ind in wat as [parsubst [argsubst wat]]; eauto. - set (oib := on_declared_inductive wf isdecl) in *. clearbody oib. - destruct oib as [onind oib]. - destruct wat as [[spars sargs] cu]. - unshelve eapply (build_case_predicate_type_spec (Σ.1, _)) in heq_build_case_predicate_type as [parsubst' [cparsubst Hpty]]; eauto. - rewrite {}Hpty in typep. - assert (wfps : wf_universe Σ ps). - { eapply validity in typep; auto. eapply PCUICWfUniverses.isType_wf_universes in typep. - rewrite PCUICWfUniverses.wf_universes_it_mkProd_or_LetIn in typep. - move/andb_and: typep => /= [_ /andb_and[_ typep]]. - now apply (ssrbool.elimT PCUICWfUniverses.wf_universe_reflect) in typep. auto. } - subst npar. - pose proof (context_subst_fun cparsubst spars). subst parsubst'. clear cparsubst. - eapply type_mkApps. eauto. - eapply wf_arity_spine_typing_spine; eauto. - split. apply (env_prop_typing _ _ validity) in typep; eauto. - eapply arity_spine_it_mkProd_or_LetIn; eauto. - simpl. constructor; [ |constructor]. - rewrite subst_mkApps. simpl. - rewrite map_app. rewrite map_map_compose. - rewrite map_subst_lift_id_eq. now rewrite (subslet_length sargs); autorewrite with len. - move: (spine_subst_subst_to_extended_list_k sargs). - rewrite to_extended_list_k_subst PCUICSubstitution.map_subst_instance_constr_to_extended_list_k. - move->. now rewrite firstn_skipn. + destruct X4 as []. + set (ptm := it_mkLambda_or_LetIn _ _). + destruct X1. + assert (isType Σ Γ (mkApps ptm (indices ++ [c]))). + { eapply validity. econstructor; eauto. + apply (All2i_impl X9). intuition auto. } + eapply type_Cumul'. eapply type_Case; eauto. + * solve_all. + * tas. * eapply conv_cumul, conv_sym, red_conv, red_mkApps; auto. eapply All2_app; [eapply All2_refl; reflexivity|now constructor]. - + - (* Case congruence on branches *) + destruct X1, X4. eapply type_Case; eauto. - eapply (OnOne2_All2_All2 o X5). - intros [] []; simpl. intros. - intuition auto. destruct b as [s [Hs IH]]; eauto. subst. - intros [] [] []; simpl. intros. - intuition auto. subst. - reflexivity. - destruct b0 as [s [Hs IH]]; eauto. - + * eapply Forall2_All2 in H4. + move: (All2_sym _ _ _ H4) => wfb. + red. eapply All2_Forall2. + apply All2_sym. + eapply (OnOne2_All2_All2 o wfb); auto. + intros [] []; simpl. intros. + destruct X1 as [[r1 eq]|[? ?]]. subst bcontext0. exact H. + red. red in H. + eapply OnOne2_local_env_forget_types in o0. + now rewrite -o0. + * eapply (OnOne2_All2i_All2i o X9). + intros n [] []; simpl. intros. intuition auto. + intros n [ctx b] [ctx' b'] cdecl; cbn. + rewrite !case_branch_type_fst. + intros [[red <-]|[red <-]]; + intros [[[wfctx IHctx] convctx] [[Hb [wfcbc IHcbc]] [IHb [Hbty IHbty]]]]. + intuition auto. + rewrite /case_branch_type -(OnOne2_local_env_forget_types _ _ _ red). + intuition auto; tea. + + eapply wf_local_app; tea. + eapply IHctx; tea; reflexivity. + + eapply red_one_decl_conv_context in red. + etransitivity; tea. now symmetry. + + eapply context_conversion; tea. + eapply wf_local_app; tea. + eapply IHctx; tea; reflexivity. + eapply red_one_decl_conv_context in red. + now symmetry. + + eapply context_conversion; tea. + eapply wf_local_app; tea. + eapply IHctx; tea; reflexivity. + eapply red_one_decl_conv_context in red. + now symmetry. + - (* Proj CoFix congruence *) assert(typecofix : Σ ;;; Γ |- tProj p (mkApps (tCoFix mfix idx) args0) : subst0 (mkApps (tCoFix mfix idx) args0 :: List.rev args) - (subst_instance_constr u pdecl.2)). + (subst_instance u pdecl.2)). { econstructor; eauto. } - pose proof (env_prop_typing _ _ validity _ _ _ _ _ typec). + pose proof (env_prop_typing _ _ validity_env _ _ _ _ _ typec). eapply inversion_mkApps in typec as [? [tcof tsp]]; auto. eapply type_tCoFix_inv in tcof as [d [[[Hnth wfcofix] Hbody] Hcum]]; auto. unfold unfold_cofix in e. @@ -773,11 +1512,12 @@ Proof. eapply conv_cumul. rewrite (subst_app_decomp [mkApps (subst0 (cofix_subst mfix) (dbody d)) args0]) (subst_app_decomp [mkApps (tCoFix mfix idx) args0]). eapply conv_sym, red_conv. - destruct (on_declared_projection wf isdecl) as [oi onp]. - epose proof (subslet_projs _ _ _ _ wf (let (x, _) := isdecl in x)). + destruct (on_declared_projection isdecl) as [oi onp]. + epose proof (subslet_projs _ _ _ _ wf isdecl). set (oib := declared_inductive_inv _ _ _ _) in *. simpl in onp, X2. - destruct (ind_cshapes oib) as [|? []]; try contradiction. + destruct (ind_ctors idecl) as [|? []]; try contradiction. destruct onp as [[[tyargctx onps] Hp2] onp]. + destruct (ind_cunivs oib) as [|? []]; try contradiction. specialize (X2 onps). red in onp. destruct (nth_error (smash_context [] _) _) eqn:Heq; try contradiction. @@ -787,31 +1527,32 @@ Proof. set (projsubst := projs _ _ _) in *. rewrite eq. eapply (substitution_untyped_red _ Γ - (smash_context [] (subst_instance_context u (ind_params mdecl))) []). auto. - { unshelve eapply isType_mkApps_Ind in X1 as [parsubst [argsubst Hind]]; eauto. - eapply (let (x, _) := isdecl in x). - unfold on_declared_inductive in Hind. fold oib in Hind. simpl in Hind. + (smash_context [] (subst_instance u (ind_params mdecl))) []). auto. + { eapply isType_mkApps_Ind_inv in X1 as [parsubst [argsubst Hind]]; eauto. + 2:eapply isdecl. + simpl in Hind. destruct Hind as [[sppars spargs] cu]. rewrite firstn_all2 in sppars. lia. eapply spine_subst_smash in sppars. eapply subslet_untyped_subslet. eapply sppars. auto. } - rewrite - !subst_subst_instance_constr. + rewrite !subst_instance_subst. rewrite distr_subst. rewrite distr_subst. rewrite distr_subst. - autorewrite with len. - rewrite -lift_subst_instance_constr. + rewrite !map_length !List.rev_length. + rewrite subst_instance_lift. rewrite -(Nat.add_1_r (ind_npars mdecl)) Nat.add_assoc. - rewrite {2 5}/projsubst. autorewrite with len. + rewrite {2 5}/projsubst. rewrite Nat.add_0_r. rewrite -(commut_lift_subst_rec _ _ 1 (#|projsubst| + ind_npars mdecl)). rewrite /projsubst. autorewrite with len. lia. - rewrite !simpl_subst_k //. - rewrite projs_subst_instance_constr. + rewrite !projs_length. + rewrite /projsubst !simpl_subst_k //. + rewrite [subst_instance _ (projs _ _ _)]projs_subst_instance. rewrite projs_subst_above //. lia. simpl. rewrite !subst_projs_inst !projs_inst_lift. - eapply (red_red _ (Γ ,,, smash_context [] (subst_instance_context u (ind_params mdecl))) - (skipn (context_assumptions (cshape_args c) - p.2) - (smash_context [] (subst_context (inds (inductive_mind p.1.1) u (ind_bodies mdecl)) #|ind_params mdecl| (subst_instance_context u (cshape_args c))))) []); auto. + eapply (red_red _ (Γ ,,, smash_context [] (subst_instance u (ind_params mdecl))) + (skipn (context_assumptions (cstr_args c) - p.2) + (smash_context [] (subst_context (inds (inductive_mind p.1.1) u (ind_bodies mdecl)) #|ind_params mdecl| (subst_instance u (cstr_args c))))) []); auto. ** eapply All2_map. eapply (All2_impl (P:=fun x y => red Σ.1 Γ x y)). 2:{ intros x' y' hred. rewrite heq_length. @@ -823,79 +1564,75 @@ Proof. unfold unfold_cofix. rewrite Hnth. reflexivity. ** rewrite -projs_inst_lift. rewrite -subst_projs_inst. - assert (p.2 = context_assumptions (cshape_args c) - (context_assumptions (cshape_args c) - p.2)) by lia. + assert (p.2 = context_assumptions (cstr_args c) - (context_assumptions (cstr_args c) - p.2)) by lia. rewrite {1}H0. rewrite -skipn_projs map_skipn subst_projs_inst. eapply untyped_subslet_skipn. destruct p as [[[? ?] ?] ?]. simpl in *. rewrite /indsubst. eapply X2. - (* Proj Constructor reduction *) - pose proof (env_prop_typing _ _ validity _ _ _ _ _ typec). + pose proof (validity typec). simpl in typec. pose proof typec as typec'. eapply inversion_mkApps in typec as [A [tyc tyargs]]; auto. - eapply (inversion_Construct Σ wf) in tyc as [mdecl' [idecl' [cdecl' [wfl [declc [Hu tyc]]]]]]. + eapply (inversion_Construct Σ wf) in tyc as [mdecl' [idecl' [cdecl [wfl [declc [Hu tyc]]]]]]. pose proof typec' as typec''. + destruct (declared_projection_declared_constructor isdecl declc); subst mdecl' idecl'. + epose proof (declared_projection_type_and_eq wf isdecl). unshelve eapply Construct_Ind_ind_eq in typec'; eauto. - unfold on_declared_constructor in typec'. - destruct declc as [decli declc]. - unfold on_declared_inductive in typec'. - destruct declared_constructor_inv as [cs [Hnth onc]]. + destruct (on_declared_constructor declc) as [[onmind oin] [cs [Hnth onc]]]. simpl in typec'. - pose proof isdecl as isdecl'. - destruct isdecl' as [decli' [H0 Hi]]. - destruct (declared_inductive_inj decli' decli) as []; subst mdecl' idecl'. - simpl in decli'. - set (pdecl' := conj decli isdecl.p2 : declared_projection Σ.1 mdecl idecl (i, pars, narg) pdecl). - epose proof (declared_projection_type_and_eq wf pdecl'). simpl in X2. - pose proof (subslet_projs Σ _ _ _ _ decli) as projsubsl. - set(oib := declared_inductive_inv _ wf wf decli) in *. - change (declared_inductive_inv weaken_env_prop_typing wf wf decli) with oib in X2. + pose proof (subslet_projs Σ _ _ _ _ isdecl) as projsubsl. + set(oib := declared_inductive_inv _ wf wf _) in *. pose proof (onProjections oib) as onProjs. clearbody oib. - forward onProjs. clear pdecl'. - eapply nth_error_Some_length in H0. simpl in H0. - intros Hp. apply (f_equal (@length _)) in Hp. rewrite Hp /= in H0. lia. - simpl in H0. + forward onProjs. destruct isdecl as [? [hnth ?]]. + eapply nth_error_Some_length in hnth. simpl in hnth. + intros Hp. apply (f_equal (@length _)) in Hp. rewrite Hp /= in hnth. lia. simpl in *. + move: (proj2 declc). + simpl in *. + destruct ind_ctors as [|? []] => //. + intros [= ->]. + destruct X2 as [projty projeq]. destruct typec' as [[[[_ equ] cu] eqargs] [cparsubst [cargsubst [iparsubst [iidxsubst ci]]]]]. destruct ci as ((([cparsubst0 iparsubst0] & idxsubst0) & subsidx) & [s [typectx [Hpars Hargs]]]). - destruct ind_cshapes as [|? []]; try contradiction. - destruct X2 as [projty projeq]. - noconf Hnth. + destruct ind_cunivs as [|? ?] => //; noconf Hnth. specialize (projsubsl onProjs). destruct onProjs. - pose proof (on_declared_minductive wf isdecl.p1.p1) as onmind. eapply nth_error_alli in on_projs; eauto. + 2:eapply isdecl. simpl in on_projs. eapply typing_spine_strengthen in tyargs; eauto. rewrite -(firstn_skipn (ind_npars mdecl) args0) in tyargs, e |- *. - subst pars. assert(#|firstn (ind_npars mdecl) args0| = ind_npars mdecl). rewrite firstn_length_le. lia. lia. - rewrite nth_error_app_ge in e. lia. - rewrite H in e. replace (ind_npars mdecl + narg - ind_npars mdecl) with narg in e by lia. - epose proof (declared_constructor_valid_ty _ _ _ _ _ 0 cdecl' _ wf wfΓ) as Hty. - forward Hty by (split; eauto). - forward Hty. eapply Hu. + rewrite nth_error_app_ge in e. rewrite H. + pose proof (onNpars onmind). + pose proof (proj2 (proj2 isdecl)). simpl in *. lia. + rewrite H in e. destruct (proj2 isdecl). simpl in H1. subst pars. + replace (ind_npars mdecl + narg - ind_npars mdecl) with narg in e by lia. + epose proof (declared_constructor_valid_ty _ _ _ _ _ 0 cdecl _ wf wfΓ declc Hu) as Hty. unfold type_of_constructor in tyargs, Hty. - rewrite [cdecl'.1.2]onc.(cstr_eq) in tyargs, Hty. - rewrite !subst_instance_constr_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn in tyargs, Hty. + rewrite onc.(cstr_eq) in tyargs, Hty. + rewrite !subst_instance_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn in tyargs, Hty. eapply typing_spine_inv in tyargs as [arg_sub [[spargs iswat] sp]]; eauto. 2:{ rewrite !context_assumptions_fold. - rewrite subst_instance_context_assumptions. rewrite H. + rewrite subst_instance_assumptions. rewrite H. apply onNpars in onmind. lia. } rewrite closed_ctx_subst in spargs. { eapply closed_wf_local; eauto. eapply on_minductive_wf_params; eauto. } pose proof (spine_subst_inj_subst spargs cparsubst0). subst arg_sub. clear Hty. rewrite subst_it_mkProd_or_LetIn in sp, iswat. - rewrite !subst_instance_constr_mkApps !subst_mkApps in sp, iswat. + rewrite !subst_instance_mkApps !subst_mkApps in sp, iswat. eapply typing_spine_nth_error in sp; eauto. clear iswat. - 2:{ rewrite !context_assumptions_fold. rewrite subst_instance_context_assumptions. - clear iswat sp. eapply nth_error_Some_length in H0. lia. } + 2:{ rewrite !context_assumptions_fold. rewrite subst_instance_assumptions. + clear iswat sp. eapply nth_error_Some_length in e. + rewrite List.skipn_length in e. lia. } destruct sp as [decl [Hnth Hu0]]. simpl in on_projs. red in on_projs. + len in Hnth. eapply type_Cumul'; eauto. { rewrite firstn_skipn. eapply (isType_subst_instance_decl _ _ _ _ _ u wf isdecl.p1.p1) in projty; eauto. @@ -904,24 +1641,26 @@ Proof. rewrite /= /map_decl /= in Hs. eapply (weaken_ctx Γ) in Hs; auto. rewrite (subst_app_simpl [_]). - eapply (substitution0 _ _ _ _ _ _ (tSort s')). auto. + destruct projeq as [decl' [[[hnthargs wf'] projeq1] projty']]. + simpl. + eapply (substitution0 _ _ _ _ _ _ (tSort s')). tea. simpl. - eapply (substitution _ Γ (subst_instance_context u (smash_context [] (ind_params mdecl))) + eapply (PCUICSubstitution.substitution _ Γ (subst_instance u (smash_context [] (ind_params mdecl))) _ [vass _ _] _ (tSort s')); eauto. rewrite firstn_all2 in iparsubst0. lia. eapply spine_subst_smash in iparsubst0; auto. - rewrite subst_instance_context_smash. - eapply iparsubst0. simpl. - rewrite subst_instance_constr_mkApps subst_mkApps /=. - rewrite (subst_instance_instance_id Σ) // subst_instance_to_extended_list. + rewrite subst_instance_smash. + eapply iparsubst0. exact Hs. + simpl. + rewrite subst_instance_mkApps subst_mkApps /=. + rewrite [subst_instance_instance _ _](subst_instance_id_mdecl Σ) // subst_instance_to_extended_list. rewrite firstn_all2 in iparsubst0. lia. eapply spine_subst_smash in iparsubst0; auto. - rewrite subst_instance_context_smash /=. + rewrite subst_instance_smash /=. rewrite /to_extended_list (spine_subst_subst_to_extended_list_k iparsubst0). assumption. } - rewrite !context_assumptions_fold subst_instance_context_assumptions in Hnth. rewrite firstn_skipn. - rewrite smash_context_app smash_context_acc in on_projs. + rewrite PCUICSigmaCalculus.smash_context_app PCUICSigmaCalculus.smash_context_acc in on_projs. rewrite nth_error_app_lt in on_projs. { autorewrite with len. simpl. eapply nth_error_Some_length in Hnth. autorewrite with len in Hnth. @@ -930,25 +1669,25 @@ Proof. epose proof (nth_error_lift_context_eq _ (smash_context [] (ind_params mdecl))). autorewrite with len in H1. simpl in H1. erewrite -> H1 in on_projs. clear H1. - unshelve epose proof (constructor_cumulative_indices wf decli' oib onc _ Hu cu equ _ _ _ _ _ spargs iparsubst0 Hpars). - { eapply (weaken_lookup_on_global_env' _ _ _ wf (proj1 decli)). } + unshelve epose proof (constructor_cumulative_indices wf declc _ Hu cu equ _ _ _ _ _ spargs iparsubst0 Hpars). + { eapply (weaken_lookup_on_global_env' _ _ _ wf (proj1 (proj1 declc))). } move: X2. - set (argsu1 := subst_instance_context u1 (cshape_args cs)) in *. - set (argsu := subst_instance_context u (cshape_args cs)) in *. + set (argsu1 := subst_instance u1 (cstr_args cdecl)) in *. + set (argsu := subst_instance u (cstr_args cdecl)) in *. set (argctxu1 := subst_context _ _ argsu1) in *. set (argctxu := subst_context _ _ argsu) in *. simpl. set (pargctxu1 := subst_context cparsubst 0 argctxu1) in *. set (pargctxu := subst_context iparsubst 0 argctxu) in *. move=> [cumargs _]; eauto. - eapply context_relation_nth_ass in cumargs. + eapply PCUICRedTypeIrrelevance.All2_fold_nth_ass in cumargs. 3:eapply smash_context_assumption_context; constructor. 2:{ unfold pargctxu1, argctxu1, argsu1. autorewrite with len in Hnth. eapply Hnth. } destruct cumargs as [decl' [Hdecl' cum]]. rewrite (smash_context_subst []) in Hnth. rewrite (smash_context_subst []) in Hnth. - rewrite -(subst_instance_context_smash u1 _ []) in Hnth. + rewrite -(subst_instance_smash u1 _ []) in Hnth. rewrite !nth_error_subst_context in Hnth. rewrite nth_error_map in Hnth. destruct projeq as [decl'' [[[Hdecl wfdecl] Hty1] Hty2]]. @@ -959,29 +1698,29 @@ Proof. autorewrite with len in Hu0, decltyeq |- *. simpl in Hu0, decltyeq |- *. move: Hu0 decltyeq. - assert (narg < context_assumptions (cshape_args cs)). + assert (narg < context_assumptions (cstr_args cdecl)). eapply nth_error_Some_length in H0. lia. - replace (context_assumptions (cshape_args cs) - - S (context_assumptions (cshape_args cs) - S narg)) + replace (context_assumptions (cstr_args cdecl) - + S (context_assumptions (cstr_args cdecl) - S narg)) with narg by lia. move=> Hu0 decltyeq. rewrite -Hty1. clear decltyeq. rewrite Hty2. unfold projection_type'. set (indsubst1 := inds _ _ _). - set (indsubst := inds _ _ _). + set (indsubst := ind_subst _ _ _). set (projsubst := projs _ _ _). - rewrite - !subst_subst_instance_constr. - rewrite -lift_subst_instance_constr. - rewrite - !subst_subst_instance_constr. + rewrite !subst_instance_subst. + rewrite subst_instance_lift. + rewrite !subst_instance_subst. epose proof (commut_lift_subst_rec _ _ 1 narg narg). rewrite Nat.add_1_r in H2. rewrite <- H2 => //. clear H2. - rewrite (subst_app_decomp [_]). - autorewrite with len. rewrite heq_length. + rewrite (subst_app_decomp [_]). len. + rewrite heq_length. simpl. rewrite lift_mkApps. simpl. - rewrite (distr_subst [_]). simpl. - autorewrite with len. rewrite {2}/projsubst projs_length. - rewrite simpl_subst_k // subst_instance_constr_projs. + rewrite (distr_subst [_]). simpl. len. + rewrite {2}/projsubst projs_length. + rewrite simpl_subst_k // [subst_instance _ projsubst]subst_instance_projs. epose proof (subst_app_simpl (List.rev (firstn narg (skipn (ind_npars mdecl) args0))) _ 0). autorewrite with len in H2. simpl in H2. assert(#|firstn narg (skipn (ind_npars mdecl) args0)| = narg). @@ -996,37 +1735,36 @@ Proof. autorewrite with len in H2. rewrite -H2. clear H2. rewrite subst_app_decomp. - autorewrite with len. - rewrite (distr_subst (List.rev args)). - autorewrite with len. + len. + rewrite (distr_subst (List.rev args)). len. assert (map (subst0 (List.rev args)) - (map (subst_instance_constr u) (extended_subst (ind_params mdecl) 0)) = + (subst_instance u (extended_subst (ind_params mdecl) 0)) = iparsubst) as ->. { rewrite firstn_all2 in iparsubst0. lia. - rewrite extended_subst_subst_instance_constr. + rewrite subst_instance_extended_subst. pose proof (inst_ctx_subst iparsubst0). eapply context_subst_extended_subst in X2. rewrite X2. eapply map_ext. intros. now rewrite subst_inst Upn_0. } - autorewrite with len in cum. simpl in cum. + len in cum. simpl in cum. move: Hdecl'. rewrite /pargctxu /argctxu /argsu. rewrite !smash_context_subst_empty. - rewrite -(subst_instance_context_smash _ _ []). + rewrite -(subst_instance_smash _ _ []). rewrite !nth_error_subst_context. rewrite nth_error_map Hdecl. simpl => [= Hdecl']. subst decl'. simpl in cum. - autorewrite with len in cum; simpl in cum. - assert(context_assumptions (cshape_args cs) - - S (context_assumptions (cshape_args cs) - S narg) = narg) by lia. + len in cum; simpl in cum. + assert(context_assumptions (cstr_args cdecl) - + S (context_assumptions (cstr_args cdecl) - S narg) = narg) by lia. rewrite H2 in cum. - set (idx := S (context_assumptions (cshape_args cs) - S narg)) in *. + set (idx := S (context_assumptions (cstr_args cdecl) - S narg)) in *. assert (wfpargctxu1 : wf_local Σ (Γ ,,, skipn idx (smash_context [] pargctxu1))). { simpl. apply wf_local_app_skipn. apply wf_local_smash_end; auto. apply idxsubst0. } - destruct cum as [[cr mapd] cdecl]. + destruct cum as [[cr mapd] cumdecls]. destruct decl'' as [na [b|] ty]; simpl in mapd; try discriminate. - depelim cdecl. rename c into cum. + depelim cumdecls. rename c into cum. eapply (substitution_cumul _ Γ (skipn idx (smash_context [] pargctxu1)) [] (skipn idx (List.rev (skipn (ind_npars mdecl) args0)))) in cum. all:auto. @@ -1043,20 +1781,19 @@ Proof. etransitivity; [eapply cum|clear cum]. rewrite -(subst_app_simpl' _ _ 0) //. rewrite subst_app_decomp. - rewrite (subslet_length iparsubst0); autorewrite with len. - assert (wf_local Σ (Γ ,,, subst_instance_context u (ind_params mdecl))). + rewrite (subslet_length iparsubst0); len. + assert (wf_local Σ (Γ ,,, subst_instance u (ind_params mdecl))). { eapply weaken_wf_local; eauto. eapply on_minductive_wf_params => //. pcuic. } eapply (substitution_cumul _ _ _ []); eauto. eapply iparsubst0. simpl. - rewrite (distr_subst_rec _ _ _ #|ind_params mdecl| 0). - autorewrite with len. simpl. + rewrite (distr_subst_rec _ _ _ #|ind_params mdecl| 0); len => /=. eapply (untyped_subst_cumul (_ ,,, _) _ _ []); auto. - { eapply subslet_untyped_subslet. rewrite -(subst_instance_context_length u). + { eapply subslet_untyped_subslet. rewrite -(subst_instance_length u). eapply subslet_lift; eauto. rewrite -eq. eapply spine_subst_smash in idxsubst0; eauto. eapply subslet_skipn. eapply idxsubst0. } { rewrite subst_projs_inst. - specialize (projsubsl (Γ ,,, subst_instance_context u (ind_params mdecl))). + specialize (projsubsl (Γ ,,, subst_instance u (ind_params mdecl))). rewrite -projs_inst_lift projs_inst_subst. rewrite -{1}H2 -projs_inst_skipn. eapply untyped_subslet_skipn. eapply (projsubsl _ u). } @@ -1083,26 +1820,27 @@ Proof. rewrite nth_error_app1 // firstn_length_le; autorewrite with len; try lia. reflexivity. } { simpl. autorewrite with len. - rewrite -(subst_instance_context_length u (ind_params mdecl)). + rewrite -(subst_instance_length u (ind_params mdecl)). eapply weakening_wf_local; auto. } simpl. unfold indsubst. - set (inds' := inds _ _ _). - change (map (subst_instance_constr u) inds') with (subst_instance u inds'). - rewrite instantiate_inds => //. pcuic. + set (inds' := ind_subst _ _ _). + change (map (subst_instance u) inds') with (subst_instance u inds'). + rewrite instantiate_inds => //. eapply isdecl. rewrite (subst_closedn (List.rev args)); [|reflexivity]. + rewrite projs_length. eapply (closedn_subst _ 0). - eapply declared_inductive_closed_inds; eauto. + eapply (declared_minductive_closed_inds isdecl). simpl. autorewrite with len. - rewrite closedn_subst_instance_constr. + rewrite closedn_subst_instance. clear projsubsl. eapply closed_wf_local in wfdecl. rewrite closedn_ctx_app in wfdecl. move/andb_and: wfdecl => [_ wfdecl]. - autorewrite with len in wfdecl. + len in wfdecl. simpl in wfdecl. eapply closedn_ctx_decl in wfdecl; eauto. - autorewrite with len in wfdecl. + len in wfdecl. simpl in wfdecl. eapply closed_upwards. eauto. lia. auto. @@ -1119,7 +1857,7 @@ Proof. [vass bann (mkApps (tInd p.1.1 u) args)] []); auto. repeat constructor. repeat constructor. constructor. now apply conv_sym, red_conv, red1_red. constructor. - simpl. constructor. auto. + simpl. constructor. auto. red. eapply validity in typec; auto. - (* Fix congruence *) @@ -1129,8 +1867,8 @@ Proof. - (* Fix congruence: type reduction *) assert(fixl :#|fix_context mfix| = #|fix_context mfix1|) by now (rewrite !fix_context_length; apply (OnOne2_length o)). assert(convctx : conv_context Σ (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix1)). - { clear -wf X o fixl. - eapply context_relation_app_inv => //. + { clear -wf X o fixl. + eapply PCUICContextRelation.All2_fold_app => //. apply conv_ctx_refl. clear X. apply conv_decls_fix_context => //. induction o; constructor. @@ -1220,7 +1958,7 @@ Proof. assert(fixl :#|fix_context mfix| = #|fix_context mfix1|) by now (rewrite !fix_context_length; apply (OnOne2_length o)). assert(convctx : conv_context Σ (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix1)). { clear -wf X o fixl. - eapply context_relation_app_inv => //. + eapply PCUICContextRelation.All2_fold_app => //. apply conv_ctx_refl. clear X. apply conv_decls_fix_context => //. induction o; constructor; try split; auto; @@ -1314,7 +2052,7 @@ Theorem subject_reduction {cf:checker_flags} : Proof. intros * wfΣ Hty Hred. induction Hred; eauto. - eapply sr_red1 in Hty; eauto with wf. + eapply (env_prop_typing _ _ sr_red1) in Hty; eauto with wf. Qed. Lemma subject_reduction1 {cf Σ} {wfΣ : wf Σ} {Γ t u T} @@ -1334,7 +2072,7 @@ Section SRContext. intros h. induction h using red_rect'. - eapply cumul_refl'. - - eapply PCUICConversion.cumul_trans ; try eassumption. + - eapply cumul_trans ; try eassumption. eapply cumul_red_l. + eassumption. + eapply cumul_refl'. @@ -1356,12 +2094,12 @@ Section SRContext. red_ctx Σ Γ Γ'. Proof. induction 1; cbn in *. - - constructor; try reflexivity. cbn; eauto using red1_red. - constructor; try reflexivity. - destruct p as [[? []]|[? []]]; cbn; eauto using red1_red. - - destruct d as [na [bo|] ty]; constructor; eauto. - split; eapply refl_red. - apply refl_red. + destruct p; subst. + constructor. cbn; eauto using red1_red. + - constructor; try reflexivity. + destruct p as [-> [[? []]|[? []]]]; constructor; cbn; eauto using red1_red. + - constructor; auto. reflexivity. Qed. Lemma nth_error_red1_ctx (Σ : global_env) Γ Γ' n decl : @@ -1375,19 +2113,20 @@ Section SRContext. intros wfΣ h1 h2; induction h2 in n, h1 |- *. - destruct n. + inversion h1; subst. exists (vass na t'). + destruct p as [<- red]. split; cbnr. - eapply (weakening_red_0 wfΣ _ [_]); tas; cbnr. + eapply (weakening_red_0 _ [_]); tas; cbnr. apply red1_red; tas. + exists decl. split; tas. apply refl_red. - destruct n. + inversion h1; subst. - destruct p as [[? []]|[? []]]. - -- exists (vdef na b' t). - split; cbnr. + destruct p as [<- [[? []]|[? []]]]. -- exists (vdef na b t'). split; cbnr. - eapply (weakening_red_0 wfΣ _ [_]); tas; cbnr. + eapply (weakening_red_0 _ [_]); tas; cbnr. apply red1_red; tas. + -- exists (vdef na b' t). + split; cbnr. + exists decl. split; tas. apply refl_red. - destruct n. + exists d. split; cbnr. inv h1; apply refl_red. @@ -1395,7 +2134,7 @@ Section SRContext. destruct IHh2 as [decl' [X1 X2]]. exists decl'. split; tas. rewrite !(simpl_lift0 _ (S n)). - eapply (weakening_red_0 wfΣ _ [_]); tas; cbnr. + eapply (weakening_red_0 _ [_]); tas; cbnr. Qed. Lemma wf_local_isType_nth {Σ} {wfΣ : wf Σ} Γ n decl : @@ -1418,31 +2157,42 @@ Section SRContext. Ltac invs H := inversion H; subst. Ltac invc H := inversion H; subst; clear H. + Lemma type_reduction {Σ} {wfΣ : wf Σ} {Γ t A B} : + Σ ;;; Γ |- t : A -> red Σ Γ A B -> Σ ;;; Γ |- t : B. + Proof. + intros Ht Hr. + eapply type_Cumul'. eassumption. + 2: now eapply cumul_red_l'. + destruct (validity Ht) as [s HA]. + exists s; eapply subject_reduction; eassumption. + Defined. + Lemma subject_reduction_ctx {Σ} {wfΣ : wf Σ} Γ Γ' t T : red1_ctx Σ Γ Γ' -> Σ ;;; Γ |- t : T -> Σ ;;; Γ' |- t : T. Proof. assert(OnOne2_local_env (on_one_decl - (fun (Δ : PCUICAst.context) (t t' : term) => red1 Σ.1 Δ t t')) Γ Γ' -> + (fun (Δ : context) (t t' : term) => red1 Σ.1 Δ t t')) Γ Γ' -> conv_context Σ Γ Γ'). { clear. induction 1. - - red in p. constructor; auto. + - destruct p as [<- r]. constructor; auto. apply conv_ctx_refl. constructor. reflexivity. now apply red_conv, red1_red. - - destruct p. constructor. - apply conv_ctx_refl. destruct p as [red ->]. + - destruct p; subst. constructor. + apply conv_ctx_refl. + destruct s as [[red ->]|[red ->]]. constructor; pcuics. now apply red_conv, red1_red. - destruct p as [red ->]. - constructor. pcuic. - constructor; pcuics. now apply red_conv, red1_red. - - destruct d as [na [b|] ?]; constructor; auto; constructor; auto. all:pcuic. } + constructor. pcuic. now apply red_conv, red1_red. + reflexivity. + - constructor; auto. reflexivity. } intros r H. specialize (X r). assert(wf_local Σ Γ'). apply typing_wf_local in H. induction H in Γ', r, X |- *; depelim r. - - constructor; auto. red in o. + - constructor; auto. cbn in o. + destruct o as [<- r]. destruct t1 as [s Hs]. exists s. eapply subject_reduction1 in Hs; eauto. - depelim X. @@ -1452,20 +2202,19 @@ Section SRContext. - depelim X. red in o. destruct t1 as [s Hs]. simpl in t2. - destruct o as [[r ->]|[r <-]]. - + destruct o as [<- [[r ->]|[r <-]]]. constructor; auto. exists s; auto. eapply subject_reduction1; eauto. - constructor; auto. exists s; eapply subject_reduction1; eauto. - eapply type_Cumul'; eauto. exists s. - eapply subject_reduction1; eauto. - now apply red_cumul, red1_red. + red. eapply type_reduction; tea. pcuic. + constructor; auto. + exists s; eapply subject_reduction; tea. + reflexivity. + red. eapply subject_reduction1; tea. - depelim X. destruct t1 as [s Hs]. simpl in t2. constructor; auto. exists s; auto. eapply context_conversion; eauto. red; eapply context_conversion; eauto. - - eapply context_conversion; eauto. Qed. @@ -1473,16 +2222,16 @@ Section SRContext. red1_ctx Σ Γ Γ' -> wf_local Σ Γ -> wf_local Σ Γ'. Proof. induction 1; cbn in *. - - intro e. inversion e; subst; cbn in *. + - destruct p as [-> r]. intro e. inversion e; subst; cbn in *. constructor; tas. destruct X0 as [s Ht]. exists s. eapply subject_reduction1; tea. - intro e. inversion e; subst; cbn in *. - destruct p as [[? []]|[? []]]; constructor; cbn; tas. - + eapply subject_reduction1; tea. + destruct p as [-> [[? []]|[? []]]]; constructor; cbn; tas. + destruct X0; eexists; eapply subject_reduction1; tea. + eapply type_Cumul'; tea. destruct X0. exists x. eapply subject_reduction1; tea. econstructor 2. eassumption. reflexivity. + + eapply subject_reduction1; tea. - intro H; inversion H; subst; constructor; cbn in *; auto. + destruct X1 as [s Ht]. exists s. eapply subject_reduction_ctx; tea. @@ -1491,23 +2240,44 @@ Section SRContext. + eapply subject_reduction_ctx; tea. Qed. - Lemma eq_context_upto_names_upto_names Γ Δ : - eq_context_upto_names Γ Δ -> Γ ≡Γ Δ. + Lemma red_ctx_clos_rt_red1_ctx Σ : Relation_Properties.inclusion (red_ctx Σ) + (clos_refl_trans (red1_ctx Σ)). Proof. - induction 1; cbnr; try constructor; eauto. - destruct x as [? [] ?], y as [? [] ?]; cbn in *; subst; inversion e0; cbn. - all:constructor; cbnr; eauto. + intros x y H. + induction H; try firstorder. + destruct p. + - transitivity (Γ ,, vass na t'). + eapply clos_rt_OnOne2_local_env_incl. constructor. + cbn. split; auto. + clear r H. + induction IHAll2_fold; try solve[repeat constructor; auto]. + etransitivity; eauto. + - transitivity (Γ ,, vdef na b t'). + * eapply clos_rt_OnOne2_local_env_incl. constructor 2. + cbn. split; auto. + * transitivity (Γ ,, vdef na b' t'). + + eapply clos_rt_OnOne2_local_env_incl. + constructor 2. cbn. split; auto. + + clear -IHAll2_fold. + induction IHAll2_fold; try solve[repeat constructor; auto]. + etransitivity; eauto. Qed. Lemma wf_local_red {Σ} {wfΣ : wf Σ} {Γ Γ'} : red_ctx Σ Γ Γ' -> wf_local Σ Γ -> wf_local Σ Γ'. Proof. - intros h. apply red_ctx_clos_rt_red1_ctx in h. + intros h. red in h. apply red_ctx_clos_rt_red1_ctx in h. induction h; eauto using wf_local_red1. - apply eq_context_upto_names_upto_names in e. - eauto using wf_local_alpha. Qed. - + + Lemma eq_context_upto_names_upto_names Γ Δ : + eq_context_upto_names Γ Δ -> Γ ≡Γ Δ. + Proof. + induction 1; cbnr; try constructor; eauto. + depelim p; 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 Γ'). @@ -1524,9 +2294,9 @@ Section SRContext. apply wf_local_app_l in X. inversion X; subst; cbn in *; assumption. } constructor; cbn; auto. - 1: exists s. 1: unfold PCUICTerm.tSort. + 1: exists s. 1: change (tSort s) with (subst [b] #|Γ'| (tSort s)). - all: eapply substitution; tea. + all: eapply PCUICSubstitution.substitution; tea. - rewrite subst_context_snoc0. simpl. inversion HH; subst; cbn in *. destruct X0 as [s X0]. change (Γ,, vdef na b t ,,, Γ') with (Γ ,,, [vdef na b t] ,,, Γ') in *. @@ -1535,9 +2305,8 @@ Section SRContext. rewrite !subst_empty in XX. apply XX. constructor. apply wf_local_app_l in X. inversion X; subst; cbn in *; assumption. } constructor; cbn; auto. exists s. - unfold PCUICTerm.tSort. change (tSort s) with (subst [b] #|Γ'| (tSort s)). - all: eapply substitution; tea. + all: eapply PCUICSubstitution.substitution; tea. Qed. @@ -1545,7 +2314,7 @@ Section SRContext. : red_ctx Σ Γ Γ' -> red_ctx Σ (Γ ,,, Δ) (Γ' ,,, Δ). Proof. induction Δ as [|[na [bd|] ty] Δ]; [trivial| |]; - intro H; simpl; constructor; cbn; eauto; now apply IHΔ. + intro H; simpl; constructor; cbn; try constructor; eauto; now apply IHΔ. Qed. Lemma isType_red1 {Σ : global_env_ext} {wfΣ : wf Σ} {Γ A B} : @@ -1616,16 +2385,6 @@ Section SRContext. eapply subject_reduction; eauto. Qed. - Lemma type_reduction {Σ} {wfΣ : wf Σ} {Γ t A B} : - Σ ;;; Γ |- t : A -> red Σ Γ A B -> Σ ;;; Γ |- t : B. - Proof. - intros Ht Hr. - eapply type_Cumul'. eassumption. - 2: now eapply cumul_red_l'. - destruct (validity_term wfΣ Ht) as [s HA]. - exists s; eapply subject_reduction; eassumption. - Defined. - End SRContext. Lemma isType_tLetIn {cf} {Σ} {HΣ' : wf Σ} {Γ} {na t A B} @@ -1645,7 +2404,7 @@ Proof. * etransitivity. 2: apply weakening_red_0 with (Γ' := [_]) (N := tSort _); tea; reflexivity. - exact (red_rel_all _ (Γ ,, vdef na t A) 0 t A' eq_refl). + exact (red_rel_all _ (Γ ,, vdef na t A) 0 t A' HΣ' eq_refl). - destruct HH as [HA [Ht HB]]. destruct HB as [sB HB]. eexists. eapply type_reduction; tas. diff --git a/pcuic/theories/PCUICSafeLemmata.v b/pcuic/theories/PCUICSafeLemmata.v index 0cc13c891..e9c80af8a 100644 --- a/pcuic/theories/PCUICSafeLemmata.v +++ b/pcuic/theories/PCUICSafeLemmata.v @@ -4,7 +4,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICConfluence PCUICCumulativity PCUICSR PCUICPosition PCUICEquality PCUICNameless PCUICAlpha PCUICNormal PCUICInversion PCUICReduction PCUICSubstitution - PCUICConversion PCUICContextConversion PCUICValidity PCUICCtxShape + PCUICConversion PCUICContextConversion PCUICValidity PCUICArities PCUICWeakeningEnv PCUICGeneration PCUICParallelReductionConfluence. @@ -16,224 +16,28 @@ Local Set Keyed Unification. Set Default Goal Selector "!". -(* TODO MOVE *) -Lemma All2_app_inv_both : - forall A B (P : A -> B -> Type) l1 l2 r1 r2, - #|l1| = #|r1| -> - All2 P (l1 ++ l2) (r1 ++ r2) -> - All2 P l1 r1 × All2 P l2 r2. -Proof. - intros A B P l1 l2 r1 r2 e h. - apply All2_app_inv in h as [[w1 w2] [[e1 h1] h2]]. - assert (e2 : r1 = w1 × r2 = w2). - { apply All2_length in h1. rewrite h1 in e. - clear - e e1. - induction r1 in r2, w1, w2, e, e1 |- *. - - destruct w1. 2: discriminate. - intuition eauto. - - destruct w1. 1: discriminate. - simpl in e. apply Nat.succ_inj in e. - simpl in e1. inversion e1. subst. - eapply IHr1 in e. 2: eassumption. - intuition eauto. f_equal. assumption. - } - destruct e2 as [? ?]. subst. - intuition auto. -Qed. - Section Lemmata. Context {cf : checker_flags}. Context (flags : RedFlags.t). - (* - Lemma eq_term_zipc_inv : - forall Σ φ u v π, - eq_term Σ φ (zipc u π) (zipc v π) -> - eq_term Σ φ u v. - Proof. - intros Σ φ u v π h. - induction π in u, v, h |- *. - all: try solve [ - simpl in h ; try apply IHπ in h ; - cbn in h ; inversion h ; subst ; assumption - ]. - - simpl in h. apply IHπ in h. - inversion h. subst. - match goal with - | h : All2 _ _ _ |- _ => rename h into a - end. - apply All2_app_inv_both in a. 2: reflexivity. - destruct a as [_ a]. inversion a. subst. - intuition eauto. - - simpl in h. apply IHπ in h. - inversion h. subst. - match goal with - | h : All2 _ _ _ |- _ => rename h into a - end. - apply All2_app_inv_both in a. 2: reflexivity. - destruct a as [_ a]. inversion a. subst. - intuition eauto. - - simpl in h. apply IHπ in h. - inversion h. subst. - match goal with - | h : All2 _ _ _ |- _ => rename h into a - end. - apply All2_app_inv_both in a. 2: reflexivity. - destruct a as [_ a]. inversion a. subst. - intuition eauto. - Qed. - - Lemma eq_term_zipx_inv : - forall φ Γ u v π, - eq_term φ (zipx Γ u π) (zipx Γ v π) -> - eq_term φ u v. - Proof. - intros Σ Γ u v π h. - eapply eq_term_zipc_inv. - eapply eq_term_it_mkLambda_or_LetIn_inv. - eassumption. - Qed.*) - - Lemma eq_term_upto_univ_zipc : - forall Σ Re u v π, - RelationClasses.Reflexive Re -> - eq_term_upto_univ Σ Re Re u v -> - eq_term_upto_univ Σ Re Re (zipc u π) (zipc v π). - Proof. - intros Σ Re u v π he h. - induction π in u, v, h |- *. - all: try solve [ - simpl ; try apply IHπ ; - cbn ; constructor ; try reflexivity; try apply eq_term_upto_univ_refl ; assumption - ]. - - assumption. - - simpl. apply IHπ. constructor. - + eapply eq_term_eq_term_napp; auto. apply _. - + apply eq_term_upto_univ_refl; assumption. - - simpl. apply IHπ. constructor. - apply All2_app. - + apply All2_same. - intros. split ; auto. split; [split|]; auto. all: apply eq_term_upto_univ_refl. - all: assumption. - + constructor. - * simpl. intuition eauto. reflexivity. - * apply All2_same. - intros. split ; auto. splits. all: apply eq_term_upto_univ_refl. - all: assumption. - - simpl. apply IHπ. constructor. - apply All2_app. - + apply All2_same. - intros. split ; auto. splits. all: apply eq_term_upto_univ_refl. - all: assumption. - + constructor. - * simpl. intuition eauto. reflexivity. - * apply All2_same. - intros. split ; auto. splits. all: apply eq_term_upto_univ_refl. - all: assumption. - - simpl. apply IHπ. constructor. - apply All2_app. - + apply All2_same. - intros. split ; [split|]; auto. split. all: apply eq_term_upto_univ_refl. - all: assumption. - + constructor. - * simpl. intuition eauto. reflexivity. - * apply All2_same. - intros. splits ; auto. all: apply eq_term_upto_univ_refl. - all: assumption. - - simpl. apply IHπ. constructor. - apply All2_app. - + apply All2_same. - intros. splits ; auto. all: apply eq_term_upto_univ_refl. - all: assumption. - + constructor. - * simpl. intuition eauto. reflexivity. - * apply All2_same. - intros. splits ; auto. all: apply eq_term_upto_univ_refl. - all: assumption. - - simpl. apply IHπ. destruct indn as [i n]. - constructor. - + assumption. - + apply eq_term_upto_univ_refl. all: assumption. - + eapply All2_same. - intros. split ; auto. apply eq_term_upto_univ_refl. all: assumption. - - simpl. apply IHπ. destruct indn as [i n]. - constructor. - + apply eq_term_upto_univ_refl. all: assumption. - + assumption. - + eapply All2_same. - intros. split ; auto. apply eq_term_upto_univ_refl. all: assumption. - - simpl. apply IHπ. destruct indn as [i n]. - constructor. - + apply eq_term_upto_univ_refl. all: assumption. - + apply eq_term_upto_univ_refl. all: assumption. - + apply All2_app. - * eapply All2_same. - intros. split ; auto. apply eq_term_upto_univ_refl. all: assumption. - * constructor. - -- simpl. intuition eauto. - -- eapply All2_same. - intros. split ; auto. apply eq_term_upto_univ_refl. - all: assumption. - Qed. - - Lemma eq_term_zipc : - forall (Σ : global_env_ext) u v π, - eq_term Σ (global_ext_constraints Σ) u v -> - eq_term Σ (global_ext_constraints Σ) (zipc u π) (zipc v π). - Proof. - intros Σ u v π h. - eapply eq_term_upto_univ_zipc. - - intro. eapply eq_universe_refl. - - assumption. - Qed. - - Lemma eq_term_upto_univ_zipp : - forall Σ Re u v π, - RelationClasses.Reflexive Re -> - eq_term_upto_univ Σ Re Re u v -> - eq_term_upto_univ Σ Re Re (zipp u π) (zipp v π). - Proof. - intros Σ Re u v π he h. - unfold zipp. - case_eq (decompose_stack π). intros l ρ e. - eapply eq_term_upto_univ_mkApps. - - apply eq_term_eq_term_napp; try assumption; apply _. - - apply All2_same. intro. reflexivity. - Qed. - - Lemma eq_term_zipp : - forall (Σ : global_env_ext) u v π, - eq_term Σ (global_ext_constraints Σ) u v -> - eq_term Σ (global_ext_constraints Σ) (zipp u π) (zipp v π). + Instance All2_eq_refl Σ Re : + RelationClasses.Reflexive Re -> + CRelationClasses.Reflexive (All2 (eq_term_upto_univ Σ Re Re)). Proof. - intros Σ u v π h. - eapply eq_term_upto_univ_zipp. - - intro. eapply eq_universe_refl. - - assumption. - Qed. - - Lemma eq_term_upto_univ_zipx : - forall Σ Re Γ u v π, - RelationClasses.Reflexive Re -> - eq_term_upto_univ Σ Re Re u v -> - eq_term_upto_univ Σ Re Re (zipx Γ u π) (zipx Γ v π). - Proof. - intros Σ Re Γ u v π he h. - eapply eq_term_upto_univ_it_mkLambda_or_LetIn ; auto. - eapply eq_term_upto_univ_zipc ; auto. + intros h x. apply All2_same. reflexivity. Qed. - Lemma eq_term_zipx : - forall Σ φ Γ u v π, - eq_term Σ φ u v -> - eq_term Σ φ (zipx Γ u π) (zipx Γ v π). + Instance All2_br_eq_refl Σ Re : + RelationClasses.Reflexive Re -> + CRelationClasses.Reflexive (All2 + (fun x y : branch term => + eq_context_upto Σ Re Re (bcontext x) (bcontext y) * + eq_term_upto_univ Σ Re Re (bbody x) (bbody y))). Proof. - intros Σ Γ u v π h. - eapply eq_term_upto_univ_zipx ; auto. - intro. eapply eq_universe_refl. + intros h x. + apply All2_same; split; reflexivity. Qed. - (* red is the reflexive transitive closure of one-step reduction and thus can't be used as well order. We thus define the transitive closure, but we take the symmetric version. @@ -246,27 +50,6 @@ Section Lemmata. Hint Resolve eq_term_upto_univ_refl : core. - (* Lemma conv_context : *) - (* forall Σ Γ u v ρ, *) - (* wf Σ.1 -> *) - (* Σ ;;; Γ ,,, stack_context ρ |- u = v -> *) - (* Σ ;;; Γ |- zipc u ρ = zipc v ρ. *) - (* Proof. *) - (* intros Σ Γ u v ρ hΣ h. *) - (* induction ρ in u, v, h |- *. *) - (* - assumption. *) - (* - simpl. eapply IHρ. eapply conv_App_l ; auto. *) - (* - simpl. eapply IHρ. eapply conv_App_r ; auto. *) - (* - simpl. eapply IHρ. eapply conv_App_r ; auto. *) - (* - simpl. eapply IHρ. eapply conv_Case_c ; auto. *) - (* - simpl. eapply IHρ. eapply conv_Proj_c ; auto. *) - (* - simpl. eapply IHρ. eapply conv_Prod_l ; auto. *) - (* - simpl. eapply IHρ. eapply conv_Prod_r ; auto. *) - (* - simpl. eapply IHρ. eapply conv_Lambda_l ; auto. *) - (* - simpl. eapply IHρ. eapply conv_Lambda_r ; auto. *) - (* - simpl. eapply IHρ. eapply conv_App_r ; auto. *) - (* Qed. *) - Context (Σ : global_env_ext). Inductive welltyped Σ Γ t : Prop := @@ -287,7 +70,7 @@ Section Lemmata. ∥ Σ ;;; Γ |- t : T ∥ -> welltyped Σ Γ T. Proof. destruct hΣ as [wΣ]. intros [X]. - intros. eapply validity_term in X; try assumption. + intros. eapply validity in X; try assumption. destruct X. now exists (tSort x). Defined. @@ -407,7 +190,21 @@ Section Lemmata. + eapply IHh. + econstructor. assumption. Qed. + + Arguments zip /. + Lemma welltyped_fill_context_hole Γ π pcontext t : + wf_local Σ (Γ,,, stack_context π,,, fill_context_hole pcontext t) -> + welltyped Σ (Γ,,, stack_context π,,, context_hole_context pcontext) t. + Proof. + intros wfl. + destruct pcontext as ((?&h)&?); simpl in *. + apply wf_local_app_inv in wfl as (_&wf). + apply wf_local_rel_app_inv in wf as (wf&_). + destruct h; depelim wf; simpl in *. + all: destruct l; econstructor; eauto. + Qed. + Lemma welltyped_context : forall Γ t, welltyped Σ Γ (zip t) -> @@ -417,142 +214,68 @@ Section Lemmata. intros Γ [t π] h. simpl. destruct h as [T h]. induction π in Γ, t, T, h |- *. - - cbn. cbn in h. eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_App in h as hh ; auto. - destruct hh as [na [A' [B' [? [? ?]]]]]. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_App in h as hh ; auto. - destruct hh as [na [A' [B' [? [? ?]]]]]. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_Fix in h as hh. 2: assumption. - destruct hh as [decl [? [? [hw [? ?]]]]]. - apply typing_wf_local in h. - clear -h hw wΣ. - eapply All_app in hw as [_ hw]. - depelim hw. simpl in i. - destruct i as [s Hs]. eexists; eauto. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_Fix in h as hh. 2: assumption. - destruct hh as [decl [? [? [? [ha ?]]]]]. - clear - ha wΣ. - apply All_app in ha as [_ ha]. - inversion ha. subst. - intuition eauto. simpl in *. - match goal with - | hh : _ ;;; _ |- _ : _ |- _ => rename hh into h - end. - rewrite fix_context_length in h. - rewrite app_length in h. simpl in h. - rewrite fix_context_fix_context_alt in h. - rewrite map_app in h. simpl in h. - unfold def_sig at 2 in h. simpl in h. - rewrite <- app_context_assoc in h. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_App in h as hh ; auto. - destruct hh as [na [A' [B' [? [? ?]]]]]. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_CoFix in h as hh. 2: assumption. - destruct hh as [decl [? [? [hw [? ?]]]]]. - apply typing_wf_local in h. - clear -h hw wΣ. - eapply All_app in hw as [_ hw]. - depelim hw. simpl in i. - destruct i as [s Hs]. eexists; eauto. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_CoFix in h as hh. 2: assumption. - destruct hh as [decl [? [? [? [ha ?]]]]]. - clear - ha wΣ. - apply All_app in ha as [_ ha]. - inversion ha. subst. - intuition eauto. simpl in *. - match goal with - | hh : _ ;;; _ |- _ : _ |- _ => rename hh into h - end. - rewrite fix_context_length in h. - rewrite app_length in h. simpl in h. - rewrite fix_context_fix_context_alt in h. - rewrite map_app in h. simpl in h. - unfold def_sig at 2 in h. simpl in h. - rewrite <- app_context_assoc in h. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - destruct indn. - apply inversion_Case in h as hh ; auto. - destruct hh as [uni [args [mdecl [idecl [ps [pty [btys - [? [? [? [? [? [? [ht0 [? ?]]]]]]]]]]]]]]]. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - destruct indn. - apply inversion_Case in h as hh ; auto. - destruct hh as [uni [args [mdecl [idecl [ps [pty [btys - [? [? [? [? [? [? [ht0 [? ?]]]]]]]]]]]]]]]. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - destruct indn. - apply inversion_Case in h as hh ; auto. - destruct hh as [uni [args [mdecl [idecl [ps [pty [btys - [? [? [? [? [? [? [ht0 [? [? ?]]]]]]]]]]]]]]]]. - apply All2_app_inv in a as [[? ?] [[? ?] ha]]. - inversion ha. subst. - intuition eauto. simpl in *. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [T' h]. - apply inversion_Proj in h - as [uni [mdecl [idecl [pdecl [args [? [? [? ?]]]]]]]] ; auto. - eexists. eassumption. - - simpl. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [T' h]. - apply inversion_Prod in h as hh ; auto. - destruct hh as [s1 [s2 [? [? ?]]]]. - eexists. eassumption. - - cbn. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [T' h]. - apply inversion_Prod in h as hh ; auto. - destruct hh as [s1 [s2 [? [? ?]]]]. - eexists. eassumption. - - cbn. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [T' h]. - apply inversion_Lambda in h as hh ; auto. - destruct hh as [s1 [B [? [? ?]]]]. - eexists. eassumption. - - cbn. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [T' h]. - apply inversion_Lambda in h as hh ; auto. - destruct hh as [s1 [B [? [? ?]]]]. - eexists. eassumption. - - cbn. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [U h]. - apply inversion_LetIn in h as [s [A [? [? [? ?]]]]]. 2: auto. - eexists. eassumption. - - cbn. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [U h]. - apply inversion_LetIn in h as [s [A [? [? [? ?]]]]]. 2: auto. - eexists. eassumption. - - cbn. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [U h]. - apply inversion_LetIn in h as [s [A [? [? [? ?]]]]]. 2: auto. - eexists. eassumption. - - cbn. cbn in h. cbn in IHπ. apply IHπ in h. - destruct h as [B h]. - apply inversion_App in h as hh ; auto. - destruct hh as [na [A' [B' [? [? ?]]]]]. - eexists. eassumption. + 1: { econstructor; eauto. } + destruct a; simpl in *. + all: apply IHπ in h as (?&typ). + all: try apply inversion_App in typ as (?&?&?&?&?&?); auto. + all: try apply inversion_Proj in typ as (?&?&?&?&?&?&?&?&?); auto. + all: try apply inversion_Prod in typ as (?&?&?&?&?); auto. + all: try apply inversion_Lambda in typ as (?&?&?&?&?); auto. + all: try apply inversion_LetIn in typ as (?&?&?&?&?&?); auto. + all: try solve [econstructor; eauto]. + - apply inversion_Fix in typ as (?&?&?&?&?&?&?); eauto. + destruct mfix as ((?&[])&?); simpl in *. + + eapply All_app in a as (_&a). + depelim a. + eauto using isType_welltyped. + + eapply All_app in a0 as (_&a0). + depelim a0. + rewrite fix_context_fix_context_alt in t0. + rewrite map_app in t0. + simpl in t0. + rewrite app_context_assoc. + econstructor; eauto. + - apply inversion_CoFix in typ as (?&?&?&?&?&?&?); eauto. + destruct mfix as ((?&[])&?); simpl in *. + + eapply All_app in a as (_&a). + depelim a. + eauto using isType_welltyped. + + eapply All_app in a0 as (_&a0). + depelim a0. + rewrite fix_context_fix_context_alt in t0. + rewrite map_app in t0. + simpl in t0. + rewrite app_context_assoc. + econstructor; eauto. + - apply inversion_Case in typ as (?&?&?&?&[]&?); auto. + rewrite app_context_assoc. + destruct p; cbn in *. + + apply validity in scrut_ty as (?&typ). + clear brs_ty. + apply inversion_mkApps in typ as (?&_&spine); auto; simpl in *. + clear -spine. + rewrite -app_assoc -app_comm_cons in spine. + revert spine; generalize (tSort x3); intros t' spine. + induction params1 in spine, x4, t' |- *; cbn in *. + * depelim spine. + econstructor; eauto. + * depelim spine; eauto. + + eauto using welltyped_fill_context_hole. + + now exists (tSort ps). + - apply inversion_Case in typ as (?&?&?&?&[]&?); auto. + econstructor; eauto. + - apply inversion_Case in typ as (?&?&?&?&[]&?); auto. + destruct brs as ((?&?)&?). + simpl fill_branches_hole in brs_ty. + apply All2i_app_inv_r in brs_ty as (?&?&_&_&a). + inv a. + clear X0. + destruct X as ((wfl&cc)&typ&_). + unfold app_context. + rewrite -app_assoc. + destruct b; cbn in *. + + eapply welltyped_fill_context_hole; eauto. + + eexists; tea. Qed. Lemma cored_red : @@ -579,43 +302,19 @@ Section Lemmata. + eapply red1_context. assumption. Qed. - Lemma cored_zipx : - forall Γ u v π, - cored Σ (Γ ,,, stack_context π) u v -> - cored Σ [] (zipx Γ u π) (zipx Γ v π). - Proof. - intros Γ u v π h. - eapply cored_it_mkLambda_or_LetIn. - eapply cored_context. - rewrite app_context_nil_l. - assumption. - Qed. - - Lemma red_zipx : - forall Γ u v π, - red Σ (Γ ,,, stack_context π) u v -> - red Σ [] (zipx Γ u π) (zipx Γ v π). - Proof. - intros Γ u v π h. - eapply red_it_mkLambda_or_LetIn. - eapply red_context. - rewrite app_context_nil_l. - assumption. - Qed. - Lemma cumul_zippx : forall Γ u v ρ, Σ ;;; (Γ ,,, stack_context ρ) |- u <= v -> Σ ;;; Γ |- zippx u ρ <= zippx v ρ. Proof. intros Γ u v ρ h. - induction ρ in u, v, h |- *. + induction ρ in u, v, h |- *; auto. + destruct a. all: try solve [ unfold zippx ; simpl ; eapply cumul_it_mkLambda_or_LetIn ; assumption ]. - - cbn. assumption. - unfold zippx. simpl. case_eq (decompose_stack ρ). intros l π e. unfold zippx in IHρ. rewrite e in IHρ. @@ -688,70 +387,6 @@ Section Lemmata. - simpl. eapply IHl. eapply cumul_App_l. assumption. Qed. - Lemma conv_cum_zipp' : - forall leq Γ u v π, - conv_cum leq Σ Γ u v -> - conv_cum leq Σ Γ (zipp u π) (zipp v π). - Proof. - intros leq Γ u v π h. - destruct leq. - - destruct h. constructor. eapply conv_zipp. assumption. - - destruct h. constructor. eapply cumul_zipp. assumption. - Qed. - - Lemma conv_alt_zippx : - forall Γ u v ρ, - Σ ;;; (Γ ,,, stack_context ρ) |- u = v -> - Σ ;;; Γ |- zippx u ρ = zippx v ρ. - Proof. - intros Γ u v ρ h. - revert u v h. induction ρ ; intros u v h. - all: try solve [ - unfold zippx ; simpl ; - eapply conv_alt_it_mkLambda_or_LetIn ; - assumption - ]. - - cbn. assumption. - - unfold zippx. simpl. - case_eq (decompose_stack ρ). intros l π e. - unfold zippx in IHρ. rewrite e in IHρ. - apply IHρ. - eapply conv_App_l. assumption. - - unfold zippx. simpl. - eapply conv_alt_it_mkLambda_or_LetIn. cbn. - eapply conv_Lambda_r. - assumption. - - unfold zippx. simpl. - eapply conv_alt_it_mkLambda_or_LetIn. cbn. - eapply conv_Lambda_r. - assumption. - - unfold zippx. simpl. - eapply conv_alt_it_mkLambda_or_LetIn. cbn. - eapply conv_LetIn_bo. assumption. - Qed. - - Lemma conv_zippx : - forall Γ u v ρ, - Σ ;;; Γ ,,, stack_context ρ |- u = v -> - Σ ;;; Γ |- zippx u ρ = zippx v ρ. - Proof. - intros Γ u v ρ uv. eapply conv_alt_zippx ; assumption. - Qed. - - Lemma conv_cum_zippx' : - forall Γ leq u v ρ, - conv_cum leq Σ (Γ ,,, stack_context ρ) u v -> - conv_cum leq Σ Γ (zippx u ρ) (zippx v ρ). - Proof. - intros Γ leq u v ρ h. - destruct leq. - - cbn in *. destruct h as [h]. constructor. - eapply conv_alt_zippx ; assumption. - - cbn in *. destruct h. constructor. - eapply cumul_zippx. assumption. - Qed. - - Derive Signature for Acc. Lemma wf_fun : @@ -833,7 +468,7 @@ Section Lemmata. Lemma welltyped_zipc_stack_context Γ t π ρ args : decompose_stack π = (args, ρ) -> welltyped Σ Γ (zipc t π) - -> welltyped Σ (Γ ,,, stack_context π) (zipc t (appstack args ε)). + -> welltyped Σ (Γ ,,, stack_context π) (zipc t (appstack args [])). Proof. intros h h1. apply decompose_stack_eq in h. subst. @@ -848,7 +483,7 @@ Section Lemmata. forall {Γ c u cty cb cu}, Some (ConstantDecl {| cst_type := cty ; cst_body := Some cb ; cst_universes := cu |}) = lookup_env Σ c -> - red (fst Σ) Γ (tConst c u) (subst_instance_constr u cb). + red (fst Σ) Γ (tConst c u) (subst_instance u cb). Proof. intros Γ c u cty cb cu e. econstructor. econstructor. @@ -860,7 +495,7 @@ Section Lemmata. forall {Γ c u cty cb cu}, Some (ConstantDecl {| cst_type := cty ; cst_body := Some cb ; cst_universes := cu |}) = lookup_env Σ c -> - cored (fst Σ) Γ (subst_instance_constr u cb) (tConst c u). + cored (fst Σ) Γ (subst_instance u cb) (tConst c u). Proof. intros Γ c u cty cb cu e. symmetry in e. @@ -996,7 +631,9 @@ Section Lemmata. isStackApp ρ = false. Proof. intros π l ρ e. - destruct ρ. all: auto. + destruct ρ; auto. + destruct s. + all: auto. exfalso. eapply decompose_stack_not_app. eassumption. Qed. @@ -1012,27 +649,28 @@ Section Lemmata. Qed. Lemma decompose_stack_stack_cat π π' : - decompose_stack (π +++ π') = + decompose_stack (π ++ π') = ((decompose_stack π).1 ++ match (decompose_stack π).2 with - | ε => (decompose_stack π').1 + | [] => (decompose_stack π').1 | _ => [] end, - (decompose_stack π).2 +++ + (decompose_stack π).2 ++ match (decompose_stack π).2 with - | ε => (decompose_stack π').2 + | [] => (decompose_stack π').2 | _ => π' end). Proof. induction π in π' |- *; cbn in *; auto. - now destruct decompose_stack. - - rewrite !IHπ. + - destruct a; auto. + rewrite !IHπ. now destruct (decompose_stack π). Qed. Lemma zipp_stack_cat π π' t : isStackApp π = false -> - zipp t (π' +++ π) = zipp t π'. + zipp t (π' ++ π) = zipp t π'. Proof. intros no_stack_app. unfold zipp. @@ -1040,7 +678,7 @@ Section Lemmata. destruct (decompose_stack π') eqn:decomp. cbn. destruct s; try now rewrite app_nil_r. - now destruct π; cbn in *; rewrite ?app_nil_r. + now destruct π as [|[] ?]; cbn in *; rewrite ?app_nil_r. Qed. Lemma zipp_appstack t args π : @@ -1052,14 +690,10 @@ Section Lemmata. now destruct decompose_stack. Qed. - Lemma appstack_cons a args π : - appstack (a :: args) π = App a (appstack args π). - Proof. reflexivity. Qed. - Lemma fst_decompose_stack_nil π : isStackApp π = false -> (decompose_stack π).1 = []. - Proof. now destruct π. Qed. + Proof. now destruct π as [|[] ?]. Qed. Lemma zipp_as_mkApps t π : zipp t π = mkApps t (decompose_stack π).1. @@ -1097,101 +731,6 @@ Section Lemmata. Hint Resolve conv_refl conv_alt_red : core. Hint Resolve conv_refl : core. - - (* Let bindings are not injective, so it_mkLambda_or_LetIn is not either. - However, when they are all lambdas they become injective for conversion. - stack_contexts only produce lambdas so we can use this property on them. - It only applies to stacks manipulated by conversion/reduction which are - indeed let-free. - *) - Fixpoint let_free_context (Γ : context) := - match Γ with - | [] => true - | {| decl_name := na ; decl_body := Some b ; decl_type := B |} :: Γ => false - | {| decl_name := na ; decl_body := None ; decl_type := B |} :: Γ => - let_free_context Γ - end. - - Lemma let_free_context_app : - forall Γ Δ, - let_free_context (Γ ,,, Δ) = let_free_context Δ && let_free_context Γ. - Proof. - intros Γ Δ. - induction Δ as [| [na [b|] B] Δ ih ] in Γ |- *. - - simpl. reflexivity. - - simpl. reflexivity. - - simpl. apply ih. - Qed. - - Lemma let_free_context_rev : - forall Γ, - let_free_context (List.rev Γ) = let_free_context Γ. - Proof. - intros Γ. - induction Γ as [| [na [b|] B] Γ ih ]. - - reflexivity. - - simpl. rewrite let_free_context_app. simpl. - apply andb_false_r. - - simpl. rewrite let_free_context_app. simpl. - rewrite ih. rewrite andb_true_r. reflexivity. - Qed. - - Fixpoint let_free_stack (π : stack) := - match π with - | ε => true - | App u ρ => let_free_stack ρ - | Fix f n args ρ => let_free_stack ρ - | Fix_mfix_ty na bo ra mfix1 mfix2 idx ρ => let_free_stack ρ - | Fix_mfix_bd na ty ra mfix1 mfix2 idx ρ => let_free_stack ρ - | CoFix f n args ρ => let_free_stack ρ - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx ρ => let_free_stack ρ - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx ρ => let_free_stack ρ - | Case_p indn c brs ρ => let_free_stack ρ - | Case indn p brs ρ => let_free_stack ρ - | Case_brs indn p c m brs1 brs2 ρ => let_free_stack ρ - | Proj p ρ => let_free_stack ρ - | Prod_l na B ρ => let_free_stack ρ - | Prod_r na A ρ => let_free_stack ρ - | Lambda_ty na u ρ => let_free_stack ρ - | Lambda_tm na A ρ => let_free_stack ρ - | LetIn_bd na B u ρ => let_free_stack ρ - | LetIn_ty na b u ρ => let_free_stack ρ - | LetIn_in na b B ρ => false - | coApp u ρ => let_free_stack ρ - end. - - Lemma let_free_stack_context : - forall π, - let_free_stack π -> - let_free_context (stack_context π). - Proof. - intros π h. - induction π. - all: try solve [ simpl ; rewrite ?IHπ // ]. - - simpl. rewrite let_free_context_app. - rewrite IHπ => //. rewrite andb_true_r. rewrite let_free_context_rev. - match goal with - | |- context [ mapi ?f ?l ] => - generalize l - end. - intro l. unfold mapi. - generalize 0 at 2. intro n. - induction l in n |- *. - + simpl. reflexivity. - + simpl. apply IHl. - - simpl. rewrite let_free_context_app. - rewrite IHπ => //. rewrite andb_true_r. rewrite let_free_context_rev. - match goal with - | |- context [ mapi ?f ?l ] => - generalize l - end. - intro l. unfold mapi. - generalize 0 at 2. intro n. - induction l in n |- *. - + simpl. reflexivity. - + simpl. apply IHl. - Qed. - Lemma cored_red_cored : forall Γ u v w, cored Σ Γ w v -> @@ -1273,7 +812,7 @@ Section Lemmata. red Σ Γ (zipc t π) (zipc u π). Proof. intros Γ t u π h. - do 2 zip fold. eapply red_context. assumption. + do 2 zip fold. eapply red_context_zip. assumption. Qed. Lemma welltyped_zipc_zipp : @@ -1306,17 +845,17 @@ Section Lemmata. apply cumul_mkApps; auto. Qed. - Lemma whne_context_relation f rel Γ Γ' t : + Lemma whne_All2_fold f rel Γ Γ' t : (forall Γ Γ' c c', rel Γ Γ' c c' -> (decl_body c = None <-> decl_body c' = None)) -> whne f Σ Γ t -> - context_relation rel Γ Γ' -> + All2_fold rel Γ Γ' -> whne f Σ Γ' t. Proof. intros behaves wh conv. induction wh; eauto using whne. destruct nth_error eqn:nth; [|easy]. cbn in *. - eapply context_relation_nth in nth; eauto. + eapply All2_fold_nth in nth; eauto. destruct nth as (?&eq&?&?). constructor. rewrite eq. @@ -1327,16 +866,16 @@ Section Lemmata. congruence. Qed. - Lemma whnf_context_relation f rel Γ Γ' t : + Lemma whnf_All2_fold f rel Γ Γ' t : (forall Γ Γ' c c', rel Γ Γ' c c' -> (decl_body c = None <-> decl_body c' = None)) -> whnf f Σ Γ t -> - context_relation rel Γ Γ' -> + All2_fold rel Γ Γ' -> whnf f Σ Γ' t. Proof. intros behaves wh conv. destruct wh; eauto using whnf. apply whnf_ne. - eapply whne_context_relation; eauto. + eapply whne_All2_fold; eauto. Qed. Lemma whne_conv_context f Γ Γ' t : @@ -1344,7 +883,7 @@ Section Lemmata. conv_context Σ Γ Γ' -> whne f Σ Γ' t. Proof. - apply whne_context_relation. + apply whne_All2_fold. intros ? ? ? ? r. now depelim r. Qed. @@ -1354,19 +893,19 @@ Section Lemmata. conv_context Σ Γ Γ' -> whnf f Σ Γ' t. Proof. - apply whnf_context_relation. + apply whnf_All2_fold. intros ? ? ? ? r. now depelim r. Qed. Lemma Case_Construct_ind_eq : - forall {Γ ind ind' npar pred i u brs args}, - welltyped Σ Γ (tCase (ind, npar) pred (mkApps (tConstruct ind' i u) args) brs) -> - ind = ind'. + forall {Γ ci ind' pred i u brs args}, + welltyped Σ Γ (tCase ci pred (mkApps (tConstruct ind' i u) args) brs) -> + ci.(ci_ind) = ind'. Proof. destruct hΣ as [wΣ]. - intros Γ ind ind' npar pred i u brs args [A h]. - apply PCUICInductiveInversion.invert_Case_Construct in h; auto. + intros Γ ci ind' pred i u brs args [A h]. + apply PCUICInductiveInversion.invert_Case_Construct in h; intuition auto. Qed. Lemma Proj_Construct_ind_eq : diff --git a/pcuic/theories/PCUICSigmaCalculus.v b/pcuic/theories/PCUICSigmaCalculus.v index e3b3cbc59..65ff845d9 100644 --- a/pcuic/theories/PCUICSigmaCalculus.v +++ b/pcuic/theories/PCUICSigmaCalculus.v @@ -1,293 +1,239 @@ -(* Distributed under the terms of the MIT license. *) From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction - PCUICLiftSubst PCUICUnivSubst - PCUICTyping PCUICClosed PCUICEquality. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction + PCUICLiftSubst. Require Import ssreflect ssrbool. From Equations Require Import Equations. Require Import Equations.Prop.DepElim. Set Equations With UIP. +Set Keyed Unification. +Set Default Goal Selector "!". -(** * Type preservation for σ-calculus *) +(** * Theory of σ-calculus operations *) -Open Scope sigma_scope. -Set Keyed Unification. +Declare Scope sigma_scope. +Delimit Scope sigma_scope with sigma. +Local Open Scope sigma_scope. +Ltac sigma := autorewrite with sigma. +Tactic Notation "sigma" "in" hyp(id) := autorewrite with sigma in id. -Set Default Goal Selector "!". +Infix "∘i" := (fun (f g : nat -> term -> term) => fun i => f i ∘ g i) (at level 40). -(* TODO Maybe remove later? *) -Require PCUICWeakening. - -Hint Rewrite @lift_rename Nat.add_0_r : sigma. - -Lemma subst1_inst : - forall t n u, - t{ n := u } = t.[⇑^n (u ⋅ ids)]. -Proof. - intros t n u. - unfold subst1. rewrite subst_inst. - eapply inst_ext. intro i. - unfold Upn, subst_compose, subst_consn. - destruct (Nat.ltb_spec0 i n). - - rewrite -> nth_error_idsn_Some by assumption. reflexivity. - - rewrite -> nth_error_idsn_None by lia. - rewrite idsn_length. - destruct (Nat.eqb_spec (i - n) 0). - + rewrite e. simpl. reflexivity. - + replace (i - n) with (S (i - n - 1)) by lia. simpl. - destruct (i - n - 1) eqn: e. - * simpl. reflexivity. - * simpl. reflexivity. -Qed. -(* Hint Rewrite @subst1_inst : sigma. *) +Definition substitution := nat -> term. +Bind Scope sigma_scope with substitution. -Lemma rename_mkApps : - forall f t l, - rename f (mkApps t l) = mkApps (rename f t) (map (rename f) l). -Proof. - intros f t l. - autorewrite with sigma. f_equal. -Qed. +Hint Rewrite Nat.add_0_r : sigma. -Lemma rename_subst_instance_constr : - forall u t f, - rename f (subst_instance_constr u t) = subst_instance_constr u (rename f t). -Proof. - intros u t f. - induction t in f |- * using term_forall_list_ind. - all: try solve [ - simpl ; - rewrite ?IHt ?IHt1 ?IHt2 ; - easy - ]. - - simpl. f_equal. induction X. - + reflexivity. - + simpl. f_equal ; easy. - - simpl. rewrite IHt1 IHt2. f_equal. - induction X. - + reflexivity. - + simpl. f_equal. 2: easy. - destruct x. unfold on_snd. simpl in *. - easy. - - simpl. f_equal. - rewrite map_length. - generalize #|m|. intro k. - induction X. 1: reflexivity. - destruct p, x. unfold map_def in *. - simpl in *. f_equal. all: easy. - - simpl. f_equal. - rewrite map_length. - generalize #|m|. intro k. - induction X. 1: reflexivity. - destruct p, x. unfold map_def in *. - simpl in *. f_equal. all: easy. -Qed. +Ltac nat_compare_specs := + match goal with + | |- context [?x <=? ?y] => + destruct (Nat.leb_spec x y); try lia + | |- context [?x + destruct (Nat.ltb_spec x y); try lia + end. + +(* Sigma calculus *) + +(** Shift a renaming [f] by [k]. *) +Definition shiftn k f := + fun n => if Nat.ltb n k then n else k + (f (n - k)). + +Section map_predicate_shift. + Context {T : Type}. + Context (fn : (nat -> T) -> term -> term). + Context (shift : nat -> (nat -> T) -> nat -> T). + Context (finst : Instance.t -> Instance.t). + Context (f : nat -> T). + + Definition map_predicate_shift (p : predicate term) := + {| pparams := map (fn f) p.(pparams); + puinst := finst p.(puinst); + pcontext := mapi_context (fun k => fn (shift k f)) p.(pcontext); + preturn := fn (shift #|p.(pcontext)| f) p.(preturn) |}. + + Lemma map_shift_pparams (p : predicate term) : + map (fn f) (pparams p) = pparams (map_predicate_shift p). + Proof. reflexivity. Qed. + + Lemma map_shift_preturn (p : predicate term) : + fn (shift #|p.(pcontext)| f) (preturn p) = preturn (map_predicate_shift p). + Proof. reflexivity. Qed. + + Lemma map_shift_pcontext (p : predicate term) : + mapi_context (fun k => fn (shift k f)) (pcontext p) = + pcontext (map_predicate_shift p). + Proof. reflexivity. Qed. + + Lemma map_shift_puinst (p : predicate term) : + finst (puinst p) = puinst (map_predicate_shift p). + Proof. reflexivity. Qed. + +End map_predicate_shift. -Definition rename_context f (Γ : context) : context := - fold_context (fun i => rename (shiftn i f)) Γ. +Section map_branch_shift. + Context {T : Type}. + Context (fn : (nat -> T) -> term -> term). + Context (shift : nat -> (nat -> T) -> nat -> T). + Context (f : nat -> T). -Definition inst_context σ (Γ : context) : context := - fold_context (fun i => inst (⇑^i σ)) Γ. + Definition map_branch_shift (b : branch term) := + {| bcontext := mapi_context (fun k => fn (shift k f)) b.(bcontext); + bbody := fn (shift #|b.(bcontext)| f) b.(bbody) |}. -Definition rename_decl f d := map_decl (rename f) d. -Definition inst_decl σ d := map_decl (inst σ) d. + Lemma map_shift_bbody (b : branch term) : + fn (shift #|b.(bcontext)| f) (bbody b) = bbody (map_branch_shift b). + Proof. reflexivity. Qed. + + Lemma map_shift_bcontext (b : branch term) : + mapi_context (fun k => fn (shift k f)) (bcontext b) = bcontext (map_branch_shift b). + Proof. reflexivity. Qed. +End map_branch_shift. -Lemma rename_context_length : - forall σ Γ, - #|rename_context σ Γ| = #|Γ|. -Proof. - intros σ Γ. unfold rename_context. - apply fold_context_length. -Qed. -Hint Rewrite rename_context_length : sigma wf. +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) + | tEvar ev args => tEvar ev (List.map (rename f) args) + | tLambda na T M => tLambda na (rename f T) (rename (shiftn 1 f) M) + | tApp u v => tApp (rename f u) (rename f v) + | tProd na A B => tProd na (rename f A) (rename (shiftn 1 f) B) + | tLetIn na b t b' => tLetIn na (rename f b) (rename f t) (rename (shiftn 1 f) b') + | tCase ind p c brs => + let p' := map_predicate_shift rename shiftn id f p in + let brs' := map_branches_shift rename f brs in + tCase ind p' (rename f c) brs' + | tProj p c => tProj p (rename f c) + | tFix mfix idx => + let mfix' := List.map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let mfix' := List.map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in + tCoFix mfix' idx + | x => x + end. +Notation rename_predicate := (map_predicate_shift rename shiftn id). +Notation rename_branches f := (map_branches_shift rename f). -Lemma rename_context_snoc0 : - forall f Γ d, - rename_context f (d :: Γ) = - rename_context f Γ ,, rename_decl (shiftn #|Γ| f) d. + +Lemma shiftn_ext n f f' : (forall i, f i = f' i) -> forall t, shiftn n f t = shiftn n f' t. Proof. - intros f Γ d. - unfold rename_context. now rewrite fold_context_snoc0. + intros. + unfold shiftn. destruct Nat.ltb; congruence. Qed. -Hint Rewrite rename_context_snoc0 : sigma. -Lemma rename_context_snoc r Γ d : rename_context r (Γ ,, d) = rename_context r Γ ,, map_decl (rename (shiftn #|Γ| r)) d. +Instance shiftn_proper : Proper (Logic.eq ==> `=1` ==> `=1`) shiftn. Proof. - unfold snoc. apply rename_context_snoc0. + intros x y -> f g Hfg ?. now apply shiftn_ext. Qed. -Hint Rewrite rename_context_snoc : sigma. -Lemma rename_context_alt r Γ : - rename_context r Γ = - mapi (fun k' d => map_decl (rename (shiftn (Nat.pred #|Γ| - k') r)) d) Γ. +Lemma shiftn_id i : shiftn i id =1 id. Proof. - unfold rename_context. apply fold_context_alt. + intros k; rewrite /shiftn. nat_compare_specs => /= //. + rewrite /id. lia. Qed. -Definition inst_context_snoc0 s Γ d : - inst_context s (d :: Γ) = - inst_context s Γ ,, map_decl (inst (⇑^#|Γ| s)) d. -Proof. unfold inst_context. now rewrite fold_context_snoc0. Qed. -Hint Rewrite inst_context_snoc0 : sigma. - -Lemma inst_context_snoc s Γ d : inst_context s (Γ ,, d) = inst_context s Γ ,, map_decl (inst (⇑^#|Γ| s)) d. +Lemma map_predicate_shift_eq_spec {T T'} fn fn' shift shift' + finst finst' (f : nat -> T) (f' : nat -> T') (p : predicate term) : + finst (puinst p) = finst' (puinst p) -> + map (fn f) (pparams p) = map (fn' f') (pparams p) -> + mapi_context (fun k => fn (shift k f)) (pcontext p) = + mapi_context (fun k => fn' (shift' k f')) (pcontext p) -> + fn (shift #|pcontext p| f) (preturn p) = fn' (shift' #|pcontext p| f') (preturn p) -> + map_predicate_shift fn shift finst f p = map_predicate_shift fn' shift' finst' f' p. Proof. - unfold snoc. apply inst_context_snoc0. + intros. unfold map_predicate_shift; f_equal; auto. Qed. -Hint Rewrite inst_context_snoc : sigma. +Hint Resolve map_predicate_shift_eq_spec : all. -Lemma inst_context_alt s Γ : - inst_context s Γ = - mapi (fun k' d => map_decl (inst (⇑^(Nat.pred #|Γ| - k') s)) d) Γ. +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) : + mapi_context (fun k => fn (shift k f)) (bcontext x) = + mapi_context (fun k => fn' (shift' k g)) (bcontext x) -> + fn (shift #|x.(bcontext)| f) (bbody x) = fn' (shift' #|x.(bcontext)| g) (bbody x) -> + map_branch_shift fn shift f x = map_branch_shift fn' shift' g x. Proof. - unfold inst_context. apply fold_context_alt. + intros. unfold map_branch_shift; f_equal; auto. Qed. +Hint Resolve map_branch_shift_eq_spec : all. -Lemma inst_context_length s Γ : #|inst_context s Γ| = #|Γ|. -Proof. apply fold_context_length. Qed. -Hint Rewrite inst_context_length : sigma wf. - -Hint Rewrite @subst_consn_nil @subst_consn_tip : sigma. - -Lemma inst_mkApps f l σ : (mkApps f l).[σ] = mkApps f.[σ] (map (inst σ) l). +Lemma map_predicate_shift_id_spec {T} {fn shift} {finst} {f : nat -> T} (p : predicate term) : + finst (puinst p) = puinst p -> + map (fn f) (pparams p) = (pparams p) -> + mapi_context (fun k => fn (shift k f)) (pcontext p) = (pcontext p) -> + fn (shift #|pcontext p| f) (preturn p) = (preturn p) -> + map_predicate_shift fn shift finst f p = p. Proof. - induction l in f |- *; simpl; auto. rewrite IHl. - now autorewrite with sigma. + intros. unfold map_predicate_shift; destruct p; f_equal; auto. Qed. -Hint Rewrite inst_mkApps : sigma. - -Lemma lift_renaming_0 k : ren (lift_renaming k 0) = ren (Nat.add k). -Proof. reflexivity. Qed. +Hint Resolve map_predicate_shift_id_spec : all. -Lemma ren_lift_renaming n k : ren (lift_renaming n k) =1 (⇑^k ↑^n). +Lemma map_branch_shift_id_spec {T} {fn : (nat -> T) -> term -> term} {shift} {f : nat -> T} (x : branch term) : + mapi_context (fun k => fn (shift k f)) (bcontext x) = (bcontext x) -> + fn (shift #|x.(bcontext)| f) (bbody x) = bbody x -> + map_branch_shift fn shift f x = x. Proof. - unfold subst_compose. intros i. - simpl. rewrite -{1}(Nat.add_0_r k). unfold ren. rewrite - (shiftn_lift_renaming n k 0). - pose proof (ren_shiftn k (lift_renaming n 0) i). - change ((ren (shiftn k (lift_renaming n 0)) i) = ((⇑^k (↑^n)) i)). - rewrite -H. sigma. rewrite lift_renaming_0. reflexivity. + intros. unfold map_branch_shift; destruct x; simpl; f_equal; auto. Qed. +Hint Resolve map_branch_shift_id_spec : all. -Lemma shiftk_compose n m : ↑^n ∘s ↑^m =1 ↑^(n + m). +Lemma rename_ext f f' : (f =1 f') -> (rename f =1 rename f'). Proof. - induction n; simpl; sigma; auto. - - reflexivity. - - rewrite -subst_compose_assoc. - rewrite -shiftk_shift shiftk_shift_l. - now rewrite subst_compose_assoc IHn -shiftk_shift shiftk_shift_l. + unfold pointwise_relation. + intros H t. revert f f' H. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all; eauto using shiftn_ext]. + - f_equal; solve_all. + * eapply map_predicate_shift_eq_spec; solve_all; eauto using shiftn_ext. + * apply map_branch_shift_eq_spec; solve_all; eauto using shiftn_ext. Qed. -Lemma lift0_inst n t : lift0 n t = t.[↑^n]. -Proof. by rewrite lift_rename rename_inst lift_renaming_0 -ren_shiftk. Qed. -Hint Rewrite lift0_inst : sigma. +Notation rename_branch := (map_branch_shift rename shiftn). + +Instance rename_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) rename. +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 rename_decl_inst_decl : - forall f d, - rename_decl f d = inst_decl (ren f) d. +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). Proof. - intros f d. - unfold rename_decl, inst_decl. - destruct d. unfold map_decl. - autorewrite with sigma. - f_equal. - simpl. destruct decl_body. - - simpl. f_equal. autorewrite with sigma. reflexivity. - - reflexivity. + intros Hfn Hshift finst finst' Hfinst f g Hfg p. + apply map_predicate_shift_eq_spec. + * apply Hfinst. + * now rewrite Hfg. + * now setoid_rewrite Hfg. + * apply Hfn. now setoid_rewrite Hfg. Qed. -Hint Rewrite rename_decl_inst_decl : sigma. -Lemma rename_context_inst_context : - forall f Γ, - rename_context f Γ = inst_context (ren f) Γ. +Instance rename_predicate_proper : Proper (`=1` ==> `=1`) rename_predicate. Proof. - intros f Γ. - induction Γ. - - reflexivity. - - autorewrite with sigma. rewrite IHΓ. f_equal. - destruct a. unfold inst_decl. unfold map_decl. simpl. - f_equal. - + destruct decl_body. 2: reflexivity. - simpl. f_equal. autorewrite with sigma. - now rewrite -up_Upn ren_shiftn. - + autorewrite with sigma. - now rewrite -up_Upn ren_shiftn. -Qed. -Hint Rewrite rename_context_inst_context : sigma. - -(* Lemma rename_subst : *) -(* forall f l t n, *) -(* rename f (subst l n t) = *) -(* subst (map (rename f) l) (#|l| + n) (rename (shiftn #|l| f) t). *) -(* (* subst (map (rename (shiftn n f)) l) n (rename (shiftn (#|l| + n) f) t). *) *) -(* Proof. *) - -Lemma rename_subst0 : - forall f l t, - rename f (subst0 l t) = - subst0 (map (rename f) l) (rename (shiftn #|l| f) t). -Proof. - intros f l t. - autorewrite with sigma. - eapply inst_ext. intro i. - unfold ren, subst_consn, shiftn, subst_compose. simpl. - rewrite nth_error_map. - destruct (nth_error l i) eqn: e1. - - eapply nth_error_Some_length in e1 as hl. - destruct (Nat.ltb_spec i #|l|). 2: lia. - rewrite e1. simpl. - autorewrite with sigma. reflexivity. - - simpl. apply nth_error_None in e1 as hl. - destruct (Nat.ltb_spec i #|l|). 1: lia. - rewrite (iffRL (nth_error_None _ _)). 1: lia. - simpl. rewrite map_length. unfold ids. - f_equal. lia. -Qed. - -Lemma rename_subst10 : - forall f t u, - rename f (t{ 0 := u }) = (rename (shiftn 1 f) t){ 0 := rename f u }. -Proof. - intros f t u. - eapply rename_subst0. -Qed. - -Lemma rename_context_nth_error : - forall f Γ i decl, - nth_error Γ i = Some decl -> - nth_error (rename_context f Γ) i = - Some (rename_decl (shiftn (#|Γ| - S i) f) decl). -Proof. - intros f Γ i decl h. - induction Γ in f, i, decl, h |- *. - - destruct i. all: discriminate. - - destruct i. - + simpl in h. inversion h. subst. clear h. - rewrite rename_context_snoc0. simpl. - f_equal. f_equal. f_equal. lia. - + simpl in h. rewrite rename_context_snoc0. simpl. - eapply IHΓ. eassumption. -Qed. - -Lemma rename_context_decl_body : - forall f Γ i body, - option_map decl_body (nth_error Γ i) = Some (Some body) -> - option_map decl_body (nth_error (rename_context f Γ) i) = - Some (Some (rename (shiftn (#|Γ| - S i) f) body)). -Proof. - intros f Γ i body h. - destruct (nth_error Γ i) eqn: e. 2: discriminate. - simpl in h. - eapply rename_context_nth_error with (f := f) in e. rewrite e. simpl. - destruct c as [na bo ty]. simpl in h. inversion h. subst. - simpl. reflexivity. + apply map_predicate_shift_proper; try tc. + now intros x. Qed. -Instance ren_ext : Morphisms.Proper (`=1` ==> `=1`)%signature ren. +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). Proof. - reduce_goal. unfold ren. now rewrite H. + intros Hfn Hshift f g Hfg x. + apply map_branch_shift_eq_spec. + * now setoid_rewrite Hfg. + * apply Hfn. now rewrite Hfg. +Qed. + +Instance rename_branch_proper : Proper (`=1` ==> `=1`) rename_branch. +Proof. + apply map_branch_shift_proper; tc. Qed. Lemma shiftn0 r : shiftn 0 r =1 r. @@ -307,2003 +253,1931 @@ Proof. destruct (Nat.ltb_spec (S x) (S n)); auto; lia. Qed. -Lemma subst_consn_shiftn n (l : list term) σ : #|l| = n -> ↑^n ∘s (l ⋅n σ) =1 σ. +Lemma shiftn_add n m f : shiftn n (shiftn m f) =1 shiftn (n + m) f. Proof. - induction n in l |- *; simpl; intros; autorewrite with sigma. - - destruct l; try discriminate. simpl; autorewrite with sigma. reflexivity. - - destruct l; try discriminate. simpl in *. - rewrite subst_consn_subst_cons. - simpl; autorewrite with sigma. apply IHn. lia. + intros i. + unfold shiftn. + destruct (Nat.ltb_spec i n). + - 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. Qed. -Lemma shiftn_consn_idsn n σ : ↑^n ∘s ⇑^n σ =1 σ ∘s ↑^n. +Hint Rewrite shiftn0 : sigma. + +Definition rshiftk n := Nat.add n. + +Instance rshiftk_proper : Proper (Logic.eq ==> Logic.eq) rshiftk. Proof. - unfold Upn. rewrite subst_consn_shiftn; [reflexivity|]. - now rewrite idsn_length. + now intros x y ->. Qed. -Lemma subst10_inst a b τ : b {0 := a}.[τ] = (b.[⇑ τ] {0 := a.[τ]}). +Lemma shiftn_rshiftk n f : shiftn n f ∘ rshiftk n =1 rshiftk n ∘ f. Proof. - unfold subst10. simpl. rewrite !subst_inst. - now unfold Upn, Up; autorewrite with sigma. + intros i. rewrite /shiftn /rshiftk /=. nat_compare_specs. + now replace (n + i - n) with i by lia. Qed. -Hint Rewrite subst10_inst : sigma. +Hint Rewrite shiftn_rshiftk : sigma. -Local Open Scope sigma. -Lemma Upn_compose n σ σ' : ⇑^n σ ∘s ⇑^n σ' =1 ⇑^n (σ ∘s σ'). +Lemma shiftn_1_S f x : shiftn 1 f (S x) = rshiftk 1 (f x). +Proof. now rewrite /shiftn /= Nat.sub_0_r. Qed. +Hint Rewrite shiftn_1_S : sigma. + +Definition lift_renaming n k := + fun i => + if Nat.leb k i then (* Lifted *) n + i + else i. + +Lemma lift_renaming_spec n k : lift_renaming n k =1 (shiftn k (rshiftk n)). Proof. - induction n. - - unfold Upn. simpl. - now rewrite !subst_consn_nil !shiftk_0 !compose_ids_r. - - rewrite !Upn_S. autorewrite with sigma. now rewrite IHn. + rewrite /lift_renaming /shiftn /rshiftk. + intros i. repeat nat_compare_specs. Qed. -Lemma up_ext_closed k' k s s' : - (forall i, i < k' -> s i = s' i) -> - forall i, i < k + k' -> - up k s i = up k s' i. +Lemma lift_renaming_0_rshift k : lift_renaming k 0 =1 rshiftk k. +Proof. reflexivity. Qed. + +Lemma shiftn_lift_renaming n m k : + shiftn m (lift_renaming n k) =1 lift_renaming n (m + k). Proof. - unfold up. intros Hs t. elim (Nat.leb_spec k t) => H; auto. - intros. f_equal. apply Hs. lia. + now rewrite !lift_renaming_spec shiftn_add. Qed. -Lemma inst_ext_closed s s' k t : - closedn k t -> - (forall x, x < k -> s x = s' x) -> - inst s t = inst s' t. +Lemma lift_rename n k t : lift n k t = rename (lift_renaming n k) t. Proof. - clear. - intros clt Hs. revert k clt s s' Hs. - elim t using PCUICInduction.term_forall_list_ind; simpl in |- *; intros; try easy ; - try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + revert n k. + elim t using term_forall_list_ind; simpl in |- *; intros; try reflexivity; + try (rewrite ?H ?H0 ?H1; reflexivity); try solve [f_equal; solve_all]. - - apply Hs. now eapply Nat.ltb_lt. - - move/andb_and: clt => []. intros. f_equal; eauto. - eapply H0; eauto. intros. eapply up_ext_closed; eauto. - - move/andb_and: clt => []. intros. f_equal; eauto. now eapply H0, up_ext_closed. - - move/andb_and: clt => [] /andb_and[] ?. intros. f_equal; eauto. - now eapply H1, up_ext_closed. - - move/andb_and: clt => [] ? ?. f_equal; eauto. - - move/andb_and: clt => [] /andb_and[] ? ? b1. - red in X. solve_all. f_equal; eauto. - eapply All_map_eq. eapply (All_impl b1). pcuicfo. - unfold on_snd. f_equal. now eapply a0. - - f_equal; eauto. red in X. solve_all. - move/andb_and: b => []. eauto. intros. - apply map_def_eq_spec; eauto. - eapply b0; eauto. now apply up_ext_closed. - - f_equal; eauto. red in X. solve_all. - move/andb_and: b => []. eauto. intros. - apply map_def_eq_spec; eauto. - eapply b0; eauto. now apply up_ext_closed. -Qed. + - f_equal; eauto. + now rewrite H0 shiftn_lift_renaming. + - f_equal; eauto. + now rewrite H0 shiftn_lift_renaming. + - f_equal; eauto. + rewrite H1. now rewrite shiftn_lift_renaming. + - f_equal; auto. + * solve_all. + unfold map_predicate_k, rename_predicate; f_equal; eauto; solve_all. + + unfold shiftf. now rewrite shiftn_lift_renaming. + + now rewrite shiftn_lift_renaming. + * solve_all. + unfold map_branch_k, map_branch_shift; f_equal; eauto; solve_all. + + unfold shiftf. now rewrite shiftn_lift_renaming. + + now rewrite shiftn_lift_renaming. + - f_equal; auto. + red in X. solve_all. + rewrite b. now rewrite shiftn_lift_renaming. + - f_equal; auto. + red in X. solve_all. + rewrite b. now rewrite shiftn_lift_renaming. +Qed. +Hint Rewrite @lift_rename : sigma. + +Lemma lift0_rename k : lift0 k =1 rename (rshiftk k). +Proof. + now intros t; rewrite lift_rename lift_renaming_0_rshift. +Qed. +Hint Rewrite lift0_rename : sigma. + +Definition up k (s : nat -> term) := + fun i => + if k <=? i then rename (Nat.add k) (s (i - k)) + else tRel i. + +Lemma shiftn_compose n f f' : shiftn n f ∘ shiftn n f' =1 shiftn n (f ∘ f'). +Proof. + unfold shiftn. intros x. + elim (Nat.ltb_spec x n) => H. + - now rewrite (proj2 (Nat.ltb_lt x n)). + - destruct (Nat.ltb_spec (n + f' (x - n)) n). + * lia. + * 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) = + 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. + rewrite map_branch_shift_map_branch_shift. + simpl. now apply map_branch_eq_spec. +Qed. *) -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. +Lemma mapi_context_compose f f' : + mapi_context f ∘ mapi_context f' =1 + mapi_context (f ∘i f'). Proof. - unfold subst_fn; intros Hx Heq Heqx. - 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. + intros x. + now rewrite !mapi_context_fold fold_context_k_compose - !mapi_context_fold. Qed. +Hint Rewrite mapi_context_compose : map. -Lemma subst_id s Γ t : - closedn #|s| t -> - assumption_context Γ -> - s = List.rev (to_extended_list Γ) -> - subst s 0 t = t. +Lemma rename_compose f f' : rename f ∘ rename f' =1 rename (f ∘ f'). Proof. - intros cl ass eq. - autorewrite with sigma. - rewrite -{2}(subst_ids t). - eapply inst_ext_closed; eauto. - intros. - unfold ids, subst_consn. simpl. - destruct (snd (nth_error_Some' s x) H). rewrite e. - subst s. - rewrite /to_extended_list /to_extended_list_k in e. - rewrite List.rev_length in cl, H. autorewrite with len in *. - rewrite reln_alt_eq in e. - rewrite app_nil_r List.rev_involutive in e. - clear -ass e. revert e. - rewrite -{2}(Nat.add_0_r x). - generalize 0. - induction Γ in x, ass, x0 |- * => n. - - simpl in *. rewrite nth_error_nil => //. - - depelim ass; simpl. - destruct x; simpl in *; try congruence. - move=> e; specialize (IHΓ ass); simpl in e. - specialize (IHΓ _ _ _ e). subst x0. f_equal. lia. -Qed. - -Lemma map_inst_idsn l l' n : - #|l| = n -> - map (inst (l ⋅n l')) (idsn n) = l. -Proof. - induction n in l, l' |- *. - - destruct l => //. - - destruct l as [|l a] using rev_case => // /=. - rewrite app_length /= Nat.add_1_r => [=]. - intros; subst n. - simpl. rewrite map_app. - f_equal; auto. - + rewrite subst_consn_app. - now apply IHn. - + simpl. - destruct (@subst_consn_lt _ (l ++ [a]) #|l|) as [a' [hnth heq]]. - * rewrite app_length. simpl; lia. - * rewrite heq. rewrite nth_error_app_ge in hnth; auto. - rewrite Nat.sub_diag in hnth. simpl in hnth. congruence. -Qed. - -Lemma map_vass_map_def g l r : - (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) - (map (map_def (rename r) g) l)) = - (mapi (fun i d => map_decl (rename (shiftn i r)) d) - (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) l)). -Proof. - rewrite mapi_mapi mapi_map. apply mapi_ext. - intros. unfold map_decl, vass; simpl; f_equal. - rewrite !lift0_inst. rewrite !rename_inst. - autorewrite with sigma. rewrite -ren_shiftn up_Upn. - rewrite shiftn_consn_idsn. reflexivity. -Qed. - -Lemma rename_fix_context r : - forall (mfix : list (def term)), - fix_context (map (map_def (rename r) (rename (shiftn #|mfix| r))) mfix) = - rename_context r (fix_context mfix). -Proof. - intros mfix. unfold fix_context. - rewrite map_vass_map_def rev_mapi. - fold (fix_context mfix). - rewrite (rename_context_alt r (fix_context mfix)). - unfold map_decl. now rewrite mapi_length fix_context_length. -Qed. - -Lemma map_vass_map_def_inst g l s : - (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) - (map (map_def (inst s) g) l)) = - (mapi (fun i d => map_decl (inst (⇑^i s)) d) - (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) l)). -Proof. - rewrite mapi_mapi mapi_map. apply mapi_ext. - intros. unfold map_decl, vass; simpl; f_equal. - rewrite !lift0_inst. - autorewrite with sigma. - rewrite shiftn_consn_idsn. reflexivity. -Qed. - -Lemma inst_fix_context: - forall (mfix : list (def term)) s, - fix_context (map (map_def (inst s) (inst (⇑^#|mfix| s))) mfix) = - inst_context s (fix_context mfix). -Proof. - intros mfix s. unfold fix_context. - rewrite map_vass_map_def_inst rev_mapi. - fold (fix_context mfix). - rewrite (inst_context_alt s (fix_context mfix)). - now rewrite mapi_length fix_context_length. -Qed. - -(* Lemma rename_lift0 : *) -(* forall f i t, *) -(* rename f (lift0 i t) = lift0 (f i) (rename f t). *) -(* Proof. *) -(* intros f i t. *) -(* rewrite !lift_rename. *) -(* autorewrite with sigma. *) -(* eapply inst_ext. intro j. *) -(* unfold ren, lift_renaming, subst_compose, shiftn. *) -(* simpl. f_equal. *) -(* destruct (Nat.ltb_spec j i). *) -(* - *) - -(* (rename (shiftn (#|Γ| - S i) f) body) *) -(* rename f ((lift0 (S i)) body) *) - -Section Renaming. - -Context `{checker_flags}. - -Lemma eq_term_upto_univ_rename Σ : - forall Re Rle napp u v f, - eq_term_upto_univ_napp Σ Re Rle napp u v -> - eq_term_upto_univ_napp Σ Re Rle napp (rename f u) (rename f v). -Proof. - intros Re Rle napp u v f h. - induction u in v, napp, Rle, f, h |- * using term_forall_list_ind. - all: dependent destruction h. - all: try solve [ - simpl ; constructor ; eauto - ]. - - simpl. constructor. - induction X in a, args' |- *. - + inversion a. constructor. - + inversion a. subst. simpl. constructor. - all: eauto. - - simpl. constructor. all: eauto. - induction X in a, brs' |- *. - + inversion a. constructor. - + inversion a. subst. simpl. - constructor. - * unfold on_snd. intuition eauto. - * eauto. - - simpl. constructor. - apply All2_length in a as e. rewrite <- e. - generalize #|m|. intro k. - induction X in mfix', a, f, k |- *. - + inversion a. constructor. - + inversion a. subst. - simpl. constructor. - * unfold map_def. intuition eauto. - * eauto. - - simpl. constructor. - apply All2_length in a as e. rewrite <- e. - generalize #|m|. intro k. - induction X in mfix', a, f, k |- *. - + inversion a. constructor. - + inversion a. subst. - simpl. constructor. - * unfold map_def. intuition eauto. - * eauto. -Qed. - -(* Notion of valid renaming without typing information. *) -Definition urenaming Γ Δ f := - forall i decl, - nth_error Δ i = Some decl -> - ∑ decl', - nth_error Γ (f i) = Some decl' × - rename f (lift0 (S i) decl.(decl_type)) - = lift0 (S (f i)) decl'.(decl_type) × - (forall b, - decl.(decl_body) = Some b -> - ∑ b', - decl'.(decl_body) = Some b' × - rename f (lift0 (S i) b) = lift0 (S (f i)) b' - ). - -(* Definition of a good renaming with respect to typing *) -Definition renaming Σ Γ Δ f := - wf_local Σ Γ × urenaming Γ Δ f. - -(* TODO MOVE *) -Lemma rename_iota_red : - forall f pars c args brs, - rename f (iota_red pars c args brs) = - iota_red pars c (map (rename f) args) (map (on_snd (rename f)) brs). -Proof. - intros f pars c args brs. - unfold iota_red. rewrite rename_mkApps. - rewrite map_skipn. f_equal. - change (rename f (nth c brs (0, tDummy)).2) - with (on_snd (rename f) (nth c brs (0, tDummy))).2. f_equal. - rewrite <- map_nth with (f := on_snd (rename f)). - reflexivity. -Qed. + intros x. + induction x in f, f' |- * using term_forall_list_ind; simpl; + f_equal; + auto; solve_all; + try match goal with + [ H : forall f f', rename f (rename f' ?x) = _ |- rename _ (rename _ ?x) = _] => + now rewrite H shiftn_compose + end. -(* TODO MOVE *) -Lemma isLambda_rename : - forall t f, - isLambda t -> - isLambda (rename f t). -Proof. - intros t f h. - destruct t. - all: try discriminate. - simpl. reflexivity. -Qed. - -(* TODO MOVE *) -Lemma rename_unfold_fix : - forall mfix idx narg fn f, - unfold_fix mfix idx = Some (narg, fn) -> - unfold_fix (map (map_def (rename f) (rename (shiftn #|mfix| f))) mfix) idx - = Some (narg, rename f fn). -Proof. - intros mfix idx narg fn f h. - unfold unfold_fix in *. rewrite nth_error_map. - case_eq (nth_error mfix idx). - 2: intro neq ; rewrite neq in h ; discriminate. - intros d e. rewrite e in h. - inversion h. clear h. - simpl. - f_equal. f_equal. - rewrite rename_subst0. rewrite fix_subst_length. + - rewrite /map_predicate_shift /= map_map. + solve_all; len. rewrite e. f_equal; solve_all. + * rewrite H. apply rename_ext, shiftn_compose. + * apply rename_ext, shiftn_compose. + - rewrite /map_branch_shift /=. f_equal; solve_all. + * rewrite H. apply rename_ext, shiftn_compose. + * len. rewrite b. apply rename_ext, shiftn_compose. +Qed. + +Lemma map_predicate_shift_map_predicate_shift + {T} {fn : (nat -> T) -> term -> term} + {shift : nat -> (nat -> T) -> nat -> T} + {finst finst'} + {f f' : nat -> T} + {p : predicate term} + (compose : (nat -> T) -> (nat -> T) -> nat -> T) : + forall (shiftn0 : forall f, shift 0 f =1 f), + Proper (`=1` ==> eq ==> eq) fn -> + (forall i, fn (shift i f) ∘ fn (shift i f') =1 fn (shift i (compose f f'))) -> + map_predicate_shift fn shift finst f (map_predicate_shift fn shift finst' f' p) = + map_predicate_shift fn shift (finst ∘ finst') (compose f f') p. +Proof. + intros shift0 Hfn Hff'. + unfold map_predicate_shift; destruct p; cbn. f_equal. - unfold fix_subst. rewrite map_length. - generalize #|mfix| at 2 3. intro n. - induction n. - - reflexivity. - - simpl. - f_equal. rewrite IHn. reflexivity. -Qed. - -(* TODO MOVE *) -Lemma decompose_app_rename : - forall f t u l, - decompose_app t = (u, l) -> - decompose_app (rename f t) = (rename f u, map (rename f) l). -Proof. - assert (aux : forall f t u l acc, - decompose_app_rec t acc = (u, l) -> - decompose_app_rec (rename f t) (map (rename f) acc) = - (rename f u, map (rename f) l) - ). - { intros f t u l acc h. - induction t in acc, h |- *. - all: try solve [ simpl in * ; inversion h ; reflexivity ]. - simpl. simpl in h. specialize IHt1 with (1 := h). assumption. - } - intros f t u l. - unfold decompose_app. - eapply aux. -Qed. - -(* TODO MOVE *) -Lemma isConstruct_app_rename : - forall t f, - isConstruct_app t -> - isConstruct_app (rename f t). -Proof. - intros t f h. - unfold isConstruct_app in *. - case_eq (decompose_app t). intros u l e. - apply decompose_app_rename with (f := f) in e as e'. - rewrite e'. rewrite e in h. simpl in h. - simpl. - destruct u. all: try discriminate. - simpl. reflexivity. -Qed. - -(* TODO MOVE *) -Lemma is_constructor_rename : - forall n l f, - is_constructor n l -> - is_constructor n (map (rename f) l). -Proof. - intros n l f h. - unfold is_constructor in *. - rewrite nth_error_map. - destruct nth_error. - - simpl. apply isConstruct_app_rename. assumption. - - simpl. discriminate. -Qed. - -(* TODO MOVE *) -Lemma rename_unfold_cofix : - forall mfix idx narg fn f, - unfold_cofix mfix idx = Some (narg, fn) -> - unfold_cofix (map (map_def (rename f) (rename (shiftn #|mfix| f))) mfix) idx - = Some (narg, rename f fn). -Proof. - intros mfix idx narg fn f h. - unfold unfold_cofix in *. rewrite nth_error_map. - case_eq (nth_error mfix idx). - 2: intro neq ; rewrite neq in h ; discriminate. - intros d e. rewrite e in h. - inversion h. - simpl. f_equal. f_equal. - rewrite rename_subst0. rewrite cofix_subst_length. + * rewrite map_map. + specialize (Hff' 0). + apply map_ext => x. + specialize (Hff' x). simpl in Hff'. + now setoid_rewrite shift0 in Hff'. + * rewrite !mapi_context_fold fold_context_k_compose. + apply fold_context_k_ext => i x. apply Hff'. + * len. apply Hff'. +Qed. + +Lemma map_predicate_shift_map_predicate + {T} {fn : (nat -> T) -> term -> term} + {shift : nat -> (nat -> T) -> nat -> T} + {finst finst' f'} + {f : nat -> T} + {p : predicate term} + (compose : (nat -> T) -> (term -> term) -> (nat -> T)) + : + Proper (`=1` ==> `=1`) fn -> + (map (fn f ∘ f') p.(pparams) = map (fn (compose f f')) p.(pparams)) -> + mapi_context (fun (k : nat) (x : term) => fn (shift k f) (f' x)) p.(pcontext) = + mapi_context (fun k : nat => fn (shift k (compose f f'))) p.(pcontext) -> + fn (shift #|p.(pcontext)| f) (f' p.(preturn)) = fn (shift #|p.(pcontext)| (compose f f')) p.(preturn) -> + map_predicate_shift fn shift finst f (map_predicate finst' f' f' p) = + map_predicate_shift fn shift (finst ∘ finst') (compose f f') p. +Proof. + intros Hfn Hf Hf' Hf''. unfold map_predicate_shift; destruct p; cbn. f_equal. - unfold cofix_subst. rewrite map_length. - generalize #|mfix| at 2 3. intro n. - induction n. - - reflexivity. - - simpl. - f_equal. rewrite IHn. reflexivity. + * rewrite map_map. + now rewrite Hf. + * rewrite !mapi_context_fold fold_context_k_map. + rewrite - !mapi_context_fold. + now rewrite Hf'. + * len. apply Hf''. +Qed. + +Lemma map_predicate_shift_map_predicate_gen + {T} {fn : (nat -> T) -> term -> term} + {T'} {fn' : (nat -> T') -> term -> term} + {shift : nat -> (nat -> T) -> nat -> T} + {shift' : nat -> (nat -> T') -> nat -> T'} + {finst finst' f'} + {f : nat -> T} + {p : predicate term} + (compose : (nat -> T) -> (term -> term) -> (nat -> T')) + : + Proper (`=1` ==> `=1`) fn -> + (map (fn f ∘ f') p.(pparams) = map (fn' (compose f f')) p.(pparams)) -> + mapi_context (fun (k : nat) (x : term) => fn (shift k f) (f' x)) p.(pcontext) = + mapi_context (fun k : nat => fn' (shift' k (compose f f'))) p.(pcontext) -> + fn (shift #|p.(pcontext)| f) (f' p.(preturn)) = fn' (shift' #|p.(pcontext)| (compose f f')) p.(preturn) -> + map_predicate_shift fn shift finst f (map_predicate finst' f' f' p) = + map_predicate_shift fn' shift' (finst ∘ finst') (compose f f') p. +Proof. + intros Hfn Hf Hf' Hf''. unfold map_predicate_shift; destruct p; cbn. + f_equal. + * rewrite map_map. + now rewrite Hf. + * rewrite !mapi_context_fold fold_context_k_map. + rewrite - !mapi_context_fold. + now rewrite Hf'. + * len. apply Hf''. +Qed. + +Lemma map_predicate_map_predicate_shift + {T} {fn : (nat -> T) -> term -> term} + {shift : nat -> (nat -> T) -> nat -> T} + {finst finst' f'} + {f : nat -> T} + {p : predicate term} + (compose : (term -> term) -> (nat -> T) -> (nat -> T)) + : + Proper (`=1` ==> `=1`) fn -> + (forall f, f' ∘ fn f =1 fn (compose f' f)) -> + (forall k, compose f' (shift k f) =1 shift k (compose f' f)) -> + map_predicate finst' f' f' (map_predicate_shift fn shift finst f p) = + map_predicate_shift fn shift (finst' ∘ finst) (compose f' f) p. +Proof. + intros Hfn Hf Hcom. unfold map_predicate_shift, map_predicate; destruct p; cbn. + f_equal. + * rewrite map_map. + now rewrite Hf. + * rewrite !mapi_context_fold map_fold_context_k. + setoid_rewrite Hf. now setoid_rewrite Hcom. + * len. rewrite (Hf _ _). + now setoid_rewrite Hcom. +Qed. + +Lemma rename_predicate_rename_predicate (f f' : nat -> nat) (p : predicate term) : + rename_predicate f (rename_predicate f' p) = + rename_predicate (f ∘ f') p. +Proof. + rewrite (map_predicate_shift_map_predicate_shift Basics.compose) //. + * apply shiftn0. + * intros i x. now rewrite (rename_compose _ _ x) shiftn_compose. +Qed. +Hint Rewrite rename_predicate_rename_predicate : map. + +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} + (compose : (nat -> T) -> (nat -> T) -> nat -> T) : + (forall i, fn (shift i f) ∘ fn (shift i f') =1 fn (shift i (compose f f'))) -> + map_branch_shift fn shift f (map_branch_shift fn shift f' b) = + map_branch_shift fn shift (compose f f') b. +Proof. + intros Hfn. + unfold map_branch_shift; destruct b; cbn. + f_equal. + * rewrite !mapi_context_fold fold_context_k_compose. + apply fold_context_k_ext => i x. apply Hfn. + * len. apply Hfn. Qed. -(* TODO MOVE *) -Lemma rename_closedn : - forall f n t, - closedn n t -> - rename (shiftn n f) t = t. +Lemma rename_branch_rename_branch f f' : + rename_branch f ∘ rename_branch f' =1 + rename_branch (f ∘ f'). Proof. - intros f n t e. - autorewrite with sigma. - erewrite <- inst_closed with (σ := ren f) by eassumption. - eapply inst_ext. intro i. - unfold ren, shiftn, Upn, subst_consn, subst_compose, shift, shiftk. - rewrite idsn_length. - destruct (Nat.ltb_spec i n). - - rewrite nth_error_idsn_Some. all: auto. - - rewrite nth_error_idsn_None. 1: lia. - simpl. reflexivity. -Qed. - -(* TODO MOVE *) -Lemma rename_closed : - forall f t, - closed t -> - rename f t = t. -Proof. - intros f t h. - replace (rename f t) with (rename (shiftn 0 f) t). - - apply rename_closedn. assumption. - - autorewrite with sigma. eapply inst_ext. intro i. - unfold ren, shiftn. simpl. - f_equal. f_equal. lia. -Qed. - -(* TODO MOVE *) -Lemma declared_constant_closed_body : - forall Σ cst decl body, - wf Σ -> - declared_constant Σ cst decl -> - decl.(cst_body) = Some body -> - closed body. -Proof. - intros Σ cst decl body hΣ h e. - unfold declared_constant in h. - eapply lookup_on_global_env in h. 2: eauto. - destruct h as [Σ' [wfΣ' decl']]. - red in decl'. red in decl'. - destruct decl as [ty bo un]. simpl in *. - rewrite e in decl'. - now eapply subject_closed in decl'. + intros br. + rewrite (map_branch_shift_map_branch_shift Basics.compose) //. + intros i x. now rewrite (rename_compose _ _ x) shiftn_compose. +Qed. +Hint Rewrite rename_branch_rename_branch : map. + +Lemma rename_branches_rename_branches f f' : + rename_branches f ∘ rename_branches f' =1 + rename_branches (f ∘ f'). +Proof. + intros br. + now autorewrite with map. Qed. +Hint Rewrite rename_branches_rename_branches : map. Lemma rename_shiftn : forall f k t, rename (shiftn k f) (lift0 k t) = lift0 k (rename f t). Proof. intros f k t. - autorewrite with sigma. - eapply inst_ext. intro i. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - destruct (Nat.ltb_spec (k + i) k); try lia. - unfold shiftk. lia_f_equal. -Qed. - -Lemma urenaming_vass : - forall Γ Δ na A f, - urenaming Γ Δ f -> - urenaming (Γ ,, vass na (rename f A)) (Δ ,, vass na A) (shiftn 1 f). -Proof. - intros Γ Δ na A f h. unfold urenaming in *. - intros [|i] decl e. - - simpl in e. inversion e. subst. clear e. - simpl. eexists. split. 1: reflexivity. - split. - + autorewrite with sigma. - eapply inst_ext. intro i. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - replace (i - 0) with i by lia. reflexivity. - + intros. discriminate. - - simpl in e. simpl. - replace (i - 0) with i by lia. - eapply h in e as [decl' [? [h1 h2]]]. - eexists. split. 1: eassumption. - split. - + rewrite simpl_lift0. rewrite rename_shiftn. rewrite h1. - autorewrite with sigma. - eapply inst_ext. intro j. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - replace (i - 0) with i by lia. - reflexivity. - + intros b e'. - eapply h2 in e' as [b' [? hb]]. - eexists. split. 1: eassumption. - rewrite simpl_lift0. rewrite rename_shiftn. rewrite hb. - autorewrite with sigma. - eapply inst_ext. intro j. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - replace (i - 0) with i by lia. - reflexivity. -Qed. + rewrite lift0_rename !(rename_compose _ _ _). + now sigma. +Qed. + +Lemma up_up k k' s : up k (up k' s) =1 up (k + k') s. +Proof. + red. intros x. unfold up. + elim (Nat.leb_spec k x) => H. + - elim (Nat.leb_spec (k + k') x) => H'. + + elim (Nat.leb_spec k' (x - k)) => H''. + ++ rewrite Nat.sub_add_distr. + rewrite -> rename_compose. apply rename_ext => t. lia. + ++ simpl. lia. + + edestruct (Nat.leb_spec k' (x - k)); simpl; lia_f_equal. + - elim (Nat.leb_spec (k + k') x) => H'; lia_f_equal. +Qed. + +Fixpoint inst s u := + match u with + | tRel n => s n + | tEvar ev args => tEvar ev (List.map (inst s) args) + | tLambda na T M => tLambda na (inst s T) (inst (up 1 s) M) + | tApp u v => tApp (inst s u) (inst s v) + | tProd na A B => tProd na (inst s A) (inst (up 1 s) B) + | tLetIn na b ty b' => tLetIn na (inst s b) (inst s ty) (inst (up 1 s) b') + | tCase ind p c brs => + let p' := map_predicate_shift inst up id s p in + let brs' := map (map_branch_shift inst up s) brs in + tCase ind p' (inst s c) brs' + | tProj p c => tProj p (inst s c) + | tFix mfix idx => + let mfix' := map (map_def (inst s) (inst (up (List.length mfix) s))) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let mfix' := map (map_def (inst s) (inst (up (List.length mfix) s))) mfix in + tCoFix mfix' idx + | x => x + end. -Lemma renaming_vass : - forall Σ Γ Δ na A f, - wf_local Σ (Γ ,, vass na (rename f A)) -> - renaming Σ Γ Δ f -> - renaming Σ (Γ ,, vass na (rename f A)) (Δ ,, vass na A) (shiftn 1 f). -Proof. - intros Σ Γ Δ na A f hΓ [? h]. - split. 1: auto. - eapply urenaming_vass. assumption. -Qed. - -Lemma urenaming_vdef : - forall Γ Δ na b B f, - urenaming Γ Δ f -> - urenaming (Γ ,, vdef na (rename f b) (rename f B)) (Δ ,, vdef na b B) (shiftn 1 f). -Proof. - intros Γ Δ na b B f h. unfold urenaming in *. - intros [|i] decl e. - - simpl in e. inversion e. subst. clear e. - simpl. eexists. split. 1: reflexivity. - split. - + autorewrite with sigma. - eapply inst_ext. intro i. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - replace (i - 0) with i by lia. reflexivity. - + intros b' [= <-]. - simpl. eexists. split. 1: reflexivity. - autorewrite with sigma. - eapply inst_ext. intro i. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - replace (i - 0) with i by lia. reflexivity. - - simpl in e. simpl. - replace (i - 0) with i by lia. - eapply h in e as [decl' [? [h1 h2]]]. - eexists. split. 1: eassumption. - split. - + rewrite simpl_lift0. rewrite rename_shiftn. rewrite h1. - autorewrite with sigma. - eapply inst_ext. intro j. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - replace (i - 0) with i by lia. - reflexivity. - + intros b0 e'. - eapply h2 in e' as [b' [? hb]]. - eexists. split. 1: eassumption. - rewrite simpl_lift0. rewrite rename_shiftn. rewrite hb. - autorewrite with sigma. - eapply inst_ext. intro j. - unfold ren, lift_renaming, shiftn, subst_compose. simpl. - replace (i - 0) with i by lia. - reflexivity. -Qed. +Notation inst_predicate := (map_predicate_shift inst up id). +Notation inst_branch := (map_branch_shift inst up). +Notation inst_branches f := (map (inst_branch f)). -Lemma renaming_vdef : - forall Σ Γ Δ na b B f, - wf_local Σ (Γ ,, vdef na (rename f b) (rename f B)) -> - renaming Σ Γ Δ f -> - renaming Σ (Γ ,, vdef na (rename f b) (rename f B)) (Δ ,, vdef na b B) (shiftn 1 f). -Proof. - intros Σ Γ Δ na b B f hΓ [? h]. - split. 1: auto. - eapply urenaming_vdef. assumption. -Qed. - -Lemma urenaming_ext : - forall Γ Δ f g, - f =1 g -> - urenaming Δ Γ f -> - urenaming Δ Γ g. -Proof. - intros Γ Δ f g hfg h. - intros i decl e. - specialize (h i decl e) as [decl' [h1 [h2 h3]]]. - exists decl'. split ; [| split ]. - - rewrite <- (hfg i). assumption. - - rewrite <- (hfg i). rewrite <- h2. - eapply rename_ext. intros j. symmetry. apply hfg. - - intros b hb. specialize (h3 b hb) as [b' [p1 p2]]. - exists b'. split ; auto. rewrite <- (hfg i). rewrite <- p2. - eapply rename_ext. intros j. symmetry. apply hfg. -Qed. - -Lemma urenaming_context : - forall Γ Δ Ξ f, - urenaming Δ Γ f -> - urenaming (Δ ,,, rename_context f Ξ) (Γ ,,, Ξ) (shiftn #|Ξ| f). -Proof. - intros Γ Δ Ξ f h. - induction Ξ as [| [na [bo|] ty] Ξ ih] in Γ, Δ, f, h |- *. - - simpl. eapply urenaming_ext. 2: eassumption. - intros []. all: reflexivity. - - simpl. rewrite rename_context_snoc. - rewrite app_context_cons. simpl. unfold rename_decl. unfold map_decl. simpl. - eapply urenaming_ext. - 2: eapply urenaming_vdef. - + intros [|i]. - * reflexivity. - * unfold shiftn. simpl. replace (i - 0) with i by lia. - destruct (Nat.ltb_spec0 i #|Ξ|). - -- destruct (Nat.ltb_spec0 (S i) (S #|Ξ|)). all: easy. - -- destruct (Nat.ltb_spec0 (S i) (S #|Ξ|)). all: easy. - + eapply ih. assumption. - - simpl. rewrite rename_context_snoc. - rewrite app_context_cons. simpl. unfold rename_decl. unfold map_decl. simpl. - eapply urenaming_ext. - 2: eapply urenaming_vass. - + intros [|i]. - * reflexivity. - * unfold shiftn. simpl. replace (i - 0) with i by lia. - destruct (Nat.ltb_spec0 i #|Ξ|). - -- destruct (Nat.ltb_spec0 (S i) (S #|Ξ|)). all: easy. - -- destruct (Nat.ltb_spec0 (S i) (S #|Ξ|)). all: easy. - + eapply ih. assumption. -Qed. - -Lemma red1_rename : - forall Σ Γ Δ u v f, - wf Σ -> - urenaming Δ Γ f -> - red1 Σ Γ u v -> - red1 Σ Δ (rename f u) (rename f v). -Proof. - intros Σ Γ Δ u v f hΣ hf h. - induction h using red1_ind_all in f, Δ, hf |- *. - all: try solve [ - simpl ; constructor ; eapply IHh ; - try eapply urenaming_vass ; - try eapply urenaming_vdef ; - assumption - ]. - - simpl. rewrite rename_subst10. constructor. - - simpl. rewrite rename_subst10. constructor. - - simpl. - case_eq (nth_error Γ i). - 2: intro e ; rewrite e in H0 ; discriminate. - intros decl e. rewrite e in H0. simpl in H0. - inversion H0. clear H0. - unfold urenaming in hf. - specialize hf with (1 := e). - destruct hf as [decl' [e' [hr hbo]]]. - specialize hbo with (1 := H2). - destruct hbo as [body' [hbo' hr']]. - rewrite hr'. constructor. - rewrite e'. simpl. rewrite hbo'. reflexivity. - - simpl. rewrite rename_mkApps. simpl. - rewrite rename_iota_red. constructor. - - rewrite 2!rename_mkApps. simpl. - econstructor. - + eapply rename_unfold_fix. eassumption. - + eapply is_constructor_rename. assumption. - - simpl. - rewrite 2!rename_mkApps. simpl. - eapply red_cofix_case. - eapply rename_unfold_cofix. eassumption. - - simpl. rewrite 2!rename_mkApps. simpl. - eapply red_cofix_proj. - eapply rename_unfold_cofix. eassumption. - - simpl. rewrite rename_subst_instance_constr. - econstructor. - + eassumption. - + rewrite rename_closed. 2: assumption. - eapply declared_constant_closed_body. all: eauto. - - simpl. rewrite rename_mkApps. simpl. - econstructor. rewrite nth_error_map. rewrite H0. reflexivity. - - - simpl. constructor. induction X. - + destruct p0 as [[p1 p2] p3]. constructor. split ; eauto. - simpl. eapply p2. assumption. - + simpl. constructor. eapply IHX. - - simpl. constructor. induction X. - + destruct p as [p1 p2]. constructor. - eapply p2. assumption. - + simpl. constructor. eapply IHX. - - simpl. - apply OnOne2_length in X as hl. rewrite <- hl. clear hl. - generalize #|mfix0|. intro n. - constructor. - induction X. - + destruct p as [[p1 p2] p3]. inversion p3. - simpl. constructor. split. - * eapply p2. assumption. - * simpl. f_equal ; auto. f_equal ; auto. - f_equal. assumption. - + simpl. constructor. eapply IHX. - - simpl. - apply OnOne2_length in X as hl. rewrite <- hl. clear hl. - eapply fix_red_body. - Fail induction X using OnOne2_ind_l. - revert mfix0 mfix1 X. - refine ( - OnOne2_ind_l _ - (fun (L : mfixpoint term) (x y : def term) => - (red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall (Δ0 : list context_decl) (f0 : nat -> nat), - urenaming Δ0 (Γ ,,, fix_context L) f0 -> - red1 Σ Δ0 (rename f0 (dbody x)) (rename f0 (dbody y)))) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y) - ) - (fun L mfix0 mfix1 o => - OnOne2 - (fun x y : def term => - red1 Σ (Δ ,,, fix_context (map (map_def (rename f) (rename (shiftn #|L| f))) L)) (dbody x) (dbody y) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) - (map (map_def (rename f) (rename (shiftn #|L| f))) mfix0) - (map (map_def (rename f) (rename (shiftn #|L| f))) mfix1) - ) - _ _ - ). - + intros L x y l [[p1 p2] p3]. - inversion p3. - simpl. constructor. split. - * eapply p2. rewrite rename_fix_context. - rewrite <- fix_context_length. - eapply urenaming_context. - assumption. - * simpl. easy. - + intros L x l l' h ih. - simpl. constructor. eapply ih. - - simpl. - apply OnOne2_length in X as hl. rewrite <- hl. clear hl. - generalize #|mfix0|. intro n. - constructor. - induction X. - + destruct p as [[p1 p2] p3]. inversion p3. - simpl. constructor. split. - * eapply p2. assumption. - * simpl. f_equal ; auto. f_equal ; auto. - f_equal. assumption. - + simpl. constructor. eapply IHX. - - simpl. - apply OnOne2_length in X as hl. rewrite <- hl. clear hl. - eapply cofix_red_body. - Fail induction X using OnOne2_ind_l. - revert mfix0 mfix1 X. - refine ( - OnOne2_ind_l _ - (fun (L : mfixpoint term) (x y : def term) => - (red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall (Δ0 : list context_decl) (f0 : nat -> nat), - urenaming Δ0 (Γ ,,, fix_context L) f0 -> - red1 Σ Δ0 (rename f0 (dbody x)) (rename f0 (dbody y)))) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y) - ) - (fun L mfix0 mfix1 o => - OnOne2 - (fun x y : def term => - red1 Σ (Δ ,,, fix_context (map (map_def (rename f) (rename (shiftn #|L| f))) L)) (dbody x) (dbody y) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) - (map (map_def (rename f) (rename (shiftn #|L| f))) mfix0) - (map (map_def (rename f) (rename (shiftn #|L| f))) mfix1) - ) - _ _ - ). - + intros L x y l [[p1 p2] p3]. - inversion p3. - simpl. constructor. split. - * eapply p2. rewrite rename_fix_context. - rewrite <- fix_context_length. - eapply urenaming_context. - assumption. - * simpl. easy. - + intros L x l l' h ih. - simpl. constructor. eapply ih. -Qed. - -Lemma meta_conv : - forall Σ Γ t A B, - Σ ;;; Γ |- t : A -> - A = B -> - Σ ;;; Γ |- t : B. -Proof. - intros Σ Γ t A B h []. assumption. -Qed. - -Lemma meta_conv_term : - forall Σ Γ t t' A, - Σ ;;; Γ |- t : A -> - t = t' -> - Σ ;;; Γ |- t' : A. -Proof. - intros Σ Γ t A B h []. assumption. -Qed. - -(* Could be more precise *) -Lemma instantiate_params_subst_length : - forall params pars s t s' t', - instantiate_params_subst params pars s t = Some (s', t') -> - #|params| + #|s| = #|s'|. -Proof. - intros params pars s t s' t' h. - induction params in pars, s, t, s', t', h |- *. - - cbn in h. destruct pars. all: try discriminate. - inversion h. reflexivity. - - cbn in h. destruct (decl_body a). - + destruct t. all: try discriminate. - cbn. eapply IHparams in h. cbn in h. lia. - + destruct t. all: try discriminate. - destruct pars. 1: discriminate. - cbn. eapply IHparams in h. cbn in h. lia. -Qed. - -Lemma instantiate_params_subst_inst : - forall params pars s t σ s' t', - instantiate_params_subst params pars s t = Some (s', t') -> - instantiate_params_subst - (mapi_rec (fun i decl => inst_decl (⇑^i σ) decl) params #|s|) - (map (inst σ) pars) - (map (inst σ) s) - t.[⇑^#|s| σ] - = Some (map (inst σ) s', t'.[⇑^(#|s| + #|params|) σ]). -Proof. - intros params pars s t σ s' t' h. - induction params in pars, s, t, σ, s', t', h |- *. - - simpl in *. destruct pars. 2: discriminate. - simpl. inversion h. subst. clear h. - f_equal. f_equal. f_equal. f_equal. lia. - - simpl in *. destruct (decl_body a). - + simpl. destruct t. all: try discriminate. - simpl. eapply IHparams with (σ := σ) in h. - simpl in h. - replace (#|s| + S #|params|) - with (S (#|s| + #|params|)) - by lia. - rewrite <- h. f_equal. - * f_equal. autorewrite with sigma. - eapply inst_ext. intro i. - unfold Upn, subst_consn, subst_compose. - case_eq (nth_error s i). - -- intros t e. - rewrite nth_error_idsn_Some. - ++ eapply nth_error_Some_length. eassumption. - ++ simpl. - rewrite nth_error_map. rewrite e. simpl. - reflexivity. - -- intro neq. - rewrite nth_error_idsn_None. - ++ eapply nth_error_None. assumption. - ++ simpl. rewrite idsn_length. - autorewrite with sigma. - rewrite <- subst_ids. eapply inst_ext. intro j. - cbn. unfold ids. rewrite map_length. - replace (#|s| + j - #|s|) with j by lia. - rewrite nth_error_map. - erewrite (iffRL (nth_error_None _ _)) by lia. - simpl. reflexivity. - * autorewrite with sigma. reflexivity. - + simpl. destruct t. all: try discriminate. - simpl. destruct pars. 1: discriminate. - simpl. eapply IHparams with (σ := σ) in h. simpl in h. - replace (#|s| + S #|params|) - with (S (#|s| + #|params|)) - by lia. - rewrite <- h. - f_equal. autorewrite with sigma. reflexivity. -Qed. - -Lemma inst_decl_closed : - forall σ k d, - closed_decl k d -> - inst_decl (⇑^k σ) d = d. -Proof. - intros σ k d. - case: d => na [body|] ty. all: rewrite /closed_decl /inst_decl /map_decl /=. - - move /andb_and => [cb cty]. rewrite !inst_closed //. - - move => cty. rewrite !inst_closed //. -Qed. - -Lemma closed_tele_inst : - forall σ ctx, - closed_ctx ctx -> - mapi (fun i decl => inst_decl (⇑^i σ) decl) (List.rev ctx) = - List.rev ctx. -Proof. - intros σ ctx. - rewrite /closedn_ctx /mapi. simpl. generalize 0. - induction ctx using rev_ind; try easy. - move => n. - rewrite /closedn_ctx !rev_app_distr /id /=. - move /andb_and => [closedx Hctx]. - rewrite inst_decl_closed //. - f_equal. now rewrite IHctx. -Qed. - -Lemma instantiate_params_inst : - forall params pars T σ T', - closed_ctx params -> - instantiate_params params pars T = Some T' -> - instantiate_params params (map (inst σ) pars) T.[σ] = Some T'.[σ]. -Proof. - intros params pars T σ T' hcl e. - unfold instantiate_params in *. - case_eq (instantiate_params_subst (List.rev params) pars [] T) ; - try solve [ intro bot ; rewrite bot in e ; discriminate e ]. - intros [s' t'] e'. rewrite e' in e. inversion e. subst. clear e. - eapply instantiate_params_subst_inst with (σ := σ) in e'. - simpl in e'. - autorewrite with sigma in e'. - rewrite List.rev_length in e'. - match type of e' with - | context [ mapi_rec ?f ?l 0 ] => - change (mapi_rec f l 0) with (mapi f l) in e' - end. - rewrite closed_tele_inst in e' ; auto. - rewrite e'. f_equal. autorewrite with sigma. - eapply inst_ext. intro i. - unfold Upn, subst_consn, subst_compose. - rewrite idsn_length map_length. - apply instantiate_params_subst_length in e'. - rewrite List.rev_length map_length in e'. cbn in e'. - replace (#|params| + 0) with #|params| in e' by lia. - rewrite e'. clear e'. - case_eq (nth_error s' i). - - intros t e. - rewrite nth_error_idsn_Some. - { eapply nth_error_Some_length in e. lia. } - simpl. - rewrite nth_error_map. rewrite e. simpl. reflexivity. - - intro neq. - rewrite nth_error_idsn_None. - { eapply nth_error_None in neq. lia. } - simpl. autorewrite with sigma. rewrite <- subst_ids. - eapply inst_ext. intro j. - cbn. unfold ids. - replace (#|s'| + j - #|s'|) with j by lia. - rewrite nth_error_map. - erewrite (iffRL (nth_error_None _ _)) by lia. - simpl. reflexivity. -Qed. - -Corollary instantiate_params_rename : - forall params pars T f T', - closed_ctx params -> - instantiate_params params pars T = Some T' -> - instantiate_params params (map (rename f) pars) (rename f T) = - Some (rename f T'). -Proof. - intros params pars T f T' hcl e. - eapply instantiate_params_inst with (σ := ren f) in e. 2: auto. - autorewrite with sigma. rewrite <- e. f_equal. -Qed. - -Lemma build_branches_type_rename : - forall ind mdecl idecl args u p brs f, - closed_ctx (subst_instance_context u (ind_params mdecl)) -> - map_option_out (build_branches_type ind mdecl idecl args u p) = Some brs -> - map_option_out ( - build_branches_type - ind - mdecl - (map_one_inductive_body - (context_assumptions (ind_params mdecl)) - #|arities_context (ind_bodies mdecl)| - (fun i : nat => rename (shiftn i f)) - (inductive_ind ind) - idecl - ) - (map (rename f) args) - u - (rename f p) - ) = Some (map (on_snd (rename f)) brs). -Proof. - intros ind mdecl idecl args u p brs f hcl. - unfold build_branches_type. - destruct idecl as [ina ity ike ict ipr]. simpl. - unfold mapi. - generalize 0 at 3 6. - intros n h. - induction ict in brs, n, h, f |- *. - - cbn in *. inversion h. reflexivity. - - cbn. cbn in h. - lazymatch type of h with - | match ?t with _ => _ end = _ => - case_eq (t) ; - try (intro bot ; rewrite bot in h ; discriminate h) +Definition ren_fn (l : list nat) := + fun i => + match List.nth_error l i with + | None => (i - List.length l) + | Some t => t end. - intros [m t] e'. rewrite e' in h. - destruct a as [[na ta] ar]. - lazymatch type of e' with - | match ?expr with _ => _ end = _ => - case_eq (expr) ; - try (intro bot ; rewrite bot in e' ; discriminate e') - end. - intros ty ety. rewrite ety in e'. - eapply instantiate_params_rename with (f := f) in ety as ety'. - 2: assumption. - simpl. - match goal with - | |- context [ instantiate_params _ _ ?t ] => - match type of ety' with - | instantiate_params _ _ ?t' = _ => - replace t with t' ; revgoals - end - end. - { clear e' ety h IHict ety'. - rewrite <- rename_subst_instance_constr. - rewrite arities_context_length. - autorewrite with sigma. - eapply inst_ext. intro i. - unfold shiftn, ren, subst_compose, subst_consn. simpl. - case_eq (nth_error (inds (inductive_mind ind) u (ind_bodies mdecl)) i). - + intros t' e. - eapply nth_error_Some_length in e as hl. - rewrite inds_length in hl. - destruct (Nat.ltb_spec i #|ind_bodies mdecl|) ; try lia. - rewrite e. - give_up. - + intro neq. - eapply nth_error_None in neq as hl. - rewrite inds_length in hl. - rewrite inds_length. - destruct (Nat.ltb_spec i #|ind_bodies mdecl|) ; try lia. - unfold ids. simpl. - rewrite (iffRL (nth_error_None _ _)). - { rewrite inds_length. lia. } - f_equal. lia. - } - rewrite ety'. - case_eq (decompose_prod_assum [] ty). intros sign ccl edty. - rewrite edty in e'. - (* TODO inst edty *) - case_eq (chop (ind_npars mdecl) (snd (decompose_app ccl))). - intros paramrels args' ech. rewrite ech in e'. - (* TODO inst ech *) - inversion e'. subst. clear e'. - lazymatch type of h with - | match ?t with _ => _ end = _ => - case_eq (t) ; - try (intro bot ; rewrite bot in h ; discriminate h) + +Definition subst_fn (l : list term) := + fun i => + match List.nth_error l i with + | None => tRel (i - List.length l) + | Some t => t end. - intros tl etl. rewrite etl in h. - (* TODO inst etl *) - inversion h. subst. clear h. - (* edestruct IHict as [brtys' [eq' he]]. *) - (* + eauto. *) - (* + eexists. rewrite eq'. split. *) - (* * reflexivity. *) - (* * constructor ; auto. *) - (* simpl. split ; auto. *) - (* eapply eq_term_upto_univ_it_mkProd_or_LetIn ; auto. *) - (* eapply eq_term_upto_univ_mkApps. *) - (* -- eapply eq_term_upto_univ_lift. assumption. *) - (* -- apply All2_same. intro. apply eq_term_upto_univ_refl ; auto. *) -Admitted. - -Lemma typed_inst : - forall Σ Γ t T k σ, - wf Σ.1 -> - k >= #|Γ| -> - Σ ;;; Γ |- t : T -> - T.[⇑^k σ] = T /\ t.[⇑^k σ] = t. -Proof. - intros Σ Γ t T k σ hΣ hk h. - apply typing_wf_local in h as hΓ. - apply typecheck_closed in h. all: eauto. - destruct h as [_ hcl]. - rewrite -> andb_and in hcl. destruct hcl as [clt clT]. - pose proof (closed_upwards k clt) as ht. - pose proof (closed_upwards k clT) as hT. - forward ht by lia. - forward hT by lia. - rewrite !inst_closed. all: auto. -Qed. - -Lemma inst_wf_local : - forall Σ Γ σ, - wf Σ.1 -> - wf_local Σ Γ -> - inst_context σ Γ = Γ. -Proof. - intros Σ Γ σ hΣ h. - induction h. - - reflexivity. - - unfold inst_context, snoc. rewrite fold_context_snoc0. - unfold snoc. f_equal. all: auto. - unfold map_decl. simpl. unfold vass. f_equal. - destruct t0 as [s ht]. eapply typed_inst. all: eauto. - - unfold inst_context, snoc. rewrite fold_context_snoc0. - unfold snoc. f_equal. all: auto. - unfold map_decl. simpl. unfold vdef. f_equal. - + f_equal. eapply typed_inst. all: eauto. - + eapply typed_inst in t1 as [? _]. all: eauto. -Qed. - -Definition inst_mutual_inductive_body σ m := - map_mutual_inductive_body (fun i => inst (⇑^i σ)) m. - -Lemma inst_declared_minductive : - forall Σ cst decl σ, - wf Σ -> - declared_minductive Σ cst decl -> - inst_mutual_inductive_body σ decl = decl. -Proof. -Admitted. -(* - unfold declared_minductive. - intros Σ cst decl σ hΣ h. - eapply lookup_on_global_env in h ; eauto. simpl in h. - destruct h as [Σ' [hΣ' decl']]. - destruct decl as [fi npars params bodies univs]. simpl. f_equal. - - eapply inst_wf_local. all: eauto. - eapply onParams in decl'. auto. - - apply onInductives in decl'. - revert decl'. generalize bodies at 2 4 5. intros bodies' decl'. - eapply Alli_mapi_id in decl'. all: eauto. - clear decl'. intros n [na ty ke ct pr] hb. simpl. - destruct (decompose_prod_assum [] ty) as [c t] eqn:e1. - destruct (decompose_prod_assum [] ty.[⇑^0 σ]) as [c' t'] eqn:e2. - destruct hb as [indices s arity_eq onAr csorts onConstr onProj sorts]. - simpl in *. - assert (e : ty.[⇑^0 σ] = ty). - { destruct onAr as [s' h']. - eapply typed_inst in h' as [_ ?]. all: eauto. - } - rewrite e in e2. rewrite e1 in e2. - revert e2. intros [= <- <-]. - rewrite e. f_equal. - + eapply All_map_id. eapply All2_All_left; tea. - intros [[x p] n'] y [[?s Hty] [cs Hargs]]. - unfold on_pi2; cbn; f_equal; f_equal. - eapply typed_inst. all: eauto. - + destruct (eq_dec pr []) as [hp | hp]. all: subst. all: auto. - specialize (onProj hp). - apply on_projs in onProj. - apply (Alli_map_id onProj). - intros n1 [x p]. unfold on_projection. simpl. - intros [? hty]. - unfold on_snd. simpl. f_equal. - eapply typed_inst. all: eauto. - simpl. - rewrite smash_context_length context_assumptions_fold. - simpl. auto. -Qed.*) - -Lemma inst_declared_inductive : - forall Σ ind mdecl idecl σ, - wf Σ -> - declared_inductive Σ mdecl ind idecl -> - map_one_inductive_body - (context_assumptions mdecl.(ind_params)) - #|arities_context mdecl.(ind_bodies)| - (fun i => inst (⇑^i σ)) - ind.(inductive_ind) - idecl - = idecl. -Proof. - intros Σ ind mdecl idecl σ hΣ [hmdecl hidecl]. - eapply inst_declared_minductive with (σ := σ) in hmdecl. all: auto. - unfold inst_mutual_inductive_body in hmdecl. - destruct mdecl as [fi npars params bodies univs]. simpl in *. - injection hmdecl. intro e. clear hmdecl. - pose proof hidecl as hidecl'. - rewrite <- e in hidecl'. - rewrite nth_error_mapi in hidecl'. - clear e. - unfold option_map in hidecl'. rewrite hidecl in hidecl'. - congruence. -Qed. - -Lemma inst_destArity : - forall ctx t σ args s, - destArity ctx t = Some (args, s) -> - destArity (inst_context σ ctx) t.[⇑^#|ctx| σ] = - Some (inst_context σ args, s). -Proof. - intros ctx t σ args s h. - induction t in ctx, σ, args, s, h |- * using term_forall_list_ind. - all: simpl in *. all: try discriminate. - - inversion h. reflexivity. - - erewrite <- IHt2 ; try eassumption. - simpl. autorewrite with sigma. reflexivity. - - erewrite <- IHt3. all: try eassumption. - simpl. autorewrite with sigma. reflexivity. -Qed. - - -(* Lemma types_of_case_rename : *) -(* forall Σ ind mdecl idecl npar args u p pty indctx pctx ps btys f, *) -(* wf Σ -> *) -(* declared_inductive Σ mdecl ind idecl -> *) -(* types_of_case ind mdecl idecl (firstn npar args) u p pty = *) -(* Some (indctx, pctx, ps, btys) -> *) -(* types_of_case *) -(* ind mdecl idecl *) -(* (firstn npar (map (rename f) args)) u (rename f p) (rename f pty) *) -(* = *) -(* Some ( *) -(* rename_context f indctx, *) -(* rename_context f pctx, *) -(* ps, *) -(* map (on_snd (rename f)) btys *) -(* ). *) -(* Proof. *) -(* intros Σ ind mdecl idecl npar args u p pty indctx pctx ps btys f hΣ hdecl h. *) -(* unfold types_of_case in *. *) -(* case_eq (instantiate_params (subst_instance_context u (ind_params mdecl)) (firstn npar args) (subst_instance_constr u (ind_type idecl))) ; *) -(* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) -(* intros ity eity. rewrite eity in h. *) -(* pose proof (on_declared_inductive hΣ hdecl) as [onmind onind]. *) -(* apply onParams in onmind as Hparams. *) -(* assert (closedparams : closed_ctx (subst_instance_context u (ind_params mdecl))). *) -(* { rewrite closedn_subst_instance_context. *) -(* eapply PCUICWeakening.closed_wf_local. all: eauto. eauto. } *) -(* epose proof (inst_declared_inductive _ ind mdecl idecl (ren f) hΣ) as hi. *) -(* forward hi by assumption. rewrite <- hi. *) -(* eapply instantiate_params_rename with (f := f) in eity ; auto. *) -(* rewrite -> ind_type_map. *) -(* rewrite firstn_map. *) -(* lazymatch type of eity with *) -(* | ?t = _ => *) -(* lazymatch goal with *) -(* | |- match ?t' with _ => _ end = _ => *) -(* replace t' with t ; revgoals *) -(* end *) -(* end. *) -(* { autorewrite with sigma. *) -(* rewrite <- !rename_inst. *) -(* now rewrite rename_subst_instance_constr. } *) -(* rewrite eity. *) -(* case_eq (destArity [] ity) ; *) -(* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) -(* intros [args0 ?] ear. rewrite ear in h. *) -(* eapply inst_destArity with (σ := ren f) in ear as ear'. *) -(* simpl in ear'. *) -(* lazymatch type of ear' with *) -(* | ?t = _ => *) -(* lazymatch goal with *) -(* | |- match ?t' with _ => _ end = _ => *) -(* replace t' with t ; revgoals *) -(* end *) -(* end. *) -(* { autorewrite with sigma. reflexivity. } *) -(* rewrite ear'. *) -(* case_eq (destArity [] pty) ; *) -(* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) -(* intros [args' s'] epty. rewrite epty in h. *) -(* eapply inst_destArity with (σ := ren f) in epty as epty'. *) -(* simpl in epty'. *) -(* lazymatch type of epty' with *) -(* | ?t = _ => *) -(* lazymatch goal with *) -(* | |- match ?t' with _ => _ end = _ => *) -(* replace t' with t ; revgoals *) -(* end *) -(* end. *) -(* { autorewrite with sigma. reflexivity. } *) -(* rewrite epty'. *) -(* case_eq (map_option_out (build_branches_type ind mdecl idecl (firstn npar args) u p)) ; *) -(* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) -(* intros brtys ebrtys. rewrite ebrtys in h. *) -(* inversion h. subst. clear h. *) -(* eapply build_branches_type_rename with (f := f) in ebrtys as ebrtys'. *) -(* 2: assumption. *) -(* lazymatch type of ebrtys' with *) -(* | ?t = _ => *) -(* lazymatch goal with *) -(* | |- match ?t' with _ => _ end = _ => *) -(* replace t' with t ; revgoals *) -(* end *) -(* end. *) -(* { f_equal. f_equal. unfold map_one_inductive_body. destruct idecl. *) -(* simpl. f_equal. *) -(* - autorewrite with sigma. *) -(* eapply inst_ext. intro j. *) -(* unfold ren, shiftn. simpl. *) -(* f_equal. f_equal. lia. *) -(* - clear. induction ind_ctors. 1: reflexivity. *) -(* simpl. unfold on_pi2. destruct a. simpl. *) -(* destruct p. simpl. f_equal. 2: easy. *) -(* f_equal. f_equal. *) -(* autorewrite with sigma. *) -(* eapply inst_ext. intro j. *) -(* unfold ren, Upn, shiftn, subst_consn. *) -(* rewrite arities_context_length. *) -(* destruct (Nat.ltb_spec j #|ind_bodies mdecl|). *) -(* + rewrite nth_error_idsn_Some. all: easy. *) -(* + rewrite nth_error_idsn_None. 1: auto. *) -(* unfold subst_compose, shiftk. simpl. *) -(* rewrite idsn_length. reflexivity. *) -(* - clear. induction ind_projs. 1: auto. *) -(* simpl. destruct a. unfold on_snd. simpl. *) -(* f_equal. 2: easy. *) -(* f_equal. autorewrite with sigma. *) -(* eapply inst_ext. intro j. *) -(* unfold Upn, Up, ren, shiftn, subst_cons, subst_consn, subst_compose, *) -(* shift, shiftk. *) -(* destruct j. *) -(* + simpl. reflexivity. *) -(* + simpl. *) -(* destruct (Nat.ltb_spec (S j) (S (context_assumptions (ind_params mdecl)))). *) -(* * rewrite nth_error_idsn_Some. 1: lia. *) -(* simpl. reflexivity. *) -(* * rewrite nth_error_idsn_None. 1: lia. *) -(* simpl. rewrite idsn_length. reflexivity. *) -(* } *) -(* rewrite ebrtys'. autorewrite with sigma. reflexivity. *) -(* Qed. *) - -(* TODO UPDATE We need to add rename_stack *) -Lemma cumul_rename : - forall Σ Γ Δ f A B, - wf Σ.1 -> - urenaming Δ Γ f -> - Σ ;;; Γ |- A <= B -> - Σ ;;; Δ |- rename f A <= rename f B. -Proof. - intros Σ Γ Δ f A B hΣ hf h. - induction h. - - eapply cumul_refl. eapply eq_term_upto_univ_rename. assumption. - - eapply cumul_red_l. - + eapply red1_rename. all: try eassumption. - + assumption. - - eapply cumul_red_r. - + eassumption. - + eapply red1_rename. all: try eassumption. -Qed. - -Lemma fix_guard_rename Σ Γ Δ mfix f : - renaming Σ Γ Δ f -> - let mfix' := map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in - fix_guard Σ Δ mfix -> - fix_guard Σ Γ mfix'. -Admitted. - -Lemma cofix_guard_rename Σ Γ Δ mfix f : - renaming Σ Γ Δ f -> - let mfix' := map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in - cofix_guard Σ Δ mfix -> - cofix_guard Σ Γ mfix'. -Admitted. - -Lemma typing_rename_prop : env_prop - (fun Σ Γ t A => - forall Δ f, - renaming Σ Δ Γ f -> - Σ ;;; Δ |- rename f t : rename f A) - (fun Σ Γ _ => - forall Δ f, - renaming Σ Δ Γ f -> - wf_local Σ Δ). -Proof. - apply typing_ind_env. - - now intros Σ wfΣ Γ wfΓ HΓ Δ f [hΔ hf]. - - - intros Σ wfΣ Γ wfΓ n decl isdecl ihΓ Δ f [hΔ hf]. - simpl. eapply hf in isdecl as h. - destruct h as [decl' [isdecl' [h1 h2]]]. - rewrite h1. econstructor. all: auto. - - intros Σ wfΣ Γ wfΓ l X H0 Δ f [hΔ hf]. - simpl. constructor. all: auto. - - intros Σ wfΣ Γ wfΓ na A B s1 s2 X hA ihA hB ihB Δ f hf. - simpl. - econstructor. - + eapply ihA. assumption. - + eapply ihB. - eapply renaming_vass. 2: auto. - constructor. - * destruct hf as [hΔ hf]. auto. - * simpl. exists s1. eapply ihA. assumption. - - intros Σ wfΣ Γ wfΓ na A t s1 B X hA ihA ht iht Δ f hf. - simpl. econstructor. - + eapply ihA. assumption. - + eapply iht. - eapply renaming_vass. 2: auto. - constructor. - * destruct hf as [hΔ hf]. auto. - * simpl. exists s1. eapply ihA. assumption. - - intros Σ wfΣ Γ wfΓ na b B t s1 A X hB ihB hb ihb ht iht Δ f hf. - simpl. econstructor. - + eapply ihB. assumption. - + eapply ihb. assumption. - + eapply iht. - eapply renaming_vdef. 2: auto. - constructor. - * destruct hf. assumption. - * simpl. eexists. eapply ihB. assumption. - * simpl. eapply ihb. assumption. - - intros Σ wfΣ Γ wfΓ t na A B s u X hty ihty ht iht hu ihu Δ f hf. - simpl. eapply meta_conv. - + eapply type_App. - * simpl in ihty. eapply ihty; eassumption. - * simpl in iht. eapply iht. assumption. - * eapply ihu. assumption. - + autorewrite with sigma. rewrite !subst1_inst. sigma. - eapply inst_ext. intro i. - unfold subst_cons, ren, shiftn, subst_compose. simpl. - destruct i. - * simpl. reflexivity. - * simpl. replace (i - 0) with i by lia. - reflexivity. - - intros Σ wfΣ Γ wfΓ cst u decl X X0 isdecl hconst Δ f hf. - simpl. eapply meta_conv. - + constructor. all: eauto. - + rewrite rename_subst_instance_constr. f_equal. - rewrite rename_closed. 2: auto. - eapply declared_constant_closed_type. all: eauto. - - intros Σ wfΣ Γ wfΓ ind u mdecl idecl isdecl X X0 hconst Δ σ hf. - simpl. eapply meta_conv. - + econstructor. all: eauto. - + rewrite rename_subst_instance_constr. f_equal. - rewrite rename_closed. 2: auto. - eapply declared_inductive_closed_type. all: eauto. - - intros Σ wfΣ Γ wfΓ ind i u mdecl idecl cdecl isdecl X X0 hconst Δ f hf. - simpl. eapply meta_conv. - + econstructor. all: eauto. - + rewrite rename_closed. 2: reflexivity. - eapply declared_constructor_closed_type. all: eauto. - - intros Σ wfΣ Γ wfΓ ind u npar p c brs args mdecl idecl isdecl X X0 e - pars ps pty H1 X1 X2 H0 X3 X4 btys H2 X5 Δ f X6. - simpl. - rewrite rename_mkApps. - rewrite map_app. simpl. - rewrite map_skipn. - (* eapply types_of_case_inst with (σ := σ) in htoc. all: try eassumption. *) - (* eapply type_Case. *) - (* + eassumption. *) - (* + assumption. *) - (* + eapply ihp. all: auto. *) - (* + eassumption. *) - (* + admit. *) - (* + assumption. *) - (* + specialize (ihc _ _ hΔ hσ). autorewrite with sigma in ihc. *) - (* eapply ihc. *) - (* + admit. *) - admit. - - intros Σ wfΣ Γ wfΓ p c u mdecl idecl pdecl isdecl args X X0 hc ihc e ty - Δ f hf. - simpl. eapply meta_conv. - + econstructor. - * eassumption. - * eapply meta_conv. - -- eapply ihc. assumption. - -- rewrite rename_mkApps. simpl. reflexivity. - * rewrite map_length. assumption. - + rewrite rename_subst0. simpl. rewrite map_rev. f_equal. - rewrite rename_subst_instance_constr. f_equal. - rewrite rename_closedn. 2: reflexivity. - eapply declared_projection_closed_type in isdecl. 2: auto. - rewrite List.rev_length. rewrite e. assumption. - - - intros Σ wfΣ Γ wfΓ mfix n decl types H1 hdecl X ihmfixt ihmfixb wffix Δ f hf. - assert (hΔ' : wf_local Σ (Δ ,,, rename_context f (fix_context mfix))). - { rewrite - rename_fix_context. - apply PCUICWeakening.All_mfix_wf; auto; try apply hf. - eapply All_map, (All_impl ihmfixt). - intros x [s Hs]; exists s; intuition auto. - simpl. apply (b _ _ hf). } - - simpl. eapply meta_conv. - + eapply type_Fix. - * eapply fix_guard_rename; eauto. - * rewrite nth_error_map. rewrite hdecl. simpl. reflexivity. - * apply hf. - * apply All_map, (All_impl ihmfixt). - intros x [s [Hs IHs]]. - exists s. now apply IHs. - * apply All_map, (All_impl ihmfixb). - intros x [Hb IHb]. - destruct x as [na ty bo rarg]. simpl in *. - rewrite rename_fix_context. - eapply meta_conv. - ++ apply (IHb (Δ ,,, rename_context f types) (shiftn #|mfix| f)). - split; auto. subst types. rewrite -(fix_context_length mfix). - apply urenaming_context; auto. apply hf. - ++ autorewrite with sigma. subst types. rewrite fix_context_length. - now rewrite -ren_shiftn up_Upn shiftn_consn_idsn. - * admit (* wf_fixpoint renaming *). - + reflexivity. - - - intros Σ wfΣ Γ wfΓ mfix n decl types guard hdecl X ihmfixt ihmfixb wfcofix Δ f hf. - assert (hΔ' : wf_local Σ (Δ ,,, rename_context f (fix_context mfix))). - { rewrite -rename_fix_context. - apply PCUICWeakening.All_mfix_wf; auto; try apply hf. - eapply All_map, (All_impl ihmfixt). - intros x [s Hs]; exists s; intuition auto. - simpl. apply (b _ _ hf). } - simpl. eapply meta_conv. - + eapply type_CoFix; auto. - * eapply cofix_guard_rename; eauto. - * rewrite nth_error_map. rewrite hdecl. simpl. reflexivity. - * apply hf. - * apply All_map, (All_impl ihmfixt). - intros x [s [Hs IHs]]. - exists s. now apply IHs. - * apply All_map, (All_impl ihmfixb). - intros x [Hb IHb]. - destruct x as [na ty bo rarg]. simpl in *. - rewrite rename_fix_context. - eapply meta_conv. - ++ apply (IHb (Δ ,,, rename_context f types) (shiftn #|mfix| f)). - split; auto. subst types. rewrite -(fix_context_length mfix). - apply urenaming_context; auto. apply hf. - ++ autorewrite with sigma. subst types. rewrite fix_context_length. - now rewrite -ren_shiftn up_Upn shiftn_consn_idsn. - * admit. - + reflexivity. - - - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht htB ihB cum Δ f hf. - eapply type_Cumul. - + eapply iht. assumption. - + eapply ihB. assumption. - + eapply cumul_rename. all: try eassumption. - apply hf. -Admitted. - -Lemma typing_rename : - forall Σ Γ Δ f t A, - wf Σ.1 -> - renaming Σ Δ Γ f -> - Σ ;;; Γ |- t : A -> - Σ ;;; Δ |- rename f t : rename f A. -Proof. -Admitted. - (* intros Σ Γ Δ f t A hΣ hf h. - revert Σ hΣ Γ t A h Δ f hf. - apply typing_rename_prop. -Qed. *) -End Renaming. - -Section Sigma. - -Context `{checker_flags}. - -(* Well-typedness of a substitution *) - -Definition well_subst Σ (Γ : context) σ (Δ : context) := - forall x decl, - nth_error Γ x = Some decl -> - Σ ;;; Δ |- σ x : ((lift0 (S x)) (decl_type decl)).[ σ ] × - (forall b, - decl.(decl_body) = Some b -> - σ x = b.[⇑^(S x) σ] - ). - -Notation "Σ ;;; Δ ⊢ σ : Γ" := - (well_subst Σ Γ σ Δ) (at level 50, Δ, σ, Γ at next level). - -Lemma well_subst_Up : - forall Σ Γ Δ σ na A, - wf_local Σ (Δ ,, vass na A.[σ]) -> - Σ ;;; Δ ⊢ σ : Γ -> - Σ ;;; Δ ,, vass na A.[σ] ⊢ ⇑ σ : Γ ,, vass na A. -Proof. - intros Σ Γ Δ σ na A hΔ h [|n] decl e. - - simpl in *. inversion e. subst. clear e. simpl. - split. - + eapply meta_conv. - * econstructor ; auto. - reflexivity. - * simpl. - autorewrite with sigma. - eapply inst_ext. intro i. - unfold subst_compose. - eapply inst_ext. intro j. - unfold shift, ren. reflexivity. - + intros b e. discriminate. - - simpl in *. - specialize (h _ _ e) as [h1 h2]. - split. -Admitted. - -Lemma well_subst_Up' : - forall Σ Γ Δ σ na t A, - wf_local Σ (Δ ,, vdef na t.[σ] A.[σ]) -> - Σ ;;; Δ ⊢ σ : Γ -> - Σ ;;; Δ ,, vdef na t.[σ] A.[σ] ⊢ ⇑ σ : Γ ,, vdef na t A. -Proof. - intros Σ Γ Δ σ na t A wf h [|n] decl e. - - simpl in *. inversion e. subst. clear e. simpl. - rewrite lift_rename. rewrite rename_inst. - autorewrite with sigma. - split. - + eapply meta_conv. - * econstructor; auto; reflexivity. - * rewrite lift0_inst /=. - now autorewrite with sigma. - + intros b [= ->]. - (* well-subst is ill-definied it should allow let-preservation *) - admit. - - - simpl in *. - specialize (h _ _ e). -Admitted. - -(* (* Could be more precise *) *) -(* Lemma instantiate_params_subst_length : *) -(* forall params pars s t s' t', *) -(* instantiate_params_subst params pars s t = Some (s', t') -> *) -(* #|params| >= #|pars|. *) -(* Proof. *) -(* intros params pars s t s' t' h. *) -(* induction params in pars, s, t, s', t', h |- *. *) -(* - cbn in h. destruct pars. all: try discriminate. auto. *) -(* - cbn in h. destruct (decl_body a). *) -(* + destruct t. all: try discriminate. *) -(* cbn. eapply IHparams in h. lia. *) -(* + destruct t. all: try discriminate. *) -(* destruct pars. 1: discriminate. *) -(* cbn. eapply IHparams in h. lia. *) -(* Qed. *) - -(* Lemma instantiate_params_length : *) -(* forall params pars T T', *) -(* instantiate_params params pars T = Some T' -> *) -(* #|params| >= #|pars|. *) -(* Proof. *) -(* intros params pars T T' e. *) -(* unfold instantiate_params in e. *) -(* case_eq (instantiate_params_subst (List.rev params) pars [] T) ; *) -(* try solve [ intro bot ; rewrite bot in e ; discriminate e ]. *) -(* intros [s' t'] e'. rewrite e' in e. inversion e. subst. clear e. *) -(* eapply instantiate_params_subst_length in e'. *) -(* rewrite List.rev_length in e'. assumption. *) -(* Qed. *) - -Lemma shift_subst_instance_constr : - forall u t k, - (subst_instance_constr u t).[⇑^k ↑] = subst_instance_constr u t.[⇑^k ↑]. +Lemma up_ext k s s' : s =1 s' -> up k s =1 up k s'. Proof. - intros u t k. - induction t in k |- * using term_forall_list_ind. - all: simpl. all: auto. - all: autorewrite with sigma. - all: rewrite ?map_map_compose ?compose_on_snd ?compose_map_def ?map_lenght. - all: try solve [ f_equal ; eauto ; solve_all ; eauto ]. - - unfold Upn, shift, subst_compose, subst_consn. - destruct (Nat.ltb_spec0 n k). - + rewrite nth_error_idsn_Some. 1: assumption. - reflexivity. - + rewrite nth_error_idsn_None. 1: lia. - reflexivity. - - rewrite IHt1. specialize (IHt2 (S k)). autorewrite with sigma in IHt2. - rewrite IHt2. reflexivity. - - rewrite IHt1. specialize (IHt2 (S k)). autorewrite with sigma in IHt2. - rewrite IHt2. reflexivity. - - rewrite IHt1 IHt2. specialize (IHt3 (S k)). autorewrite with sigma in IHt3. - rewrite IHt3. reflexivity. - - f_equal. - autorewrite with len. - red in X. - eapply All_map_eq. eapply (All_impl X). - intros x [IH IH']. - apply map_def_eq_spec. - * apply IH. - * specialize (IH' (#|m| + k)). - autorewrite with sigma. - now rewrite - !up_Upn up_up !up_Upn. - - f_equal. - autorewrite with len. - red in X. - eapply All_map_eq. eapply (All_impl X). - intros x [IH IH']. - apply map_def_eq_spec. - * apply IH. - * specialize (IH' (#|m| + k)). - autorewrite with sigma. - now rewrite - !up_Upn up_up !up_Upn. + unfold up. intros Hs t. elim (Nat.leb_spec k t) => H; auto. + f_equal. apply Hs. Qed. -Lemma inst_subst_instance_constr : - forall u t σ, - (subst_instance_constr u t).[(subst_instance_constr u ∘ σ)%prog] = - subst_instance_constr u t.[σ]. +Instance up_proper : Proper (Logic.eq ==> `=1` ==> `=1`) up. Proof. - intros u t σ. - induction t in σ |- * using term_forall_list_ind. - all: simpl. all: auto. - all: autorewrite with sigma. - all: rewrite ?map_map_compose ?compose_on_snd ?compose_map_def ?map_lenght. - all: try solve [ f_equal ; eauto ; solve_all ; eauto ]. - - rewrite IHt1. f_equal. rewrite <- IHt2. - eapply inst_ext. intro i. - unfold Up, subst_compose, subst_cons. - destruct i. - + reflexivity. - + pose proof (shift_subst_instance_constr u (σ i) 0) as e. - autorewrite with sigma in e. rewrite e. reflexivity. - - f_equal;auto. -Admitted. - -Lemma build_branches_type_inst : - forall ind mdecl idecl args u p brs σ, - closed_ctx (subst_instance_context u (ind_params mdecl)) -> - map_option_out (build_branches_type ind mdecl idecl args u p) = Some brs -> - map_option_out ( - build_branches_type - ind - mdecl - (map_one_inductive_body - (context_assumptions (ind_params mdecl)) - #|arities_context (ind_bodies mdecl)| - (fun i : nat => inst (⇑^i σ)) - (inductive_ind ind) - idecl - ) - (map (inst σ) args) - u - p.[σ] - ) = Some (map (on_snd (inst σ)) brs). -Proof. - intros ind mdecl idecl args u p brs σ hcl. - unfold build_branches_type. - destruct idecl as [ina ity ike ict ipr]. simpl. - unfold mapi. - generalize 0 at 3 6. - intros n h. - induction ict in brs, n, h, σ |- *. - - cbn in *. inversion h. reflexivity. - - cbn. cbn in h. - lazymatch type of h with - | match ?t with _ => _ end = _ => - case_eq (t) ; - try (intro bot ; rewrite bot in h ; discriminate h) - end. - intros [m t] e'. rewrite e' in h. - destruct a as [[na ta] ar]. - lazymatch type of e' with - | match ?expr with _ => _ end = _ => - case_eq (expr) ; - try (intro bot ; rewrite bot in e' ; discriminate e') - end. - intros ty ety. rewrite ety in e'. - eapply instantiate_params_inst with (σ := σ) in ety as ety'. 2: assumption. - autorewrite with sigma. simpl. - autorewrite with sigma in ety'. - rewrite <- inst_subst_instance_constr. - autorewrite with sigma. - match goal with - | |- context [ instantiate_params _ _ ?t.[?σ] ] => - match type of ety' with - | instantiate_params _ _ ?t'.[?σ'] = _ => - replace t.[σ] with t'.[σ'] ; revgoals - end - end. - { eapply inst_ext. intro i. - unfold Upn, subst_compose, subst_consn. - rewrite arities_context_length. - case_eq (nth_error (inds (inductive_mind ind) u (ind_bodies mdecl)) i). - - intros t' e. - rewrite nth_error_idsn_Some. - { eapply nth_error_Some_length in e. - rewrite inds_length in e. assumption. - } - simpl. rewrite e. - give_up. - - intro neq. simpl. rewrite inds_length idsn_length. - rewrite nth_error_idsn_None. - { eapply nth_error_None in neq. rewrite inds_length in neq. lia. } - give_up. - } - rewrite ety'. - case_eq (decompose_prod_assum [] ty). intros sign ccl edty. - rewrite edty in e'. - (* TODO inst edty *) - case_eq (chop (ind_npars mdecl) (snd (decompose_app ccl))). - intros paramrels args' ech. rewrite ech in e'. - (* TODO inst ech *) - inversion e'. subst. clear e'. - lazymatch type of h with - | match ?t with _ => _ end = _ => - case_eq (t) ; - try (intro bot ; rewrite bot in h ; discriminate h) - end. - intros tl etl. rewrite etl in h. - (* TODO inst etl *) - inversion h. subst. clear h. - (* edestruct IHict as [brtys' [eq' he]]. *) - (* + eauto. *) - (* + eexists. rewrite eq'. split. *) - (* * reflexivity. *) - (* * constructor ; auto. *) - (* simpl. split ; auto. *) - (* eapply eq_term_upto_univ_it_mkProd_or_LetIn ; auto. *) - (* eapply eq_term_upto_univ_mkApps. *) - (* -- eapply eq_term_upto_univ_lift. assumption. *) - (* -- apply All2_same. intro. apply eq_term_upto_univ_refl ; auto. *) -Admitted. - -(* Lemma types_of_case_inst : *) -(* forall Σ ind mdecl idecl npar args u p pty indctx pctx ps btys σ, *) -(* wf Σ -> *) -(* declared_inductive Σ mdecl ind idecl -> *) -(* types_of_case ind mdecl idecl (firstn npar args) u p pty = *) -(* Some (indctx, pctx, ps, btys) -> *) -(* types_of_case ind mdecl idecl (firstn npar (map (inst σ) args)) u p.[σ] pty.[σ] = *) -(* Some (inst_context σ indctx, inst_context σ pctx, ps, map (on_snd (inst σ)) btys). *) -(* Proof. *) -(* intros Σ ind mdecl idecl npar args u p pty indctx pctx ps btys σ hΣ hdecl h. *) -(* unfold types_of_case in *. *) -(* case_eq (instantiate_params (subst_instance_context u (ind_params mdecl)) (firstn npar args) (subst_instance_constr u (ind_type idecl))) ; *) -(* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) -(* intros ity eity. rewrite eity in h. *) -(* pose proof (on_declared_inductive hΣ hdecl) as [onmind onind]. *) -(* apply onParams in onmind as Hparams. *) -(* assert (closedparams : closed_ctx (subst_instance_context u (ind_params mdecl))). *) -(* { rewrite closedn_subst_instance_context. *) -(* eapply PCUICWeakening.closed_wf_local. all: eauto. eauto. } *) -(* epose proof (inst_declared_inductive _ ind mdecl idecl σ hΣ) as hi. *) -(* forward hi by assumption. rewrite <- hi. *) -(* eapply instantiate_params_inst with (σ := σ) in eity ; auto. *) -(* rewrite -> ind_type_map. *) -(* rewrite firstn_map. *) -(* autorewrite with sigma. *) -(* (* rewrite eity. *) *) -(* (* case_eq (destArity [] ity) ; *) *) -(* (* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) *) -(* (* intros [args0 ?] ear. rewrite ear in h. *) *) -(* (* eapply inst_destArity with (σ := σ) in ear as ear'. *) *) -(* (* simpl in ear'. autorewrite with sigma in ear'. *) *) -(* (* rewrite ear'. *) *) -(* (* case_eq (destArity [] pty) ; *) *) -(* (* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) *) -(* (* intros [args' s'] epty. rewrite epty in h. *) *) -(* (* eapply inst_destArity with (σ := σ) in epty as epty'. *) *) -(* (* simpl in epty'. autorewrite with sigma in epty'. *) *) -(* (* rewrite epty'. *) *) -(* (* case_eq (map_option_out (build_branches_type ind mdecl idecl (firstn npar args) u p)) ; *) *) -(* (* try solve [ intro bot ; rewrite bot in h ; discriminate h ]. *) *) -(* (* intros brtys ebrtys. rewrite ebrtys in h. *) *) -(* (* inversion h. subst. clear h. *) *) -(* (* eapply build_branches_type_inst with (σ := σ) in ebrtys as ebrtys'. *) *) -(* (* 2: assumption. *) *) -(* (* rewrite ebrtys'. reflexivity. *) *) -(* (* Qed. *) *) -(* Admitted. *) + intros k y <- f g. apply up_ext. +Qed. +Lemma inst_ext s s' : s =1 s' -> inst s =1 inst s'. +Proof. + intros Hs t. revert s s' Hs. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all; eauto using up_ext]. + - f_equal; solve_all. + * eapply map_predicate_shift_eq_spec; solve_all; eauto using up_ext. + * apply map_branch_shift_eq_spec; solve_all; eauto using up_ext. +Qed. -Lemma subst_consn_compose l σ' σ : l ⋅n σ' ∘s σ =1 (map (inst σ) l ⋅n (σ' ∘s σ)). +Instance proper_inst : Proper (`=1` ==> Logic.eq ==> Logic.eq) inst. Proof. - induction l; simpl. - - now sigma. - - rewrite subst_consn_subst_cons. sigma. - rewrite IHl. now rewrite subst_consn_subst_cons. + intros f f' Hff' t t' ->. now apply inst_ext. Qed. -Lemma map_idsn_spec (f : term -> term) (n : nat) : - map f (idsn n) = Nat.recursion [] (fun x l => l ++ [f (tRel x)]) n. +Instance proper_inst' : Proper (`=1` ==> `=1`) inst. Proof. - induction n; simpl. - - reflexivity. - - simpl. rewrite map_app. now rewrite -IHn. + intros f f' Hff' t. now apply inst_ext. Qed. -Lemma nat_recursion_ext {A} (x : A) f g n : - (forall x l', x < n -> f x l' = g x l') -> - Nat.recursion x f n = Nat.recursion x g n. +Instance up_proper' k : Proper (`=1` ==> `=1`) (up k). +Proof. reduce_goal. now apply up_ext. Qed. + +Instance inst_predicate_proper : Proper (`=1` ==> `=1`) inst_predicate. Proof. - intros. - generalize (le_refl n). - induction n at 1 3 4; simpl; auto. - intros. simpl. rewrite IHn0; try lia. now rewrite H0. + apply map_predicate_shift_proper; try tc. + now intros x. Qed. -Lemma id_nth_spec {A} (l : list A) : - l = Nat.recursion [] (fun x l' => - match nth_error l x with - | Some a => l' ++ [a] - | None => l' - end) #|l|. +Instance inst_branch_proper : Proper (`=1` ==> `=1`) inst_branch. Proof. - induction l using rev_ind; simpl; try reflexivity. - rewrite app_length. simpl. rewrite Nat.add_1_r. simpl. - rewrite nth_error_app_ge; try lia. rewrite Nat.sub_diag. simpl. - f_equal. rewrite {1}IHl. eapply nat_recursion_ext. intros. - now rewrite nth_error_app_lt. + apply map_branch_shift_proper; try tc. Qed. -Lemma Upn_comp n l σ : n = #|l| -> ⇑^n σ ∘s (l ⋅n ids) =1 l ⋅n σ. +Definition ren (f : nat -> nat) : nat -> term := + fun i => tRel (f i). + +Instance ren_ext : Morphisms.Proper (`=1` ==> `=1`)%signature ren. Proof. - intros ->. rewrite Upn_eq; simpl. - rewrite !subst_consn_compose. sigma. - rewrite subst_consn_shiftn ?map_length //. sigma. - eapply subst_consn_proper; try reflexivity. - rewrite map_idsn_spec. - rewrite {3}(id_nth_spec l). - eapply nat_recursion_ext. intros. - simpl. destruct (nth_error_spec l x). - - unfold subst_consn. rewrite e. reflexivity. - - lia. + 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. + intros i. + elim (Nat.ltb_spec i n) => H; elim (Nat.leb_spec n i) => H'; try lia; trivial. Qed. -Lemma shift_Up_comm σ : ↑ ∘s ⇑ σ =1 σ ∘s ↑. +Lemma rename_inst f : rename f =1 inst (ren f). +Proof. + intros t. revert f. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. + + - f_equal; eauto. now rewrite H0 -ren_shiftn. + - f_equal; eauto. now rewrite H0 -ren_shiftn. + - f_equal; eauto. now rewrite H1 -ren_shiftn. + - f_equal; eauto; solve_all. + * eapply map_predicate_shift_eq_spec; solve_all. + + now rewrite H0 ren_shiftn. + + now rewrite e ren_shiftn. + * apply map_branch_shift_eq_spec; solve_all. + + now rewrite H0 -ren_shiftn. + + now rewrite b -ren_shiftn. + - f_equal; eauto. solve_all. + now rewrite b ren_shiftn. + - f_equal; eauto. solve_all. + now rewrite b ren_shiftn. +Qed. + +Hint Rewrite @rename_inst : sigma. + +(** Show the σ-calculus equations. + + Additional combinators: [idsn n] for n-identity, [consn] for consing a parallel substitution. + *) + +Notation "t '.[' σ ]" := (inst σ t) (at level 6, format "t .[ σ ]") : sigma_scope. + +Definition subst_cons (t : term) (f : nat -> term) := + fun i => + match i with + | 0 => t + | S n => f n + end. + +Notation " t ⋅ s " := (subst_cons t s) (at level 70) : sigma_scope. + +Instance subst_cons_proper : Proper (Logic.eq ==> `=1` ==> `=1`) subst_cons. +Proof. intros x y -> f f' Hff'. intros i. destruct i; simpl; trivial. Qed. + +Definition shift : nat -> term := tRel ∘ S. +Notation "↑" := shift : sigma_scope. + +Definition subst_compose (σ τ : nat -> term) := + fun i => (σ i).[τ]. + +Infix "∘s" := subst_compose (at level 40) : sigma_scope. + +Instance subst_compose_proper : Proper (`=1` ==> `=1` ==> `=1`) subst_compose. +Proof. + intros f f' Hff' g g' Hgg'. intros x. unfold subst_compose. + now rewrite Hgg' Hff'. +Qed. + +Definition Up σ : substitution := tRel 0 ⋅ (σ ∘s ↑). +Notation "⇑ s" := (Up s) (at level 20). + +Instance Up_ext : Proper (`=1` ==> `=1`) Up. +Proof. + unfold Up. reduce_goal. unfold subst_compose, subst_cons. + destruct a => //. now rewrite H. +Qed. + +Lemma up_Up σ : up 1 σ =1 ⇑ σ. +Proof. + unfold up. + intros i. + elim (Nat.leb_spec 1 i) => H. + - unfold subst_cons, shift. destruct i. + -- lia. + -- simpl. rewrite Nat.sub_0_r. + unfold subst_compose. + now rewrite rename_inst. + - red in H. destruct i; [|lia]. reflexivity. +Qed. + +(** Simplify away [up 1] *) +Hint Rewrite up_Up : sigma. + +Definition ids (x : nat) := tRel x. + +Definition ren_id (x : nat) := x. + +Lemma ren_id_ids : ren ren_id =1 ids. Proof. reflexivity. Qed. -Lemma inst_closed0 σ t : closedn 0 t -> t.[σ] = t. -Proof. intros. rewrite -{2}[t](inst_closed σ 0) //. now sigma. Qed. - - -Lemma type_inst : - forall Σ Γ Δ σ t A, - wf Σ.1 -> - wf_local Σ Δ -> - Σ ;;; Δ ⊢ σ : Γ -> - Σ ;;; Γ |- t : A -> - Σ ;;; Δ |- t.[σ] : A.[σ]. -Proof. - intros Σ Γ Δ σ t A hΣ hΔ hσ h. - revert Σ hΣ Γ t A h Δ σ hΔ hσ. - apply (typing_ind_env (fun Σ Γ t T => forall Δ σ, - wf_local Σ Δ -> - Σ ;;; Δ ⊢ σ : Γ -> - Σ ;;; Δ |- t.[σ] : T.[σ] - ) (fun Σ Γ wfΓ => forall Δ σ, wf_local Σ Δ -> Σ ;;; Δ ⊢ σ : Γ -> - wf_local Σ Δ)). - - intros Σ wfΣ Γ wfΓ. auto. - - - intros Σ wfΣ Γ wfΓ n decl e X Δ σ hΔ hσ. simpl. - eapply hσ. assumption. - - intros Σ wfΣ Γ wfΓ l X H0 Δ σ hΔ hσ. simpl. - econstructor. all: assumption. - - intros Σ wfΣ Γ wfΓ na A B s1 s2 X hA ihA hB ihB Δ σ hΔ hσ. - autorewrite with sigma. simpl. - econstructor. - + eapply ihA ; auto. - + eapply ihB. - * econstructor ; auto. - eexists. eapply ihA ; auto. - * eapply well_subst_Up. 2: assumption. - econstructor ; auto. - eexists. eapply ihA. all: auto. - - intros Σ wfΣ Γ wfΓ na A t s1 bty X hA ihA ht iht Δ σ hΔ hσ. - autorewrite with sigma. - econstructor. - + eapply ihA ; auto. - + eapply iht. - * econstructor ; auto. - eexists. eapply ihA ; auto. - * eapply well_subst_Up. 2: assumption. - constructor. 1: assumption. - eexists. eapply ihA. all: auto. - - intros Σ wfΣ Γ wfΓ na b B t s1 A X hB ihB hb ihb ht iht Δ σ hΔ hσ. - autorewrite with sigma. - econstructor. - + eapply ihB. all: auto. - + eapply ihb. all: auto. - + eapply iht. - * econstructor. all: auto. - -- eexists. eapply ihB. all: auto. - -- simpl. eapply ihb. all: auto. - * eapply well_subst_Up'; try assumption. - constructor; auto. - ** exists s1. apply ihB; auto. - ** apply ihb; auto. - - intros Σ wfΣ Γ wfΓ t na A B s u X hty ihty ht iht hu ihu Δ σ hΔ hσ. - autorewrite with sigma. - econstructor. - * specialize (ihty _ _ hΔ hσ). - simpl in ihty. eapply meta_conv_term; [eapply ihty|]. - now rewrite up_Up. - * specialize (iht _ _ hΔ hσ). - simpl in iht. eapply meta_conv; [eapply iht|]. - now rewrite up_Up. - * eapply ihu; auto. - - intros Σ wfΣ Γ wfΓ cst u decl X X0 isdecl hconst Δ σ hΔ hσ. - autorewrite with sigma. simpl. - eapply meta_conv; [econstructor; eauto|]. - eapply declared_constant_closed_type in isdecl; eauto. - rewrite inst_closed0; auto. - now rewrite closedn_subst_instance_constr. - - intros Σ wfΣ Γ wfΓ ind u mdecl idecl isdecl X X0 hconst Δ σ hΔ hσ. - eapply meta_conv; [econstructor; eauto|]. - eapply declared_inductive_closed_type in isdecl; eauto. - rewrite inst_closed0; auto. - now rewrite closedn_subst_instance_constr. - - intros Σ wfΣ Γ wfΓ ind i u mdecl idecl cdecl isdecl X X0 hconst Δ σ hΔ hσ. - eapply meta_conv; [econstructor; eauto|]. - eapply declared_constructor_closed_type in isdecl; eauto. - rewrite inst_closed0; eauto. - - intros Σ wfΣ Γ wfΓ ind u npar p c brs args mdecl idecl isdecl X X0 a pars - ps pty htoc X1 ihp H2 X3 notcoind ihc btys H3 ihbtys Δ σ hΔ hσ. - autorewrite with sigma. simpl. - rewrite map_app. simpl. - rewrite map_skipn. - (* eapply types_of_case_inst with (σ := σ) in htoc. all: try eassumption. *) - eapply type_Case. - + eassumption. - + assumption. - + admit. - + simpl. eapply ihp. all: auto. - + eassumption. - + specialize (ihc _ _ hΔ hσ). autorewrite with sigma in ihc. - eapply ihc. - + admit. - + admit. - + admit. - - intros Σ wfΣ Γ wfΓ p c u mdecl idecl pdecl isdecl args X X0 hc ihc e ty - Δ σ hΔ hσ. - simpl. - eapply meta_conv; [econstructor|]. - * eauto. - * specialize (ihc _ _ hΔ hσ). - rewrite inst_mkApps in ihc. eapply ihc. - * now rewrite map_length. - * autorewrite with sigma. - eapply declared_projection_closed in isdecl; auto. - admit. - - intros Σ wfΣ Γ wfΓ mfix n decl types H0 H1 X ihmfix Δ σ hΔ hσ. - autorewrite with sigma. - admit. - - intros Σ wfΣ Γ wfΓ mfix n decl types H0 X X0 ihmfix Δ σ hΔ hσ. - autorewrite with sigma. - admit. - - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht hB ihB hcu Δ σ hΔ hσ. - eapply type_Cumul. - + eapply iht. all: auto. - + eapply ihB. all: auto. - + admit. -Admitted. - -End Sigma. +Lemma shiftn_ren_id n : shiftn n ren_id =1 ren_id. +Proof. apply shiftn_id. Qed. + +Lemma rename_ren_id : rename ren_id =1 id. +Proof. + intros t. unfold id. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. + + - f_equal; auto. now rewrite shiftn_id. + - f_equal; auto. now rewrite shiftn_id. + - f_equal; auto. now rewrite shiftn_id. + - f_equal; solve_all. + * eapply map_predicate_shift_id_spec; solve_all; now rewrite shiftn_id. + * eapply map_branch_shift_id_spec; solve_all; now rewrite shiftn_id. + - f_equal; auto. solve_all. + now rewrite shiftn_id. + - f_equal; auto. solve_all. + now rewrite shiftn_id. +Qed. + +Lemma subst_ids t : t.[ids] = t. +Proof. + now rewrite -ren_id_ids -rename_inst rename_ren_id. +Qed. + +Hint Rewrite subst_ids : sigma. + +Lemma compose_ids_r σ : σ ∘s ids =1 σ. +Proof. + unfold subst_compose. intros i; apply subst_ids. +Qed. + +Lemma compose_ids_l σ : ids ∘s σ =1 σ. +Proof. reflexivity. Qed. + +Hint Rewrite compose_ids_r compose_ids_l : sigma. + +Definition shiftk (k : nat) (x : nat) := tRel (k + x). +Notation "↑^ k" := (shiftk k) (at level 30, k at level 2, format "↑^ k") : sigma_scope. + +Lemma shiftk_0 : shiftk 0 =1 ids. +Proof. + intros i. reflexivity. +Qed. + +Definition subst_consn {A} (l : list A) (σ : nat -> A) := + fun i => + match List.nth_error l i with + | None => σ (i - List.length l) + | Some t => t + end. + +Notation " t ⋅n s " := (subst_consn t s) (at level 40) : sigma_scope. + +Lemma subst_consn_nil {A} (σ : nat -> A) : nil ⋅n σ =1 σ. +Proof. + intros i. unfold subst_consn. rewrite nth_error_nil. + now rewrite Nat.sub_0_r. +Qed. +Hint Rewrite @subst_consn_nil : sigma. + +Lemma subst_consn_subst_cons t l σ : (t :: l) ⋅n σ =1 (t ⋅ subst_consn l σ). +Proof. + intros i. unfold subst_consn. induction i; simpl; trivial. +Qed. + +Lemma subst_consn_tip t σ : [t] ⋅n σ =1 (t ⋅ σ). +Proof. now rewrite subst_consn_subst_cons subst_consn_nil. Qed. +Hint Rewrite @subst_consn_tip : sigma. + +Instance subst_consn_proper {A} : Proper (Logic.eq ==> `=1` ==> `=1`) (@subst_consn A). +Proof. + intros ? l -> f f' Hff' i. + unfold subst_consn. destruct nth_error eqn:Heq; auto. +Qed. + +Instance subst_consn_proper_ext {A} : Proper (Logic.eq ==> `=1` ==> Logic.eq ==> Logic.eq) (@subst_consn A). +Proof. + intros ? l -> f f' Hff' i i' <-. + unfold subst_consn. destruct nth_error eqn:Heq; auto. +Qed. + +Fixpoint idsn n : list term := + match n with + | 0 => [] + | S n => idsn n ++ [tRel n] + end. + +Definition subst_cons_gen {A} (t : A) (f : nat -> A) := + fun i => + match i with + | 0 => t + | S n => f n + end. + +Instance subst_cons_gen_proper {A} : Proper (Logic.eq ==> `=1` ==> `=1`) (@subst_cons_gen A). +Proof. intros x y <- f g Hfg i. destruct i; simpl; auto. Qed. + +Lemma subst_consn_subst_cons_gen {A} (t : A) l σ : subst_consn (t :: l) σ =1 (subst_cons_gen t (l ⋅n σ)). +Proof. + intros i. unfold subst_consn. induction i; simpl; trivial. +Qed. + +Lemma subst_consn_app {A} {l l' : list A} {σ} : (l ++ l') ⋅n σ =1 l ⋅n (l' ⋅n σ). +Proof. + induction l; simpl; auto. + - now rewrite subst_consn_nil. + - now rewrite !subst_consn_subst_cons_gen IHl. +Qed. + +Lemma subst_consn_ge {A} {l : list A} {i σ} : #|l| <= i -> (l ⋅n σ) i = σ (i - #|l|). +Proof. + induction l in i, σ |- *; simpl. + - now rewrite subst_consn_nil. + - rewrite subst_consn_subst_cons_gen. + intros H. destruct i; [lia|]. simpl. + apply IHl. lia. +Qed. + +Lemma subst_consn_lt_spec {A} {l : list A} {i} : + i < #|l| -> + ∑ x, (List.nth_error l i = Some x) /\ (forall σ, (l ⋅n σ) i = x)%type. +Proof. + induction l in i |- *; simpl. + - intros H; elimtype False; lia. + - intros H. + destruct i. + + simpl. exists a. split; auto. + + specialize (IHl i). forward IHl. + * lia. + * destruct IHl as [x [Hnth Hsubst_cons]]. + exists x. simpl. split; auto. +Qed. + +Lemma subst_consn_lt {l : list term} {i : nat} {σ} : + i < #|l| -> + (l ⋅n σ) i = subst_fn l i. +Proof. + move/subst_consn_lt_spec => [x [hnth] hl]. + rewrite hl. unfold subst_fn. now rewrite hnth. +Qed. + +Lemma ren_consn_lt {l : list nat} {i : nat} {σ} : + i < #|l| -> + (l ⋅n σ) i = ren_fn l i. +Proof. + move/subst_consn_lt_spec => [x [hnth] hl]. + rewrite hl. unfold ren_fn. now rewrite hnth. +Qed. + +Fixpoint ren_ids (n : nat) := + match n with + | 0 => [] + | S n => ren_ids n ++ [n] + end. + +Lemma ren_ids_length n : #|ren_ids n| = n. +Proof. induction n; simpl; auto. rewrite app_length IHn; simpl; lia. Qed. +Hint Rewrite ren_ids_length : len. + +Lemma idsn_length n : #|idsn n| = n. +Proof. + induction n; simpl; auto. rewrite app_length IHn; simpl; lia. +Qed. +Hint Rewrite idsn_length : len. + +Lemma idsn_lt {n i} : i < n -> nth_error (idsn n) i = Some (tRel i). +Proof. + induction n in i |- *; simpl; auto. + - intros H; lia. + - intros H. destruct (Compare_dec.le_lt_dec n i). + -- assert (n = i) by lia; subst. + rewrite nth_error_app_ge idsn_length ?Nat.sub_diag; trea. + -- rewrite nth_error_app_lt ?idsn_length //. apply IHn; lia. +Qed. + +Lemma nth_ren_ids_lt {n i} : i < n -> nth_error (ren_ids n) i = Some i. +Proof. + induction n in i |- *; simpl; auto. + - intros H; lia. + - intros H. destruct (Compare_dec.le_lt_dec n i). + -- assert (n = i) by lia; subst. + rewrite nth_error_app_ge ren_ids_length ?Nat.sub_diag; trea. + -- rewrite nth_error_app_lt ?ren_ids_length //. apply IHn; lia. +Qed. + +Lemma ren_ids_lt {n i} : i < n -> ren (ren_fn (ren_ids n)) i = tRel i. +Proof. + intros lt. + rewrite /ren /ren_fn nth_ren_ids_lt //. +Qed. + +Lemma ren_idsn_consn_lt {i n : nat} {σ} : i < n -> + ren (ren_ids n ⋅n σ) i = tRel i. +Proof. + intros lt. + rewrite /ren ren_consn_lt; len => //. + rewrite /ren_fn nth_ren_ids_lt //. +Qed. + +Lemma subst_ids_lt i m : i < m -> subst_fn (idsn m) i = tRel i. +Proof. + move=> lt. rewrite /subst_fn idsn_lt //. +Qed. + +Lemma subst_idsn_consn_lt {i n : nat} {σ} : i < n -> + (idsn n ⋅n σ) i = tRel i. +Proof. + intros lt. + rewrite subst_consn_lt; len; try lia. + rewrite subst_ids_lt //. +Qed. + +Lemma nth_error_idsn_Some : + forall n k, + k < n -> + nth_error (idsn n) k = Some (tRel k). +Proof. + intros n k h. + induction n in k, h |- *. + - inversion h. + - simpl. destruct (Nat.ltb_spec0 k n). + + rewrite nth_error_app1. + * rewrite idsn_length. auto. + * eapply IHn. assumption. + + assert (k = n) by lia. subst. + rewrite nth_error_app2. + * rewrite idsn_length. auto. + * rewrite idsn_length. replace (n - n) with 0 by lia. + simpl. reflexivity. +Qed. + +Lemma nth_error_idsn_None : + forall n k, + k >= n -> + nth_error (idsn n) k = None. +Proof. + intros n k h. + eapply nth_error_None. + rewrite idsn_length. auto. +Qed. + + +Lemma subst_cons_0 t σ : (tRel 0).[t ⋅ σ] = t. Proof. reflexivity. Qed. +Lemma subst_cons_shift t σ : ↑ ∘s (t ⋅ σ) = σ. Proof. reflexivity. Qed. +Hint Rewrite subst_cons_0 subst_cons_shift : sigma. + +Lemma shiftk_shift n : ↑^(S n) =1 ↑^n ∘s ↑. Proof. reflexivity. Qed. + +Lemma shiftk_shift_l n : ↑^(S n) =1 ↑ ∘s ↑^n. +Proof. + intros i. + unfold shiftk. unfold subst_compose, shift. + simpl. f_equal. lia. +Qed. + +Lemma subst_subst_consn s σ τ : (s ⋅ σ) ∘s τ =1 (s.[τ] ⋅ σ ∘s τ). +Proof. + intros i. + destruct i; simpl; reflexivity. +Qed. + +Hint Rewrite subst_subst_consn : sigma. + +Definition Upn n σ := idsn n ⋅n (σ ∘s ↑^n). +Notation "⇑^ n σ" := (Upn n σ) (at level 30, n at level 2, format "⇑^ n σ") : sigma_scope. + +Instance Upn_ext n : Proper (`=1` ==> `=1`) (Upn n). +Proof. + unfold Upn. reduce_goal. now rewrite H. +Qed. + +Lemma Upn_0 σ : ⇑^0 σ =1 σ. +Proof. + unfold Upn. simpl. + now rewrite subst_consn_nil shiftk_0 compose_ids_r. +Qed. + +Lemma Upn_1_Up σ : ⇑^1 σ =1 ⇑ σ. +Proof. + unfold Upn. + intros i. destruct i; auto. + simpl. rewrite subst_consn_ge; simpl; auto with arith. +Qed. +Hint Rewrite Upn_1_Up : sigma. + +Lemma Upn_eq n σ : Upn n σ = idsn n ⋅n (σ ∘s ↑^n). +Proof. reflexivity. Qed. + +Lemma Upn_proper : Proper (Logic.eq ==> `=1` ==> `=1`) Upn. +Proof. intros ? ? -> f g Hfg. unfold Upn. now rewrite Hfg. Qed. + +(** The σ-calculus equations for Coq *) + +Lemma inst_app {s t σ} : (tApp s t).[σ] = tApp s.[σ] t.[σ]. +Proof. reflexivity. Qed. + +Lemma inst_lam {na t b σ} : (tLambda na t b).[σ] = tLambda na t.[σ] b.[⇑ σ]. +Proof. + simpl. now rewrite up_Up. +Qed. + +Lemma inst_prod {na t b σ} : (tProd na t b).[σ] = tProd na t.[σ] b.[⇑ σ]. +Proof. + simpl. now rewrite up_Up. +Qed. + +Lemma inst_letin {na t b b' σ} : (tLetIn na t b b').[σ] = tLetIn na t.[σ] b.[σ] b'.[⇑ σ]. +Proof. + simpl. now rewrite up_Up. +Qed. + +Lemma up_Upn {n σ} : up n σ =1 ⇑^n σ. +Proof. + unfold up, Upn. + intros i. + elim (Nat.leb_spec n i) => H. + - rewrite rename_inst. + rewrite subst_consn_ge; rewrite idsn_length; auto. + - assert (Hle: i < #|idsn n|) by (rewrite idsn_length; lia). + rewrite (subst_consn_lt Hle) /subst_fn idsn_lt //. +Qed. + +Lemma Upn_ren k f : ⇑^k ren f =1 ren (shiftn k f). +Proof. + now rewrite -up_Upn ren_shiftn. +Qed. + +Lemma inst_fix {mfix idx σ} : (tFix mfix idx).[σ] = + tFix (map (map_def (inst σ) (inst (⇑^#|mfix| σ))) mfix) idx. +Proof. + simpl. f_equal. apply map_ext. intros x. apply map_def_eq_spec => //. + now rewrite up_Upn. +Qed. + +Lemma inst_cofix {mfix idx σ} : (tCoFix mfix idx).[σ] = + tCoFix (map (map_def (inst σ) (inst (⇑^#|mfix| σ))) mfix) idx. +Proof. + simpl. f_equal. apply map_ext. intros x. apply map_def_eq_spec => //. + now rewrite up_Upn. +Qed. + +Lemma inst_mkApps : + forall t l σ, + (mkApps t l).[σ] = mkApps t.[σ] (map (inst σ) l). +Proof. + intros t l σ. + induction l in t, σ |- *. + - reflexivity. + - simpl. rewrite IHl. reflexivity. +Qed. + +Hint Rewrite @inst_app @inst_lam @inst_prod @inst_letin @inst_fix @inst_cofix + @inst_mkApps : sigma. + + +Lemma ren_shift : ↑ =1 ren S. +Proof. reflexivity. Qed. + +Lemma compose_ren f g : ren f ∘s ren g =1 ren (g ∘ f). +Proof. + intros i. + destruct i; simpl; reflexivity. +Qed. +Hint Rewrite compose_ren : sigma. + +Lemma subst_cons_ren i f : (tRel i ⋅ ren f) =1 ren (subst_cons_gen i f). +Proof. + intros x; destruct x; auto. +Qed. + +Infix "=2" := (Logic.eq ==> (pointwise_relation _ Logic.eq))%signature (at level 70) : signature_scope. + +Lemma subst_consn_subst_cons' {A} (t : A) l : (subst_consn (t :: l) =2 ((subst_cons_gen t) ∘ (subst_consn l)))%signature. +Proof. red. + intros x y <-. apply subst_consn_subst_cons_gen. +Qed. + +Lemma subst_consn_compose l σ' σ : l ⋅n σ' ∘s σ =1 (map (inst σ) l ⋅n (σ' ∘s σ)). +Proof. + induction l; simpl. + - now sigma. + - rewrite subst_consn_subst_cons. sigma. + rewrite IHl. now rewrite subst_consn_subst_cons. +Qed. + +Lemma subst_consn_ids_ren n f : (idsn n ⋅n ren f) =1 ren (ren_ids n ⋅n f). +Proof. + intros i. + destruct (Nat.leb_spec n i). + - rewrite subst_consn_ge idsn_length; auto. + unfold ren. f_equal. rewrite subst_consn_ge ren_ids_length; auto. + - assert (Hr:i < #|ren_ids n|) by (rewrite ren_ids_length; lia). + assert (Hi:i < #|idsn n|) by (rewrite idsn_length; lia). + now rewrite (subst_consn_lt Hi) subst_ids_lt // (ren_idsn_consn_lt H). +Qed. + +Lemma ren_shiftk n : ren (Nat.add n) =1 ↑^n. +Proof. reflexivity. Qed. +Hint Rewrite ren_shiftk : sigma. + +Lemma ren_rshiftk k : ren (rshiftk k) =1 ↑^k. +Proof. reflexivity. Qed. +Hint Rewrite ren_rshiftk : sigma. + +Lemma map_inst_idsn σ n m : m <= n -> map (inst (⇑^n σ)) (idsn m) = idsn m. +Proof. + induction m in n |- *; simpl; auto. + intros. + rewrite map_app IHm; try lia. + f_equal. simpl. rewrite Upn_eq. + now rewrite subst_consn_lt /subst_fn ?idsn_lt; len; try lia. +Qed. + +(** Specific lemma for the fix/cofix cases where we are subst_cons'ing a list of ids in front + of the substitution. *) +Lemma ren_subst_consn_comm: + forall (f : nat -> nat) (σ : nat -> term) (n : nat), + ren (subst_consn (ren_ids n) (rshiftk n ∘ f)) ∘s subst_consn (idsn n) (σ ∘s ↑^n) =1 + subst_consn (idsn n) (ren f ∘s σ ∘s ↑^n). +Proof. + intros f σ m. + rewrite -subst_consn_ids_ren. + rewrite subst_consn_compose. + apply subst_consn_proper. + * rewrite -Upn_eq map_inst_idsn //. + * intros i. + rewrite /ren /subst_compose /= /rshiftk. + rewrite subst_consn_ge; len; try lia. + lia_f_equal. +Qed. + +(** Simplify away iterated up's *) +Hint Rewrite @up_Upn : sigma. + +Lemma Upn_ren_l k f σ : ⇑^k ren f ∘s ⇑^k σ =1 ⇑^k (ren f ∘s σ). +Proof. + rewrite Upn_eq. + rewrite -(ren_shiftk k) !compose_ren !subst_consn_ids_ren. + apply ren_subst_consn_comm. +Qed. + +Lemma rename_inst_assoc t f σ : t.[ren f].[σ] = t.[ren f ∘s σ]. +Proof. + revert f σ. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. + + - f_equal; auto. sigma. + unfold Up. + simpl. rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. + apply inst_ext. intros i. destruct i; auto. + - f_equal; auto. sigma. + unfold Up. + rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. + apply inst_ext. intros i. destruct i; auto. + - f_equal; auto. sigma. + unfold Up. + rewrite ren_shift. rewrite compose_ren subst_cons_ren H1. + apply inst_ext. intros i. destruct i; auto. + - f_equal; auto; solve_all; sigma. + * unfold map_predicate_shift; simpl; f_equal; solve_all. + + now rewrite !up_Upn Upn_ren H0 -Upn_ren Upn_ren_l. + + rewrite !up_Upn Upn_ren e -Upn_ren. len. + now rewrite Upn_ren_l. + * unfold map_branch_shift; simpl; f_equal; solve_all. + + now rewrite !up_Upn Upn_ren H0 -Upn_ren Upn_ren_l. + + len. now rewrite !up_Upn Upn_ren b -Upn_ren Upn_ren_l. + - f_equal; auto. + red in X. rewrite map_map_compose. solve_all. + sigma. + now rewrite Upn_ren b -Upn_ren Upn_ren_l. + - f_equal; auto. + red in X. solve_all. + sigma. + now rewrite Upn_ren b -Upn_ren Upn_ren_l. +Qed. + +Lemma map_idsn_spec (f : term -> term) (n : nat) : + map f (idsn n) = Nat.recursion [] (fun x l => l ++ [f (tRel x)]) n. +Proof. + induction n; simpl. + - reflexivity. + - simpl. rewrite map_app. now rewrite -IHn. +Qed. + +Lemma idsn_spec (n : nat) : + idsn n = Nat.recursion [] (fun x l => l ++ [tRel x]) n. +Proof. + induction n; simpl. + - reflexivity. + - simpl. now rewrite -IHn. +Qed. + +Lemma nat_recursion_ext {A} (x : A) f g n : + (forall x l', x < n -> f x l' = g x l') -> + Nat.recursion x f n = Nat.recursion x g n. +Proof. + intros. + generalize (le_refl n). + induction n at 1 3 4; simpl; auto. + intros. simpl. rewrite IHn0; try lia. now rewrite H. +Qed. + +Lemma rename_idsn_idsn m f : map (rename (ren_ids m ⋅n f)) (idsn m) = idsn m. +Proof. + rewrite map_idsn_spec idsn_spec. + apply nat_recursion_ext. intros x l' hx. f_equal. + simpl. f_equal. f_equal. rewrite ren_consn_lt; len => //. + rewrite /ren_fn. rewrite nth_ren_ids_lt //. +Qed. + +Lemma inst_rename_assoc_n: + forall (f : nat -> nat) (σ : nat -> term) (n : nat), + subst_consn (idsn n) (σ ∘s ↑^n) ∘s ren (subst_consn (ren_ids n) (Init.Nat.add n ∘ f)) =1 + subst_consn (idsn n) (σ ∘s ren f ∘s ↑^n). +Proof. + intros f σ m. rewrite -ren_shiftk. + intros i. + destruct (Nat.leb_spec m i). + -- rewrite [subst_consn (idsn _) _ i]subst_consn_ge ?idsn_length; try lia. + unfold subst_compose. + rewrite [subst_consn (idsn _) _ i]subst_consn_ge ?idsn_length; try lia. + rewrite !rename_inst_assoc !compose_ren. + apply inst_ext. intros i'. + unfold ren. f_equal. rewrite subst_consn_ge ?ren_ids_length; try lia. + now assert (m + i' - m = i') as -> by lia. + -- 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_lt); len => //. + rewrite -rename_inst rename_idsn_idsn subst_ids_lt //. +Qed. + +Lemma Upn_ren_r k f σ : ⇑^k σ ∘s ⇑^k ren f =1 ⇑^k (σ ∘s ren f). +Proof. + rewrite !Upn_eq. + rewrite -(ren_shiftk k) !compose_ren !subst_consn_ids_ren. + apply inst_rename_assoc_n. +Qed. + +Lemma inst_rename_assoc t f σ : t.[σ].[ren f] = t.[σ ∘s ren f]. +Proof. + revert f σ. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. + + - f_equal; auto. sigma. + unfold Up. + rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. + apply inst_ext. intros i. destruct i; auto. simpl. + unfold subst_compose. simpl. now rewrite !rename_inst_assoc !compose_ren. + - f_equal; auto. sigma. + unfold Up. + rewrite ren_shift. rewrite compose_ren subst_cons_ren H0. + apply inst_ext. intros i. destruct i; auto. + unfold subst_compose. simpl. now rewrite !rename_inst_assoc !compose_ren. + - f_equal; auto. sigma. + unfold Up. + rewrite ren_shift. rewrite compose_ren subst_cons_ren H1. + apply inst_ext. intros i. destruct i; auto. + unfold subst_compose. simpl. now rewrite !rename_inst_assoc !compose_ren. + - f_equal; auto; solve_all; sigma. + * unfold map_predicate_shift; cbn; f_equal; solve_all. + + now rewrite !up_Upn Upn_ren H0 -Upn_ren Upn_ren_r. + + now rewrite !up_Upn Upn_ren e; len; rewrite -Upn_ren Upn_ren_r. + * sigma. + unfold map_branch_shift; cbn; f_equal; solve_all. + + now rewrite !up_Upn Upn_ren H0 -Upn_ren Upn_ren_r. + + now rewrite !up_Upn Upn_ren b; len; rewrite -Upn_ren Upn_ren_r. + - f_equal; auto. + red in X. rewrite map_map_compose. solve_all. + sigma. now rewrite Upn_ren b -Upn_ren Upn_ren_r. + - f_equal; auto. + red in X. rewrite map_map_compose. solve_all. + sigma. now rewrite Upn_ren b -Upn_ren Upn_ren_r. +Qed. + +Lemma rename_subst_compose1 r s s' : ren r ∘s (s ∘s s') =1 ren r ∘s s ∘s s'. +Proof. unfold subst_compose. simpl. intros i. reflexivity. Qed. + +Lemma rename_subst_compose2 r s s' : s ∘s (ren r ∘s s') =1 s ∘s ren r ∘s s'. +Proof. + unfold subst_compose. simpl. intros i. + rewrite rename_inst_assoc. reflexivity. +Qed. + +Lemma rename_subst_compose3 r s s' : s ∘s (s' ∘s ren r) =1 s ∘s s' ∘s ren r. +Proof. + unfold subst_compose. simpl. intros i. + rewrite inst_rename_assoc. reflexivity. +Qed. + +Lemma Up_Up_assoc: + forall s s' : nat -> term, (⇑ s) ∘s (⇑ s') =1 ⇑ (s ∘s s'). +Proof. + intros s s'. + unfold Up. + rewrite ren_shift. + rewrite subst_subst_consn. + simpl. apply subst_cons_proper => //. + rewrite - rename_subst_compose2. + rewrite - rename_subst_compose3. + now apply subst_compose_proper; auto. +Qed. + +Hint Rewrite Up_Up_assoc : sigma. + +Lemma up_up_assoc: + forall (s s' : nat -> term) (n : nat), up n s ∘s up n s' =1 up n (s ∘s s'). +Proof. + intros s s' n i. + unfold up, subst_compose. simpl. + destruct (Nat.leb_spec n i). + - rewrite !(rename_inst (Nat.add n) (s (i - n))). + rewrite rename_inst_assoc. + rewrite !(rename_inst (Nat.add n) _). + rewrite inst_rename_assoc. + apply inst_ext. + intros i'. unfold subst_compose. + unfold ren. simpl. + destruct (Nat.leb_spec n (n + i')). + * rewrite rename_inst. + now assert (n + i' - n = i') as -> by lia. + * lia. + - simpl. + destruct (Nat.leb_spec n i); lia_f_equal. +Qed. + +Lemma inst_assoc t s s' : t.[s].[s'] = t.[s ∘s s']. +Proof. + revert s s'. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. + + - f_equal; auto. sigma. + now rewrite H0 Up_Up_assoc. + - f_equal; auto. sigma. + now rewrite H0 Up_Up_assoc. + - f_equal; auto. sigma. + now rewrite H1 Up_Up_assoc. + - f_equal; auto. + * unfold map_predicate_shift; cbn; f_equal; solve_all. + + now rewrite H0 up_up_assoc. + + len. now rewrite e up_up_assoc. + * rewrite map_map_compose; solve_all. + unfold map_branch_shift; cbn; f_equal; solve_all. + + now rewrite H0 up_up_assoc. + + len. now rewrite b up_up_assoc. + - f_equal; auto. sigma. + rewrite map_map_compose; solve_all. + now rewrite b up_up_assoc. + - f_equal; auto. sigma. + rewrite map_map_compose; solve_all. + now rewrite b up_up_assoc. +Qed. + +Hint Rewrite inst_assoc : sigma. + +Lemma subst_compose_assoc s s' s'' : (s ∘s s') ∘s s'' =1 s ∘s (s' ∘s s''). +Proof. + intros i; unfold subst_compose at 1 3 4. + now rewrite inst_assoc. +Qed. + +Hint Rewrite subst_compose_assoc : sigma. + +Lemma subst_cons_0_shift : (tRel 0 ⋅ ↑) =1 ids. +Proof. intros i. destruct i; reflexivity. Qed. + +Hint Rewrite subst_cons_0_shift : sigma. + +Lemma subst_cons_0s_shifts σ : ((σ 0) ⋅ (↑ ∘s σ)) =1 σ. +Proof. + intros i. destruct i; auto. +Qed. + +Hint Rewrite subst_cons_0s_shifts : sigma. + +Lemma Upn_Up σ n : ⇑^(S n) σ =1 ⇑^n ⇑ σ. +Proof. + intros i. unfold Upn. + simpl. rewrite subst_consn_app. + 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. + - unfold shiftk. now rewrite Nat.add_0_r. + - simpl. now rewrite inst_assoc. +Qed. + +Lemma Upn_1 σ : ⇑^1 σ =1 ⇑ σ. +Proof. now rewrite Upn_Up Upn_0. Qed. + +Lemma Upn_S σ n : ⇑^(S n) σ =1 ⇑ ⇑^n σ. +Proof. + rewrite Upn_Up. induction n in σ |- *. + * rewrite !Upn_0. now eapply Up_ext. + * rewrite Upn_Up. rewrite IHn. eapply Up_ext. now rewrite Upn_Up. +Qed. +Hint Rewrite Upn_0 Upn_S : sigma. + +(* Print Rewrite HintDb sigma. *) + +Lemma subst_inst_aux s k t : subst s k t = inst (up k (subst_fn s)) t. +Proof. + revert s k. + elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. + + - unfold subst_fn, up. + elim (Nat.leb_spec k n) => //. + intros H. + destruct nth_error eqn:Heq. + * apply lift_rename. + * simpl. eapply nth_error_None in Heq. lia_f_equal. + - f_equal; eauto. + rewrite H0. apply inst_ext. intros t'; now rewrite (up_up 1 k). + - f_equal; eauto. + rewrite H0. apply inst_ext. intros t'; now rewrite (up_up 1 k). + - f_equal; eauto. + rewrite H1. apply inst_ext. intros t'; now rewrite (up_up 1 k). + - f_equal; eauto. + * unfold map_predicate_k, map_predicate_shift; destruct p; cbn in *; f_equal; solve_all. + + now rewrite /shiftf up_up. + + simpl in e. now rewrite up_up. + * solve_all. + unfold map_branch_k, map_branch_shift; destruct x; cbn in *; f_equal; solve_all. + + now rewrite /shiftf up_up. + + now rewrite b up_up. + - 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. + rewrite b. apply inst_ext. intros t'; now rewrite (up_up #|m| k). +Qed. + +Lemma subst_fn_subst_consn s : subst_fn s =1 subst_consn s ids. +Proof. reflexivity. Qed. + +(** Substitution is faithfully modelled by instantiation *) +Theorem subst_inst s k t : subst s k t = inst (⇑^k (subst_consn s ids)) t. +Proof. + rewrite subst_inst_aux up_Upn. apply inst_ext. + unfold Upn. now rewrite subst_fn_subst_consn. +Qed. + +(** Useful for point-free rewriting *) +Corollary subst_inst' s k : subst s k =1 inst (⇑^k (subst_consn s ids)). +Proof. + intros t; apply subst_inst. +Qed. + +(** Simplify away [subst] to the σ-calculus [inst] primitive. *) +Hint Rewrite @subst_inst : sigma. +Hint Rewrite @subst_consn_nil : sigma. + +Hint Rewrite shiftk_shift_l shiftk_shift : sigma. +(* Hint Rewrite Upn_eq : sigma. *) + + +Fixpoint subst_app (t : term) (us : list term) : term := + match t, us with + | tLambda _ A t, u :: us => subst_app (t {0 := u}) us + | _, [] => t + | _, _ => mkApps t us + end. + +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. simpl in *. + rewrite subst_consn_subst_cons. + simpl; sigma. apply IHn. lia. +Qed. + +Lemma shiftn_Upn n σ : ↑^n ∘s ⇑^n σ =1 σ ∘s ↑^n. +Proof. + unfold Upn. rewrite subst_consn_shiftn; [reflexivity|]. + now rewrite idsn_length. +Qed. +Hint Rewrite shiftn_Upn: sigma. + +Lemma id_nth_spec {A} (l : list A) : + l = Nat.recursion [] (fun x l' => + match nth_error l x with + | Some a => l' ++ [a] + | None => l' + end) #|l|. +Proof. + induction l using rev_ind; simpl; try reflexivity. + rewrite app_length. simpl. rewrite Nat.add_1_r. simpl. + rewrite nth_error_app_ge; try lia. rewrite Nat.sub_diag. simpl. + f_equal. rewrite {1}IHl. eapply nat_recursion_ext. intros. + now rewrite nth_error_app_lt. +Qed. + +Lemma Upn_comp n l σ : n = #|l| -> ⇑^n σ ∘s (l ⋅n ids) =1 l ⋅n σ. +Proof. + intros ->. rewrite Upn_eq; simpl. + rewrite !subst_consn_compose. sigma. + rewrite subst_consn_shiftn ?map_length //. sigma. + eapply subst_consn_proper; try reflexivity. + rewrite map_idsn_spec. + rewrite {3}(id_nth_spec l). + eapply nat_recursion_ext. intros. + simpl. destruct (nth_error_spec l x). + - unfold subst_consn. rewrite e. reflexivity. + - lia. +Qed. + +Lemma shift_Up_comm σ : ↑ ∘s ⇑ σ =1 σ ∘s ↑. +Proof. reflexivity. Qed. + +Lemma shiftk_compose n m : ↑^n ∘s ↑^m =1 ↑^(n + m). +Proof. + induction n; simpl; sigma; auto. + - reflexivity. + - rewrite -subst_compose_assoc. + rewrite -shiftk_shift shiftk_shift_l. + now rewrite subst_compose_assoc IHn -shiftk_shift shiftk_shift_l. +Qed. + +Lemma Upn_Upn k k' σ : ⇑^(k + k') σ =1 ⇑^k (⇑^k' σ). +Proof. + setoid_rewrite <- up_Upn. rewrite -(@up_Upn k'). + symmetry; apply up_up. +Qed. +Hint Rewrite Upn_Upn : sigma. + +Lemma Upn_compose n σ σ' : ⇑^n σ ∘s ⇑^n σ' =1 ⇑^n (σ ∘s σ'). +Proof. + induction n. + - unfold Upn. simpl. + now rewrite !subst_consn_nil !shiftk_0 !compose_ids_r. + - setoid_rewrite Upn_S. sigma. now rewrite IHn. +Qed. + +Lemma up_ext_closed k' k s s' : + (forall i, i < k' -> s i = s' i) -> + forall i, i < k + k' -> + up k s i = up k s' i. +Proof. + unfold up. intros Hs t. elim (Nat.leb_spec k t) => H; auto. + intros. f_equal. apply Hs. lia. +Qed. + +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. + 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. +Qed. + +Lemma shift_subst_instance : + forall u t k, + (subst_instance u t).[⇑^k ↑] = subst_instance u t.[⇑^k ↑]. +Proof. + intros u t k. + rewrite /subst_instance /=. + induction t in k |- * using term_forall_list_ind. + all: simpl. all: auto. + all: sigma. + all: autorewrite with map; unfold map_branch. + all: try solve [ f_equal ; eauto ; solve_all ; eauto ]. + - unfold Upn, shift, subst_compose, subst_consn. + destruct (Nat.ltb_spec0 n k). + + rewrite nth_error_idsn_Some. 1: assumption. + reflexivity. + + rewrite nth_error_idsn_None. 1: lia. + reflexivity. + - rewrite IHt1. specialize (IHt2 (S k)). + setoid_rewrite Upn_S in IHt2. + rewrite IHt2. reflexivity. + - rewrite IHt1. specialize (IHt2 (S k)). + setoid_rewrite Upn_S in IHt2. + rewrite IHt2. reflexivity. + - rewrite IHt1 IHt2. specialize (IHt3 (S k)). + setoid_rewrite Upn_S in IHt3. + rewrite IHt3. reflexivity. + - f_equal. + * destruct X. solve_all. + unfold map_predicate_shift, map_predicate. + destruct p; cbn in *; simpl; f_equal. + + solve_all. + + rewrite mapi_context_map_context [map _ _]map_context_mapi_context. + solve_all. now rewrite up_Upn -Upn_Upn. + + solve_all. now rewrite up_Upn -Upn_Upn. + * apply IHt. + * solve_all. + unfold map_branch_shift, map_branch. + destruct x; cbn in *; simpl; f_equal. + + rewrite mapi_context_map_context. + solve_all. now rewrite up_Upn -Upn_Upn. + + solve_all. now rewrite up_Upn -Upn_Upn. + - f_equal. + red in X. + eapply All_map_eq. eapply (All_impl X). + intros x [IH IH']. + apply map_def_eq_spec. + * apply IH. + * specialize (IH' (#|m| + k)). + sigma. + now rewrite - !up_Upn up_up !up_Upn. + - f_equal. + autorewrite with len. + red in X. + eapply All_map_eq. eapply (All_impl X). + intros x [IH IH']. + apply map_def_eq_spec. + * apply IH. + * specialize (IH' (#|m| + k)). sigma. + now rewrite - !up_Upn up_up !up_Upn. +Qed. + +Lemma nth_error_idsn_eq_Some n k i : nth_error (idsn n) k = Some i -> i = tRel k. +Proof. + intros hnth. + move: (nth_error_Some_length hnth). + len. move/nth_error_idsn_Some. + now rewrite hnth => [= ->]. +Qed. + +Lemma subst_consn_ids_rel_ren n k f : (idsn n ⋅n (tRel k ⋅ ren f) =1 ren (ren_ids n ⋅n (subst_cons_gen k f)))%sigma. +Proof. + intros i. + destruct (Nat.leb_spec n i). + - rewrite subst_consn_ge idsn_length //. + unfold ren. f_equal. rewrite subst_consn_ge ren_ids_length; auto. + unfold subst_cons_gen. destruct (i - n) eqn:eqin. + * simpl. auto. + * simpl. reflexivity. + - assert (Hi:i < #|idsn n|) by (rewrite idsn_length; lia). + rewrite (subst_consn_lt Hi) ren_idsn_consn_lt //. + rewrite subst_ids_lt //. +Qed. + +Lemma lift_renaming_0 k : ren (lift_renaming k 0) = ren (rshiftk k). +Proof. reflexivity. Qed. + +Lemma ren_lift_renaming n k : ren (lift_renaming n k) =1 (⇑^k ↑^n). +Proof. + unfold subst_compose. intros i. + simpl. rewrite -{1}(Nat.add_0_r k). unfold ren. rewrite - (shiftn_lift_renaming n k 0). + pose proof (ren_shiftn k (lift_renaming n 0) i). + change ((ren (shiftn k (lift_renaming n 0)) i) = ((⇑^k (↑^n)) i)). + rewrite -H. sigma. rewrite lift_renaming_0. reflexivity. +Qed. + +Arguments Nat.sub : simpl never. + +Lemma subst_consn_idsn_shift n σ : (idsn n ⋅n (σ ∘s ↑^n)) = ⇑^n σ. +Proof. + now rewrite Upn_eq. +Qed. + +Lemma Up_comp (t : term) σ : ⇑ σ ∘s (t ⋅ ids) =1 subst_cons t σ. +Proof. + rewrite /Up; simpl. now sigma. +Qed. + +Lemma shiftk_unfold i : (tRel i ⋅ ↑^(S i)) =1 ↑^i. +Proof. + intros x; unfold subst_cons, shiftk. destruct x; lia_f_equal. +Qed. + +Lemma subst_cons_compose_r t σ' σ : σ ∘s (t ⋅ σ') =1 ((σ 0).[t ⋅ σ'] ⋅ (↑ ∘s σ) ∘s (t ⋅ σ')). +Proof. + intros [|i]. + - now sigma. + - simpl. + 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. + - now sigma. + - rewrite subst_consn_subst_cons. + rewrite subst_cons_compose_r. sigma. + + rewrite (subst_cons_compose_r a + + unfold subst_compose; intros i. simpl. + rewrite subst_compo + rewrite IHl. now rewrite subst_consn_subst_cons. +Qed. *) + +(** The central lemma to show that let expansion commutes with lifting and substitution *) +Lemma subst_reli_lift_id i n t : i <= n -> + subst [tRel i] n (lift (S i) (S n) t) = (lift i n t). +Proof. + intros ltin; sigma; apply inst_ext. + rewrite Upn_eq subst_consn_idsn_shift. + rewrite !ren_lift_renaming. + rewrite -Nat.add_1_r Upn_Upn Upn_compose. + now rewrite Upn_Up /= Upn_0 Up_comp shiftk_unfold. +Qed. + +Lemma subst_context_lift_id Γ k n : n <= k -> subst_context [tRel n] k (lift_context (S n) (S k) Γ) = lift_context n k Γ. +Proof. + intros nk. + rewrite subst_context_alt !lift_context_alt. + rewrite mapi_compose. + apply mapi_ext; len. + intros n' [? [?|] ?]; unfold lift_decl, subst_decl, map_decl; simpl. + * intros. now rewrite !Nat.add_succ_r !subst_reli_lift_id //. + * f_equal. now rewrite !Nat.add_succ_r !subst_reli_lift_id //. +Qed. + +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. + rewrite /expand_lets /expand_lets_k; len. + rewrite extended_subst_app /=. + rewrite subst_app_simpl. simpl. len. + rewrite !Nat.add_1_r. + rewrite subst_context_lift_id // lift0_context. f_equal. + rewrite Nat.add_succ_r. + rewrite subst_reli_lift_id //. + move: (context_assumptions_length_bound Γ); lia. +Qed. + +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 : + 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. + rewrite /expand_lets /expand_lets_k; len. + rewrite extended_subst_app /=. + rewrite subst_app_simpl. simpl. len. + rewrite !subst_empty lift0_id lift0_context. + epose proof (distr_lift_subst_rec _ [b] (context_assumptions Γ) (k + #|Γ|) 0). + rewrite !Nat.add_0_r in H. + f_equal. simpl in H. rewrite Nat.add_assoc. + rewrite <- H. + reflexivity. +Qed. + +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. + rewrite /expand_lets; apply expand_lets_k_vdef. +Qed. + +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. + 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. + rewrite /expand_lets_k_ctx lift_context_app subst_context_app /=; simpl. + unfold app_context. simpl. + rewrite /subst_context /fold_context_k /=. + f_equal. rewrite compose_map_decl. f_equal. +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) = + 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. + - now rewrite /expand_lets_k_ctx /= Nat.add_0_r. + - rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. + rewrite /expand_lets_ctx expand_lets_k_ctx_decl /= it_mkProd_or_LetIn_app. + simpl. f_equal. rewrite app_length /=. + simpl. rewrite Nat.add_1_r Nat.add_succ_r. + now rewrite -(H Δ ltac:(lia) (S k)). + - rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. + rewrite /expand_lets_ctx expand_lets_k_ctx_decl /= it_mkProd_or_LetIn_app. + simpl. f_equal. rewrite app_length /=. + simpl. rewrite Nat.add_1_r Nat.add_succ_r. + now rewrite -(H Δ ltac:(lia) (S k)). +Qed. + +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 : + 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 Γ : + expand_lets Γ (tRel (k + #|Γ|)) = tRel (k + context_assumptions Γ). +Proof. + 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 Γ -> + context_assumptions Γ = #|Γ|. +Proof. + induction 1; simpl; auto. +Qed. + +Lemma assumption_context_app Γ Γ' : + assumption_context (Γ' ,,, Γ) -> + assumption_context Γ * assumption_context Γ'. +Proof. + induction Γ; simpl; split; try constructor; auto. + - depelim H. constructor; auto. now eapply IHΓ. + - depelim H. now eapply IHΓ. +Qed. + +Lemma expand_lets_assumption_context Γ Δ : + assumption_context Γ -> expand_lets_ctx Γ Δ = Δ. +Proof. + induction Γ using rev_ind. + - by rewrite /expand_lets_ctx /expand_lets_k_ctx /= lift0_context subst0_context. + - 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 subst_app_context /=; len. + rewrite subst_context_lift_id // lift0_context. + rewrite (context_assumptions_context assl). simpl. + rewrite !Nat.add_1_r subst_context_lift_id //. + rewrite /expand_lets_ctx /expand_lets_k_ctx in IHΓ. + rewrite (context_assumptions_context assl) in IHΓ . + now simpl in IHΓ. +Qed. + +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 /=; + autorewrite with len; f_equal; auto. + - rewrite IHΓ. + 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 !map_map_compose. apply map_ext. + intros x. + erewrite (commut_lift_subst_rec); lia_f_equal. +Qed. + +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. + rewrite !subst_extended_subst. + rewrite distr_subst. f_equal; len. + now rewrite commut_lift_subst_rec. +Qed. + +Lemma map_expand_lets_subst_comm Γ s : + 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 Γ : + context_assumptions Γ = #|s| -> + subst0 (map (subst0 s) (extended_subst Γ 0)) =1 subst0 s ∘ expand_lets Γ. +Proof. + intros Hs x; unfold expand_lets, expand_lets_k. + rewrite distr_subst. f_equal. + len. + simpl. rewrite simpl_subst_k //. +Qed. + +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. + intros Hs; unfold expand_lets, expand_lets_k. + epose proof (distr_subst_rec _ _ _ 0 _). rewrite -> Nat.add_0_r in H. + rewrite -> H. clear H. f_equal. + len. + simpl. rewrite simpl_subst_k //. +Qed. + +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. + intros Hs. rewrite !subst_context_alt. + unfold expand_lets_ctx, expand_lets_k_ctx. + rewrite subst_context_alt lift_context_alt. len. + rewrite !mapi_compose. apply mapi_ext. + intros n x. unfold subst_decl, lift_decl. + rewrite !compose_map_decl. apply map_decl_ext. + intros. simpl. rewrite !Nat.add_0_r. + generalize (Nat.pred #|Δ| - n). intros. + rewrite map_subst_expand_lets_k //. +Qed. + +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. + intros Hs. rewrite !subst_context_alt. + unfold expand_lets_ctx, expand_lets_k_ctx. + rewrite subst_context_alt lift_context_alt. len. + rewrite !mapi_compose. apply mapi_ext. + intros n x. unfold subst_decl, lift_decl. + rewrite !compose_map_decl. apply map_decl_ext. + intros. simpl. + rewrite map_subst_expand_lets_k //. f_equal. + rewrite /expand_lets_k. lia_f_equal. +Qed. + +Local Open Scope sigma_scope. + +Lemma inst_extended_subst_shift (Γ : context) k : + map (inst ((extended_subst Γ 0 ⋅n ids) ∘s ↑^k)) (idsn #|Γ|) = + map (inst (extended_subst Γ k ⋅n ids)) (idsn #|Γ|). +Proof. + intros. + rewrite !map_idsn_spec. + apply nat_recursion_ext => x l' Hx. + f_equal. f_equal. simpl. rewrite subst_consn_compose. + rewrite (@subst_consn_lt (extended_subst Γ k) x); len; try lia. + rewrite subst_consn_lt; len; try lia. + rewrite (lift_extended_subst _ k). now sigma. +Qed. + +Lemma subst_context_decompo s s' Γ k : + subst_context (s ++ s') k Γ = + subst_context s' k (subst_context (map (lift0 #|s'|) s) k Γ). +Proof. + intros. + rewrite !subst_context_alt !mapi_compose. + apply mapi_ext => i x. + destruct x as [na [b|] ty] => //. + - rewrite /subst_decl /map_decl /=; f_equal. + + rewrite !mapi_length. f_equal. + now rewrite subst_app_decomp. + + rewrite mapi_length. + now rewrite subst_app_decomp. + - rewrite /subst_decl /map_decl /=; f_equal. + rewrite !mapi_length. now rewrite subst_app_decomp. +Qed. + +Lemma fold_context_k_compose f g Γ : + fold_context_k f (fold_context_k g Γ) = fold_context_k (fun n x => f n (g n x)) Γ. +Proof. + induction Γ; simpl; auto; rewrite !fold_context_k_snoc0. + simpl. rewrite IHΓ. f_equal. + rewrite compose_map_decl. + now rewrite fold_context_k_length. +Qed. + +Lemma smash_context_app Δ Γ Γ' : + smash_context Δ (Γ ++ Γ') = smash_context (smash_context Δ Γ) Γ'. +Proof. + revert Δ; induction Γ as [|[na [b|] ty]]; intros Δ; simpl; auto. +Qed. + +Lemma smash_context_acc Γ Δ : + smash_context Δ Γ = + subst_context (extended_subst Γ 0) 0 (lift_context (context_assumptions Γ) #|Γ| Δ) + ++ smash_context [] Γ. +Proof. + revert Δ. + induction Γ as [|[? [] ?] ?]; intros Δ. + - simpl; auto. + now rewrite subst0_context app_nil_r lift0_context. + - simpl. autorewrite with len. + rewrite IHΓ; auto. + rewrite subst_context_nil. f_equal. + rewrite (subst_context_decompo [_] _). + simpl. autorewrite with len. + rewrite lift0_id. + rewrite subst0_context. + unfold subst_context, lift_context. + rewrite !fold_context_k_compose. + apply fold_context_k_ext. intros n x. + rewrite Nat.add_0_r. + autorewrite with sigma. + apply inst_ext. + setoid_rewrite ren_lift_renaming. + autorewrite with sigma. + rewrite !Upn_compose. + apply Upn_ext. + autorewrite with sigma. + unfold Up. + rewrite subst_consn_subst_cons. + autorewrite with sigma. + reflexivity. + + - simpl. + rewrite IHΓ /=. auto. + rewrite (IHΓ [_]). auto. rewrite !app_assoc. f_equal. + rewrite app_nil_r. unfold map_decl. simpl. unfold app_context. + simpl. rewrite lift_context_app subst_context_app /app_context. simpl. + unfold lift_context at 2. unfold subst_context at 2, fold_context_k. simpl. + f_equal. + unfold subst_context, lift_context. + rewrite !fold_context_k_compose. + apply fold_context_k_ext. intros n x. + rewrite Nat.add_0_r. + + autorewrite with sigma. + apply inst_ext. rewrite !ren_lift_renaming. + autorewrite with sigma. + rewrite !Upn_compose. + autorewrite with sigma. + apply Upn_ext. + unfold Up. + + rewrite subst_consn_subst_cons. + autorewrite with sigma. + apply subst_cons_proper; auto. + rewrite !Upn_eq. autorewrite with sigma. + rewrite subst_consn_compose. + setoid_rewrite subst_consn_compose at 2 3. + apply subst_consn_proper. + { rewrite -inst_extended_subst_shift; auto. } + + autorewrite with sigma. + rewrite -subst_compose_assoc. + rewrite shiftk_compose. + autorewrite with sigma. + setoid_rewrite <- (compose_ids_l ↑) at 2. + rewrite -subst_consn_compose. + rewrite - !subst_compose_assoc. + rewrite -shiftk_shift shiftk_compose. + autorewrite with sigma. + rewrite subst_consn_compose. + rewrite -shiftk_compose subst_compose_assoc. + rewrite subst_consn_shiftn. + 2:now autorewrite with len. + autorewrite with sigma. + rewrite -shiftk_shift. + rewrite -shiftk_compose subst_compose_assoc. + rewrite subst_consn_shiftn. + 2:now autorewrite with len. + now autorewrite with sigma. +Qed. + +Lemma shift_subst_consn_ge (n : nat) (l : list term) (σ : nat -> term) : + #|l| <= n -> ↑^n ∘s (l ⋅n σ) =1 ↑^(n - #|l|) ∘s σ. +Proof. + intros Hlt i. + rewrite /subst_compose /shiftk /=. + rewrite subst_consn_ge; try lia. lia_f_equal. +Qed. + +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. + destruct nth_error => //. + rewrite List.skipn_length. lia_f_equal. +Qed. + +Lemma subst_shift_comm k n s : ⇑^k s ∘s ↑^n =1 ↑^n ∘s ⇑^(k+n) s. +Proof. + now rewrite Nat.add_comm Upn_Upn shiftn_Upn. +Qed. + +Lemma Upn_subst_consn_ge (n i : nat) s (σ : nat -> term) : + n + #|s| <= i -> (⇑^n (s ⋅n σ)) i = (σ ∘s ↑^n) (i - n - #|s|). +Proof. + intros Hlt. + rewrite /subst_compose /shiftk /= /Upn. + rewrite subst_consn_ge; len; try lia. + now rewrite subst_consn_compose subst_consn_ge; len; try lia. +Qed. + +Lemma Upn_subst_consn_lt (n i : nat) s (σ : nat -> term) : + i < n + #|s| -> (⇑^n (s ⋅n σ)) i = (idsn n ⋅n (subst_fn s ∘s ↑^n)) i. +Proof. + intros Hlt. + rewrite /subst_compose /shiftk /= /Upn. + destruct (leb_spec_Set (S i) n). + * rewrite subst_consn_lt; len; try lia. + now rewrite subst_consn_lt; len; try lia. + * rewrite subst_consn_ge; len; try lia. + rewrite subst_consn_ge; len; try lia. + rewrite subst_consn_compose subst_fn_subst_consn. + rewrite !subst_consn_lt; len; try lia. + unfold subst_fn. rewrite nth_error_map. + case:nth_error_spec => /= // hlen. len. + lia. +Qed. + +Hint Rewrite ren_lift_renaming subst_consn_compose : sigma. \ No newline at end of file diff --git a/pcuic/theories/PCUICSize.v b/pcuic/theories/PCUICSize.v index c8f977bca..6aa4f0947 100644 --- a/pcuic/theories/PCUICSize.v +++ b/pcuic/theories/PCUICSize.v @@ -1,7 +1,7 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import utils. From MetaCoq.PCUIC Require Import PCUICAst. - +From Coq Require Import ssreflect. Definition def_size (size : term -> nat) (x : def term) := size (dtype x) + size (dbody x). @@ -13,6 +13,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) := + context_size size br.(bcontext) + size br.(bbody). + +Definition predicate_size (size : term -> nat) (p : PCUICAst.predicate term) := + list_size size p.(pparams) + + context_size size p.(pcontext) + + size p.(preturn). Fixpoint size t : nat := match t with @@ -22,9 +30,25 @@ Fixpoint size t : nat := | tApp u v => S (size u + size v) | tProd na A B => S (size A + size B) | tLetIn na b t b' => S (size b + size t + size b') - | tCase ind p c brs => S (size p + size c + list_size (fun x => size (snd x)) brs) + | tCase ind p c brs => S (predicate_size size p + + size c + list_size (branch_size size) brs) | tProj p c => S (size c) | tFix mfix idx => S (mfixpoint_size size mfix) | tCoFix mfix idx => S (mfixpoint_size size mfix) | x => 1 end. + +Lemma size_mkApps f l : size (mkApps f l) = size f + list_size size l. +Proof. + induction l in f |- *; simpl; try lia. + rewrite IHl. simpl. lia. +Qed. + +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. +Proof. + induction l in n |- *; destruct n; simpl => //; auto. + - intros [= <-]. lia. + - intros hnth. specialize (IHl _ hnth). lia. +Qed. diff --git a/pcuic/theories/PCUICSpine.v b/pcuic/theories/PCUICSpine.v index b116d3b3a..1e8e0c391 100644 --- a/pcuic/theories/PCUICSpine.v +++ b/pcuic/theories/PCUICSpine.v @@ -1,16 +1,14 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import CRelationClasses ProofIrrelevance. -From MetaCoq.Template Require Import config Universes utils BasicAst - AstUtils UnivSubst. +From MetaCoq.Template Require Import config Universes utils BasicAst. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction PCUICReflect PCUICLiftSubst PCUICSigmaCalculus PCUICUnivSubst PCUICTyping PCUICUnivSubstitution - PCUICCumulativity PCUICPosition PCUICEquality PCUICNameless + PCUICCumulativity PCUICPosition PCUICEquality PCUICInversion PCUICCumulativity PCUICReduction PCUICConfluence PCUICConversion PCUICContextConversion - PCUICParallelReductionConfluence PCUICWeakeningEnv - PCUICClosed PCUICSubstitution - PCUICWeakening PCUICGeneration PCUICUtils PCUICCtxShape PCUICContexts + PCUICWeakeningEnv PCUICClosed PCUICSubstitution PCUICContextSubst + PCUICWeakening PCUICGeneration PCUICUtils PCUICContexts PCUICArities. From Equations Require Import Equations. @@ -18,9 +16,40 @@ Require Import Equations.Prop.DepElim. Require Import Equations.Type.Relation_Properties. Require Import ssreflect. +Implicit Types (cf : checker_flags) (Σ : global_env_ext). + Derive Signature for ctx_inst. - -Notation ctx_inst Σ Γ i Δ := (ctx_inst (lift_typing typing) Σ Γ i Δ). + +Notation ctx_inst := (ctx_inst typing). + +Definition lengths := + (@context_assumptions_expand_lets_ctx, @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, + @map_length, @mapi_length, @mapi_rec_length, + @fold_context_k_length, @cofix_subst_length, @fix_subst_length, + @smash_context_length, @context_assumptions_smash_context, + @arities_context_length). + +Ltac trylia := + lazymatch goal with + | [|- @eq nat _ _] => try lia + | [|- @eq term _ _] => try solve [lia_f_equal] + | [|- _ <= _] => try lia + | [|- _ < _ ] => try lia + | [|- _ >= _] => try lia + | [|- _ > _ ] => try lia + | _ => idtac + end. + +Ltac len ::= try rewrite !lengths /= // ?lengths; trylia. +Tactic Notation "len" "in" hyp(cl) := rewrite !lengths /= // ?lengths in cl. + +Notation "'lens'" := (ltac:(len)) (only parsing) : ssripat_scope. Lemma typing_spine_eq {cf:checker_flags} Σ Γ ty s s' ty' : s = s' -> @@ -92,11 +121,11 @@ Lemma untyped_subslet_eq_subst Γ s s' Δ : untyped_subslet Γ s' Δ. Proof. now intros H ->. Qed. -Lemma context_subst_app_inv {ctx ctx' : list PCUICAst.context_decl} {args s : list term} : +Lemma context_subst_app_inv {ctx ctx' : context} {args s : list term} : context_subst (subst_context (skipn #|ctx| s) 0 ctx) - (skipn (PCUICAst.context_assumptions ctx') args) + (skipn (context_assumptions ctx') args) (firstn #|ctx| s) - × context_subst ctx' (firstn (PCUICAst.context_assumptions ctx') args) (skipn #|ctx| s) -> + × context_subst ctx' (firstn (context_assumptions ctx') args) (skipn #|ctx| s) -> context_subst (ctx ++ ctx') args s. Proof. move=> [Hl Hr]. @@ -137,24 +166,22 @@ Proof. apply IHctx => //. Qed. - Lemma ctx_inst_inst {cf:checker_flags} Σ ext u Γ i Δ : wf_global_ext Σ.1 ext -> ctx_inst (Σ.1, ext) Γ i Δ -> consistent_instance_ext Σ ext u -> - ctx_inst Σ (subst_instance_context u Γ) - (map (subst_instance_constr u) i) - (subst_instance_context u Δ). + ctx_inst Σ (subst_instance u Γ) + (map (subst_instance u) i) + (subst_instance u Δ). Proof. intros wfext ctxi cu. induction ctxi; simpl; constructor; auto. - * red in p |- *. - destruct Σ as [Σ univs]. + * destruct Σ as [Σ univs]. eapply (typing_subst_instance'' Σ); eauto. apply wfext. apply wfext. - * rewrite (subst_telescope_subst_instance_constr u [i]). + * rewrite (subst_telescope_subst_instance u [i]). apply IHctxi. - * rewrite (subst_telescope_subst_instance_constr u [b]). + * rewrite (subst_telescope_subst_instance u [b]). apply IHctxi. Qed. @@ -248,7 +275,7 @@ Proof. specialize (IHc _ c'). now subst. Qed. -Inductive arity_spine {cf : checker_flags} (Σ : PCUICAst.global_env_ext) (Γ : PCUICAst.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' -> @@ -319,7 +346,7 @@ Proof. -- rewrite app_length /= in len. rewrite it_mkProd_or_LetIn_app in Hsp. destruct x as [na [b|] ty]; simpl in *; rewrite /mkProd_or_LetIn /= in Hsp. - + rewrite PCUICCtxShape.context_assumptions_app /= Nat.add_0_r. + + rewrite context_assumptions_app /= Nat.add_0_r. eapply typing_spine_letin_inv in Hsp; auto. rewrite /subst1 subst_it_mkProd_or_LetIn /= in Hsp. specialize (IHn (subst_context [b] 0 l)). @@ -350,7 +377,7 @@ Proof. repeat constructor. rewrite app_context_assoc in wfΓ'. simpl in wfΓ'. apply wf_local_app_l in wfΓ'. depelim wfΓ'; now rewrite !subst_empty. - + rewrite PCUICCtxShape.context_assumptions_app /=. + + rewrite context_assumptions_app /=. depelim Hsp. now eapply cumul_Prod_Sort_inv in c. eapply cumul_Prod_inv in c as [conva cumulB]. @@ -393,6 +420,24 @@ Proof. eapply type_Cumul'; eauto. eapply conv_cumul. now symmetry. Qed. +Lemma make_context_subst_skipn {Γ args s s'} : + make_context_subst Γ args s = Some s' -> + skipn #|Γ| s' = s. +Proof. + induction Γ in args, s, s' |- *. + - destruct args; simpl; auto. + + now intros [= ->]. + + now discriminate. + - destruct a as [na [b|] ty]; simpl. + + intros H. + specialize (IHΓ _ _ _ H). + now eapply skipn_n_Sn. + + destruct args; try discriminate. + intros Hsub. + specialize (IHΓ _ _ _ Hsub). + now eapply skipn_n_Sn. +Qed. + Lemma typing_spine_it_mkProd_or_LetIn_gen {cf:checker_flags} Σ Γ Δ Δ' T args s s' args' T' : wf Σ.1 -> make_context_subst (List.rev Δ) args s' = Some s -> @@ -545,23 +590,22 @@ Lemma spine_subst_conv {cf:checker_flags} Σ Γ inst insts Δ inst' insts' Δ' : wf Σ.1 -> spine_subst Σ Γ inst insts Δ -> spine_subst Σ Γ inst' insts' Δ' -> - context_relation (fun Δ Δ' => conv_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ' -> + All2_fold (fun Δ Δ' => conv_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ' -> All2 (conv Σ Γ) inst inst' -> All2 (conv Σ Γ) insts insts'. Proof. -move=> wfΣ [_ wf cs sl] [_ _ cs' sl'] cv. -move: inst insts cs wf sl inst' insts' cs' sl'. -induction cv; intros; depelim cs ; depelim cs'. -- constructor; auto. -- eapply All2_app_inv in X as [[l1 l2] [[? ?] ?]]. - depelim a2. depelim a2. apply app_inj_tail in e as [? ?]; subst. - depelim sl; depelim sl'; depelim wf. - specialize (IHcv _ _ cs wf sl _ _ cs' sl' a1). - constructor; auto. -- depelim sl; depelim sl'; depelim wf. - specialize (IHcv _ _ cs wf sl _ _ cs' sl' X). - constructor; auto. - eapply (subst_conv _ _ _ []); eauto. - depelim p; pcuic. + move=> wfΣ [_ wf cs sl] [_ _ cs' sl'] cv. + move: inst insts cs wf sl inst' insts' cs' sl'. + induction cv; intros; depelim cs; depelim cs'. + 1:constructor; auto. + all:depelim p. + - apply All2_app_r in X as (?&?). + depelim sl; depelim sl'; depelim wf. + specialize (IHcv _ _ cs wf sl _ _ cs' sl' a1). + constructor; auto. + - depelim sl; depelim sl'; depelim wf. + specialize (IHcv _ _ cs wf sl _ _ cs' sl' X). + constructor; auto. + eapply (subst_conv _ _ _ []); eauto. Qed. Lemma spine_subst_subst {cf:checker_flags} Σ Γ Γ0 Γ' i s Δ sub : @@ -655,57 +699,69 @@ Proof. now rewrite app_context_assoc in wfcodom. Qed. +Lemma spine_subst_smash_app_inv {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ' δ δ'} : + #|δ| = context_assumptions Δ -> + 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. + intros hδ sp. + rewrite smash_context_app_expand in sp. + eapply spine_subst_app_inv in sp; eauto. + 2:{ rewrite context_assumptions_smash_context /= //. } + rewrite expand_lets_ctx_length smash_context_length /= in sp. + destruct sp as [sppars spidx]. + assert (lenidx : context_assumptions Δ' = #|δ'|). + { pose proof (PCUICContextSubst.context_subst_length2 spidx). len in H. } + assert (firstn (context_assumptions Δ') + (List.rev (δ ++ δ')) = List.rev δ'). + { rewrite List.rev_app_distr. + now rewrite (firstn_app_left _ 0); + rewrite /= ?app_nil_r // Nat.add_0_r List.rev_length. } + assert (skipn (context_assumptions Δ') + (List.rev (δ ++ δ')) = List.rev δ). + { rewrite List.rev_app_distr. + erewrite (skipn_all_app_eq) => //; rewrite List.rev_length //. } + rewrite H H0 in spidx, sppars. + split => //. +Qed. + Lemma spine_subst_inst {cf:checker_flags} Σ ext u Γ i s Δ : wf Σ.1 -> wf_global_ext Σ.1 ext -> spine_subst (Σ.1, ext) Γ i s Δ -> consistent_instance_ext Σ ext u -> - spine_subst Σ (subst_instance_context u Γ) - (map (subst_instance_constr u) i) - (map (subst_instance_constr u) s) - (subst_instance_context u Δ). + spine_subst Σ (subst_instance u Γ) + (map (subst_instance u) i) + (map (subst_instance u) s) + (subst_instance u Δ). Proof. intros wfΣ wfext [wfdom wfcodom cs subsl] cu. split. eapply wf_local_subst_instance; eauto. - rewrite -subst_instance_context_app. + rewrite -subst_instance_app_ctx. eapply wf_local_subst_instance; eauto. clear -cs cu wfext wfΣ. induction cs; simpl; rewrite ?map_app; try constructor; auto. - simpl. - rewrite -subst_subst_instance_constr. + rewrite subst_instance_cons; simpl. + rewrite subst_instance_subst. constructor; auto. clear -subsl cu wfΣ wfext. - induction subsl; simpl; rewrite -?subst_subst_instance_constr; constructor; auto. + induction subsl; simpl; rewrite ?subst_instance_subst; constructor; auto. * destruct Σ as [Σ univs]. - rewrite subst_subst_instance_constr. + rewrite -subst_instance_subst. eapply (typing_subst_instance'' Σ); simpl; auto. apply wfext. simpl in wfext. apply t0. apply wfext. auto. - * rewrite !subst_subst_instance_constr. simpl. + * rewrite - !subst_instance_subst. simpl. destruct Σ as [Σ univs]. eapply (typing_subst_instance'' Σ); simpl; auto. apply wfext. simpl in wfext. apply t0. apply wfext. auto. Qed. -Lemma subslet_lift {cf:checker_flags} Σ (Γ Δ : context) s Δ' : - wf Σ.1 -> wf_local Σ (Γ ,,, Δ) -> - subslet Σ Γ s Δ' -> - subslet Σ (Γ ,,, Δ) (map (lift0 #|Δ|) s) (lift_context #|Δ| 0 Δ'). -Proof. - move=> wfΣ wfl. - induction 1; rewrite ?lift_context_snoc /=; try constructor; auto. - simpl. - rewrite -(subslet_length X). - rewrite -distr_lift_subst. apply weakening; eauto. - - rewrite -(subslet_length X). - rewrite distr_lift_subst. constructor; auto. - rewrite - !distr_lift_subst. apply weakening; eauto. -Qed. - Lemma spine_subst_weakening {cf:checker_flags} Σ Γ i s Δ Γ' : wf Σ.1 -> wf_local Σ (Γ ,,, Γ') -> @@ -739,7 +795,7 @@ Proof. induction ctxinst in sub, subs |- *. - simpl; intros; constructor; auto. - intros. rewrite subst_telescope_cons; simpl; constructor. - * red in p |- *. simpl. eapply substitution; eauto. + * simpl. eapply substitution; eauto. * specialize (IHctxinst _ subs). now rewrite (subst_telescope_comm [i]). - intros. rewrite subst_telescope_cons; simpl; constructor. @@ -755,7 +811,7 @@ Lemma ctx_inst_weaken {cf:checker_flags} Σ Γ i Δ Γ' : Proof. move=> wfΣ wfl subl. induction subl; constructor; auto. - red in p |- *. now eapply (weaken_ctx Γ'). + now eapply (weaken_ctx Γ'). Qed. Lemma make_context_subst_tele s s' Δ inst sub : @@ -806,12 +862,15 @@ Proof. 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 Δ) = context_assumptions Δ. Proof. rewrite /subst_telescope /mapi. generalize 0. induction Δ; simpl; auto. - destruct a as [na [b|] ty]; 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 Γ : @@ -891,30 +950,45 @@ Proof. rewrite -H1. now rewrite firstn_skipn. Qed. -Lemma isType_Sort {cf:checker_flags} {Σ Γ s} : - wf_universe Σ s -> - wf_local Σ Γ -> - isType Σ Γ (tSort s). +Lemma arity_spine_it_mkProd_or_LetIn_Sort {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ ctx s s' args inst : + wf_universe Σ s' -> + leq_universe Σ s s' -> + spine_subst Σ Γ args inst ctx -> + arity_spine Σ Γ (it_mkProd_or_LetIn ctx (tSort s)) args (tSort s'). Proof. - intros wfs wfΓ. - eexists; econstructor; eauto. + intros wfs le sp. rewrite -(app_nil_r args). + eapply arity_spine_it_mkProd_or_LetIn => //. + eauto. constructor. + eapply isType_Sort; eauto. + eapply sp. simpl. constructor. now constructor. Qed. -Hint Resolve @isType_Sort : pcuic. +Lemma ctx_inst_subst_length {cf:checker_flags} {Σ Γ} {Δ : context} {args} (c : ctx_inst Σ Γ args Δ) : + #|ctx_inst_sub c| = #|Δ|. +Proof. + induction c; simpl; auto; try lia; + rewrite app_length IHc subst_telescope_length /=; lia. +Qed. -Lemma arity_spine_it_mkProd_or_LetIn_Sort {cf:checker_flags} Σ Γ ctx s args inst : - wf Σ.1 -> wf_universe Σ s -> - spine_subst Σ Γ args inst ctx -> - arity_spine Σ Γ (it_mkProd_or_LetIn ctx (tSort s)) args (tSort s). +Lemma ctx_inst_app {cf} {Σ Γ} {Δ : context} {Δ' args args'} + (dom : ctx_inst Σ Γ args Δ) : + ctx_inst Σ Γ args' (subst_telescope (ctx_inst_sub dom) 0 Δ') -> + ctx_inst Σ Γ (args ++ args') (Δ ++ Δ'). Proof. - intros wfΣ wfs sp. rewrite -(app_nil_r args). - eapply arity_spine_it_mkProd_or_LetIn => //. - eauto. constructor. - (* eapply isType_Sort; eauto. - eapply sp. simpl. reflexivity. *) + induction dom in args', Δ' |- *; simpl. + - now rewrite subst_telescope_empty. + - rewrite subst_app_telescope /= ctx_inst_subst_length /= subst_telescope_length Nat.add_0_r /=. + move/IHdom => IH. + constructor => //. + now rewrite subst_telescope_app Nat.add_0_r. + - rewrite subst_app_telescope /= ctx_inst_subst_length /= subst_telescope_length Nat.add_0_r /=. + move/IHdom => IH. + constructor => //. + now rewrite subst_telescope_app Nat.add_0_r. Qed. -Lemma ctx_inst_app {cf:checker_flags} {Σ Γ} {Δ : context} {Δ' args} (c : ctx_inst Σ Γ args (Δ ++ Δ')) : +Lemma ctx_inst_app_inv {cf:checker_flags} {Σ Γ} {Δ : 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 Δ'). Proof. @@ -958,18 +1032,11 @@ Proof. intros -> ->. induction c; depelim d; auto; simpl in *; now rewrite (IHc d). Qed. -Lemma ctx_inst_subst_length {cf:checker_flags} {Σ Γ} {Δ : context} {args} (c : ctx_inst Σ Γ args Δ) : - #|ctx_inst_sub c| = #|Δ|. -Proof. - induction c; simpl; auto; try lia; - rewrite app_length IHc subst_telescope_length /=; lia. -Qed. - -Lemma ctx_inst_app_len {cf:checker_flags} {Σ Γ} {Δ : context} {Δ' args} (c : ctx_inst Σ Γ args (Δ ++ Δ')) : - let (dom, codom) := ctx_inst_app c in +Lemma ctx_inst_app_sub {cf:checker_flags} {Σ Γ} {Δ : context} {Δ' args} (c : ctx_inst Σ Γ args (Δ ++ Δ')) : + let (dom, codom) := ctx_inst_app_inv c in ctx_inst_sub c = ctx_inst_sub codom ++ ctx_inst_sub dom. Proof. - destruct (ctx_inst_app c). + destruct (ctx_inst_app_inv c). induction Δ using ctx_length_ind in Δ', c, x, args, c0 |- *. simpl in *. depelim x. simpl in *. rewrite app_nil_r; apply ctx_inst_sub_eq. now rewrite skipn_0. now rewrite subst_telescope_empty. @@ -1021,23 +1088,22 @@ Proof. depelim c. exists i; constructor; auto. Qed. -Lemma ctx_inst_spine_subst {cf:checker_flags} Σ Γ Δ args : - wf Σ.1 -> wf_local Σ Γ -> +Lemma ctx_inst_spine_subst {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ args} : wf_local Σ (Γ ,,, Δ) -> forall ci : ctx_inst Σ Γ args (List.rev Δ), spine_subst Σ Γ args (ctx_inst_sub ci) Δ. Proof. - move=> wfΣ wfΓ wfΔ ci. + move=> wfΔ ci. pose proof (ctx_inst_sub_spec ci) as msub. eapply make_context_subst_spec in msub. rewrite List.rev_involutive in msub. - split; auto. + split; pcuic. now eapply wf_local_app_inv in wfΔ as []. move: ci msub. induction Δ in wfΔ, args |- *. simpl. intros ci. depelim ci. constructor. intros. simpl in ci. - pose proof (ctx_inst_app_len ci). - destruct (ctx_inst_app ci). rewrite H in msub |- *. + pose proof (ctx_inst_app_sub ci). + destruct (ctx_inst_app_inv ci). rewrite H in msub |- *. clear ci H. simpl in c. apply (@context_subst_app [a]) in msub. @@ -1062,10 +1128,10 @@ Proof. specialize (IHΔ _ wfΔ _ subr). constructor; auto. Qed. -Lemma subst_instance_context_rev u Γ : - subst_instance_context u (List.rev Γ) = List.rev (subst_instance_context u Γ). +Lemma subst_instance_rev u Γ : + subst_instance u (List.rev Γ) = List.rev (subst_instance u Γ). Proof. - now rewrite /subst_instance_context /map_context List.map_rev. + now rewrite /subst_instance /subst_instance_context /= /map_context List.map_rev. Qed. Lemma subst_telescope_subst_context s k Γ : @@ -1107,18 +1173,14 @@ Proof. now rewrite subst_app_simpl. Qed. -Lemma closed_ctx_subst n k ctx : closedn_ctx k ctx = true -> subst_context n k ctx = ctx. +Lemma closed_k_ctx_subst n k ctx : closedn_ctx k ctx = true -> subst_context n k ctx = ctx. Proof. induction ctx in n, k |- *; auto. - unfold closed_ctx, id. - rewrite mapi_app forallb_app List.rev_length /= Nat.add_0_r. - move/andb_and => /= [Hctx /andb_and [Ha _]]. + simpl. + move/andb_and => /= [Hctx Hd]. rewrite subst_context_snoc /snoc /= IHctx // subst_decl_closed //. - now apply: closed_decl_upwards. Qed. - - Fixpoint all_rels (Γ : context) (n : nat) (k : nat) := match Γ with | nil => nil @@ -1197,6 +1259,262 @@ Proof. now rewrite -IHc. Qed. +(*Open Scope sigma_scope. +From Equations.Type Require Import Relation. +From MetaCoq.PCUIC Require Import PCUICInst PCUICRename PCUICOnFreeVars PCUICParallelReduction. + +Lemma red_inst {cf:checker_flags} {Σ} {wfΣ : wf Σ} Δ Γ σ t u : + usubst Γ σ Δ -> + red Σ Γ t u -> + red Σ Δ t.[σ] u.[σ]. +Proof. + intros us. + induction 1. + - now eapply red1_inst. + - reflexivity. + - etransitivity; tea. +Qed. + +(* Lemma strong_substitutivity_clos_rt {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ s t} σ τ : + ctxmap Γ Δ σ -> + ctxmap Γ Δ τ -> + pred1_subst Σ Γ Δ Δ σ τ -> + clos_refl_trans (pred1 Σ Γ Γ) s t -> + clos_refl_trans (pred1 Σ Δ Δ) s.[σ] t.[τ]. +Proof. + +Lemma red_strong_substitutivity {cf:checker_flags} {Σ} {wfΣ : wf Σ} Γ Δ s t σ τ : + red Σ Γ s t -> + ctxmap Γ Δ σ -> + ctxmap Γ Δ τ -> + (forall x, red Σ Γ (σ x) (τ x)) -> + red Σ Δ s.[σ] t.[τ]. +Proof. + intros r ctxm ctxm' IH. + eapply red_pred in r; eauto. + eapply (strong_substitutivity_clos_rt σ τ) in r; tea. + - eapply pred_red => //. + - intros x. *) + +Lemma red_meta_conv Σ Γ t u t' u' : + red Σ Γ t' u' -> t' = t -> u' = u -> + red Σ Γ t u. +Proof. now intros r -> ->. Qed. + +Definition red_subst Σ Γ (σ σ' : nat -> term) := + forall x, red Σ Γ (σ x) (σ' x). + +Lemma red_on_free_vars {cf} {P : nat -> bool} {Σ Γ u v} {wfΣ : wf Σ} : + on_free_vars P u -> + on_ctx_free_vars P Γ -> + red Σ Γ u v -> + on_free_vars P v. +Proof. + intros on onΓ r. + induction r; auto. + now eapply red1_on_free_vars. +Qed. + +Lemma red_rename {cf} : + forall P Σ Γ Δ u v f, + wf Σ -> + (*on_ctx_free_vars P Γ -> *) + urenaming P Δ Γ f -> + on_free_vars P u -> + red Σ Γ u v -> + red Σ Δ (rename f u) (rename f v). +Proof. + intros. + induction X1. + - constructor. now eapply red1_rename. + - reflexivity. + - etransitivity. eapply IHX1_1; eauto. + eapply IHX1_2. eapply red_on_free_vars; eauto. + admit. +Abort. + +Lemma usubst_up Γ d : usubst Γ ↑ (Γ ,, d). +Proof. + intros x decl nth b hb. + unfold shift. left. + exists (S x), decl. splits; auto. + sigma. rewrite hb /=. f_equal. +Qed. + +Lemma red_subst_up {cf} {Σ} {wfΣ : wf Σ} Γ (σ σ' : nat -> term) d : + red_subst Σ Γ σ σ' -> + red_subst Σ (Γ ,, d) (up 1 σ) (up 1 σ'). +Proof. + intros r x. + unfold up. destruct Nat.leb. 2:reflexivity. + eapply red_meta_conv. 2-3:sigma; reflexivity. + destruct d as [na [d|] ty]. + eapply red_inst; tea. + 2:eapply r. eapply usubst_up. + eapply red_inst; tea. + 2:eapply r. eapply usubst_up. +Qed. + +Lemma red_subst_upn {cf} {Σ} {wfΣ : wf Σ} Γ (σ σ' : nat -> term) Δ : + red_subst Σ Γ σ σ' -> + red_subst Σ (Γ ,,, Δ) (up #|Δ| σ) (up #|Δ| σ'). +Proof. + induction Δ; simpl. + intros r x. specialize (r x). + eapply red_meta_conv; sigma. 2-3:reflexivity. assumption. + intros r h. rewrite -(up_up 1) -(up_up 1 #|Δ|). + now eapply red_subst_up. +Qed. + +Lemma red_red_onctx {cf:checker_flags} Σ {wfΣ : wf Σ} Δ σ σ' ctx : + red_subst Σ Δ σ σ' -> + onctx + (fun b : term => + forall Δ σ σ', + red_subst Σ Δ σ σ' -> + red Σ Δ b.[σ] b.[σ']) ctx -> + All2_fold + (fun (Γ0 Δ0 : context) (d d' : context_decl) => + red_decls Σ (Δ ,,, mapi_context (fun k => inst (up k σ)) Γ0) + (Δ ,,, mapi_context (fun k => inst (up k σ')) Δ0) + (map_decl (inst (up #|Γ0| σ)) d) + (map_decl (inst (up #|Γ0| σ')) d')) ctx ctx. +Proof. + intros hsubs. + induction 1; constructor; auto. + destruct p. destruct x as [na [b|] ty]; constructor; auto; simpl in *; + rewrite /shiftf. + - eapply o. relativize #|l|. + now eapply red_subst_upn. rewrite mapi_context_length. len. + - eapply r. relativize #|l|. + now eapply red_subst_upn. rewrite mapi_context_length. len. + - eapply r. relativize #|l|. + now eapply red_subst_upn. rewrite mapi_context_length. len. +Qed. + +Lemma red_red_inst {cf:checker_flags} (Σ : global_env_ext) Δ σ σ' b : wf Σ -> + (red_subst Σ Δ σ σ') -> + red Σ Δ b.[σ] b.[σ']. +Proof. + intros wfΣ Hsubs. + revert Δ σ σ' Hsubs. + elim b using term_forall_list_ind; + intros; match goal with + |- context [tRel _] => idtac + | |- _ => cbn -[plus] + end; try easy; + autorewrite with map; + rewrite ?Nat.add_assoc; + try solve [f_equal; auto; solve_all]. + + - apply red_evar. apply All2_map. solve_all. + - apply red_prod; eauto. eapply X0. + now eapply red_subst_up. + + - apply red_abs; eauto using red_subst_up. + + - apply red_letin; eauto using red_subst_up. + - apply red_app; eauto. + - eapply (red_case (p:=(inst_predicate σ p))); simpl; solve_all. + * rewrite mapi_context_inst. eapply r. + relativize #|pcontext p|. + now eapply red_subst_upn. now len. + * eapply PCUICContextReduction.red_ctx_rel_red_context_rel => //. + red. + eapply PCUICContextRelation.All2_fold_mapi. + eapply red_red_onctx; tea. + * red. solve_all. + eapply All_All2; tea => /=. solve_all; unfold on_Trel; simpl. + + eapply b0. relativize #|bcontext x|. + eapply red_subst_upn; tea. + now rewrite mapi_context_length. + + eapply PCUICContextReduction.red_ctx_rel_red_context_rel => //. + eapply PCUICContextRelation.All2_fold_mapi. + eapply red_red_onctx; tea. + - apply red_proj_c; eauto. + - apply red_fix_congr; eauto. + solve_all. eapply All_All2; tea; simpl; solve_all. + eapply b0. rewrite inst_fix_context_up. + relativize #|m|. + now eapply red_subst_upn. len. + - apply red_cofix_congr; eauto. + red in X. solve_all. eapply All_All2; tea; simpl; solve_all. + eapply b0. + rewrite inst_fix_context_up. + relativize #|m|. + now eapply red_subst_upn. len. +Qed. +Lemma all_rels_subst {cf:checker_flags} Σ Δ Γ t : + wf Σ.1 -> wf_local Σ (Γ ,,, Δ) -> + red Σ.1 (Γ ,,, Δ) t (subst0 (all_rels Δ 0 #|Δ|) (lift #|Δ| #|Δ| t)). +Proof. + intros wfΣ wfΓ. + sigma. rewrite -{1}(subst_ids t). + eapply red_red_inst; tea. + intros x. rewrite {1}/ids. + unfold subst_compose. + rewrite /ren /lift_renaming. + destruct (leb_spec_Set #|Δ| x); simpl. + **simpl. unfold Upn. simpl. unfold subst_consn. rewrite nth_error_nil. + simpl. unfold subst_compose. simpl. rewrite Nat.sub_0_r. + destruct (nth_error_spec (all_rels Δ 0 #|Δ|) (#|Δ| + x)); + rewrite all_rels_length in l0 |- *. lia. + assert (#|Δ| + x - #|Δ| = x) as -> by lia. + reflexivity. + ** rewrite /subst_compose /ren /lift_renaming. + simpl. unfold Upn. simpl. unfold subst_consn. rewrite nth_error_nil. + simpl. unfold subst_compose. simpl. rewrite Nat.sub_0_r. + destruct (nth_error_spec (all_rels Δ 0 #|Δ|) x). + rewrite all_rels_length in l0 |- *; try lia. + eapply nth_error_all_rels_spec in e. + destruct e as [decl [Hnth Hdecl]]. + + destruct decl as [? [?|] ?]; simpl in Hdecl; subst x0. + assert (x = #|Δ| + (x - #|Δ|)). lia. + rewrite {1}H. + change (tRel (#|Δ'| + (n - #|Δ'|))) with + (lift0 #|Δ'| (tRel (n - #|Δ'|))). + eapply (weakening_red _ _ []); auto. + simpl. + set (i := n - #|Δ'|) in *. clearbody i. + clear l Hle H. + + etransitivi +*) + +Lemma All2_fold_mapi_right P Γ Δ g : + All2_fold (fun Γ Δ d d' => + P Γ (mapi_context g Δ) d (map_decl (g #|Γ|) d')) Γ Δ + -> All2_fold P Γ (mapi_context g Δ). +Proof. + induction 1; simpl; constructor; intuition auto; + now rewrite <-(All2_fold_length X). +Qed. + +Inductive All_fold {P : context -> context_decl -> Type} + : forall (Γ : context), Type := + | All_fold_nil : All_fold nil + | All_fold_cons {d Γ} : All_fold Γ -> P Γ d -> All_fold (d :: Γ). +Arguments All_fold : clear implicits. + +Lemma All2_fold_refl' P Γ : + All_fold (fun Γ d => P Γ Γ d d) Γ <~> + All2_fold P Γ Γ. +Proof. + split. + - induction 1; simpl; constructor; intuition auto; + now rewrite <-(All2_fold_length X). + - intros H; depind H; constructor; auto. +Qed. + +Lemma onctx_All_fold P Q Γ : + onctx P Γ -> + (forall Γ x, All_fold Q Γ -> ondecl P x -> Q Γ x) -> + All_fold Q Γ. +Proof. + intros o H; induction o; constructor; auto. +Qed. + Lemma all_rels_subst {cf:checker_flags} Σ Δ Γ t : wf Σ.1 -> wf_local Σ (Γ ,,, Δ) -> red Σ.1 (Γ ,,, Δ) t (subst0 (all_rels Δ 0 #|Δ|) (lift #|Δ| #|Δ| t)). @@ -1332,12 +1650,56 @@ Proof. eapply (IHt3 (Δ' ,, vdef n _ _)). * simpl; eapply red_app; auto. - * simpl; eapply red_case; auto. - red in X0. - do 2 eapply All2_map_right. - eapply (All_All2 X0). - simpl; intros. - split; auto. + * simpl. rewrite map_branches_k_map_branches_k. + relativize (subst_predicate _ _ _). + eapply red_case. + 6:{ reflexivity. } + simpl. rewrite mapi_context_length. + destruct X0 as [? [? ?]]. + specialize (r (Δ' ,,, pcontext p)). rewrite app_context_assoc in r. len in r. + relativize (#|pcontext p| + (_ + _)). eapply r. lia. + simpl. + rewrite (mapi_context_compose _ _ _). solve_all. + eapply PCUICContextReduction.red_ctx_rel_red_context_rel => //. + eapply All2_fold_mapi_right. + eapply All2_fold_refl'. eapply onctx_All_fold; tea. + intros. + + destruct X2. destruct x as [na [b|] ty]; constructor; auto. + specialize (o (Δ' ,,, Γ0)). simpl in o. + rewrite app_context_assoc in o. rewrite /shiftf. len in o. + relativize (#|_| + (_ + _)). exact o. len. + specialize (r0 (Δ' ,,, Γ0)). simpl in r0. + rewrite app_context_assoc in r0. rewrite /shiftf. len in r0. + relativize (#|_| + (_ + _)). exact r0. len. + simpl in o. + specialize (r0 (Δ' ,,, Γ0)). simpl in r0. + rewrite app_context_assoc in r0. rewrite /shiftf. len in r0. + relativize (#|_| + (_ + _)). exact r0. len. + + simpl. rewrite map_map_compose; eapply All2_map_right. + solve_all. + + eapply IHt. + + clear -wfΣ X0 X1. + eapply All2_map_right, All_All2; tea. + rewrite /on_Trel /=. + unfold on_Trel in *; simpl; solve_all. + rewrite Nat.add_0_r. + specialize (b (Δ' ,,, bcontext x)). rewrite app_context_assoc in b. len in b. + relativize (#|_| + _ + _). exact b. len. + eapply PCUICContextReduction.red_ctx_rel_red_context_rel => //; tea. + eapply All2_fold_mapi_right. + eapply All2_fold_refl'. eapply onctx_All_fold; tea. + intros. rewrite /shiftf !Nat.add_0_r. + { destruct X0. destruct x0 as [na [bod|] ty]; constructor; auto. + specialize (o (Δ' ,,, Γ0)). simpl in o. + rewrite app_context_assoc in o. rewrite /shiftf. len in o. + relativize (#|_| + (_ + _)). exact o. len. + specialize (r0 (Δ' ,,, Γ0)). simpl in r0. + rewrite app_context_assoc in r0. rewrite /shiftf. len in r0. + relativize (#|_| + (_ + _)). exact r0. len. + simpl in o. + specialize (r0 (Δ' ,,, Γ0)). simpl in r0. + rewrite app_context_assoc in r0. rewrite /shiftf. len in r0. + relativize (#|_| + (_ + _)). exact r0. len. } * simpl; eapply red_proj_c. auto. @@ -1452,9 +1814,9 @@ Proof. exists x. change (tSort x) with (subst0 (all_rels c (S #|l|) #|Δ|) (lift #|Δ| #|c| (tSort x))). - { eapply (substitution _ _ (lift_context #|Δ| 0 c) _ []); simpl; auto. + { eapply (substitution _ _ (lift_context #|Δ| 0 c) _ []); cbn; auto. change (tSort x) with (lift #|Δ| #|c| (tSort x)). - eapply (weakening_typing _ _ c); eauto. } + eapply (weakening_typing); eauto. } eapply conv_cumul. simpl. rewrite -{1}eql. simpl. rewrite !app_context_assoc. @@ -1472,7 +1834,6 @@ Proof. apply X; auto. Qed. - Lemma red_expand_let {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} Γ na b ty t : wf_local Σ (Γ ,,, [vdef na b ty]) -> red Σ.1 (Γ ,,, [vdef na b ty]) t (lift0 1 (subst1 b 0 t)). @@ -1484,6 +1845,45 @@ Proof. now rewrite distr_lift_subst. Qed. +Lemma type_it_mkProd_or_LetIn_inv {cf} {Σ : global_env_ext} {wfΣ : wf Σ}: + forall {Γ Δ t s}, + Σ ;;; Γ |- it_mkProd_or_LetIn Δ t : tSort s -> + ∑ Δs ts, sorts_local_ctx (lift_typing typing) Σ Γ Δ Δs × + Σ ;;; Γ ,,, Δ |- t : tSort ts × + leq_universe Σ (sort_of_products Δs ts) s. +Proof. + intros Γ Δ t s h. revert Γ t s h. + induction Δ; intros. + - exists [], s; splits. apply h. apply leq_universe_refl. + - destruct a as [na [b|] ty]; simpl in *; + rewrite /mkProd_or_LetIn /= in h. + * specialize (IHΔ _ _ _ h) as (Δs & ts & sorts & IHΔ & leq). + exists Δs, ts. + pose proof (PCUICWfUniverses.typing_wf_universe _ IHΔ) as wfts. + eapply inversion_LetIn in IHΔ as [s' [? [? [? [? ?]]]]]; auto. + splits; eauto. + eapply type_Cumul'. eapply t2. now pcuic. + eapply invert_cumul_letin_l in c; auto. + eapply invert_cumul_sort_r in c as [u' [redu' cumu']]. + transitivity (tSort u'). 2:do 2 constructor; auto. + eapply cumul_alt. + exists (tSort u'), (tSort u'). repeat split; auto. + 2:now constructor. + transitivity (lift0 1 (x {0 := b})). + eapply (red_expand_let _ _ _ _). pcuic. + change (tSort u') with (lift0 1 (tSort u')). + eapply (weakening_red _ (Γ ,,, Δ) [] [_]); auto. + + * specialize (IHΔ _ _ _ h) as (Δs & ts & sorts & IHΔ & leq). + eapply inversion_Prod in IHΔ as [? [? [? [? ]]]]; tea. + exists (x :: Δs), x0. splits; tea. + eapply cumul_Sort_inv in c. + transitivity (sort_of_products Δs ts); auto using leq_universe_product. + simpl. eapply leq_universe_sort_of_products_mon. + eapply Forall2_same. reflexivity. + exact: c. +Qed. + Lemma inversion_it_mkProd_or_LetIn {cf:checker_flags} Σ {wfΣ : wf Σ.1}: forall {Γ Δ t s}, Σ ;;; Γ |- it_mkProd_or_LetIn Δ t : tSort s -> @@ -1517,19 +1917,18 @@ Proof. auto. Qed. -Lemma subst_instance_lift_context u n k Γ : - subst_instance_context u (lift_context n k Γ) = lift_context n k (subst_instance_context u Γ). +Lemma isType_it_mkProd_or_LetIn_app {cf} {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ Δ' 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. - rewrite /subst_instance_context /map_context !lift_context_alt. - rewrite map_mapi mapi_map. apply mapi_rec_ext. - intros. rewrite /lift_decl !compose_map_decl. apply map_decl_ext => ?. - rewrite map_length. now rewrite lift_subst_instance_constr. + intros Hs sub. + move: Hs. rewrite it_mkProd_or_LetIn_app. + move/inversion_it_mkProd_or_LetIn => Hs. + eapply typing_expand_lets in Hs. + eapply (PCUICSubstitution.substitution _ _ _ _ []) in Hs; tea. Qed. -Lemma subst_lift_above s n k x : k = #|s| -> subst0 s (lift0 (n + k) x) = lift0 n x. -Proof. - intros. rewrite Nat.add_comm. subst k. now rewrite simpl_subst. -Qed. Lemma lift_to_extended_list_k n Γ : map (lift n #|Γ|) (to_extended_list_k Γ 0) = to_extended_list_k Γ 0. @@ -1775,6 +2174,81 @@ Proof. * apply conv_cumul. now symmetry. Qed. +Arguments ctx_inst_nil {typing} {Σ} {Γ}. +Arguments PCUICTyping.ctx_inst_ass {typing} {Σ} {Γ} {na t i inst Δ}. +Arguments PCUICTyping.ctx_inst_def {typing} {Σ} {Γ} {na b t inst Δ}. + +Lemma typing_spine_ctx_inst {cf : checker_flags} {Σ : global_env × universes_decl} + {Γ Δ : context} {T args args' T'} : + wf Σ.1 -> + #|args| = context_assumptions Δ -> + wf_local Σ Γ -> + isType Σ Γ (it_mkProd_or_LetIn Δ T) -> + typing_spine Σ Γ (it_mkProd_or_LetIn Δ T) (args ++ args') T' -> + ∑ argsi : ctx_inst Σ Γ args (List.rev Δ), + isType Σ Γ (subst0 (ctx_inst_sub argsi) T) * + typing_spine Σ Γ (subst0 (ctx_inst_sub argsi) T) args' T'. +Proof. + intros wfΣ len wfΓ. + revert args len T. + induction Δ as [|d Δ] using ctx_length_rev_ind; intros args. simpl. + destruct args; simpl; try discriminate. + - intros _ T sp; exists ctx_inst_nil; split; simpl; now rewrite subst_empty. + - rewrite context_assumptions_app => eq T wat sp. + assert (wfΓΔ := isType_it_mkProd_or_LetIn_wf_local _ _ (Δ ++ [d]) _ _ wat). + rewrite it_mkProd_or_LetIn_app in sp, wat. + destruct d as [? [b|] ?]; simpl in *. + + rewrite Nat.add_0_r in eq. + eapply typing_spine_letin_inv in sp => //. + rewrite /subst1 subst_it_mkProd_or_LetIn in sp. + specialize (X (subst_context [b] 0 Δ) ltac:(now autorewrite with len)). + specialize (X args ltac:(now rewrite context_assumptions_subst)). + rewrite Nat.add_0_r in sp. + eapply isType_tLetIn_red in wat as wat' => //. + rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r in wat'; auto. + destruct (X _ wat' sp) as [args_sub [[sps wat''] sp']]. + clear wat'. red in wat''. + rewrite List.rev_app_distr /=. + revert args_sub wat'' sp'. + rewrite -subst_telescope_subst_context => args_sub wat'' sp'. + exists (PCUICTyping.ctx_inst_def args_sub); simpl. + rewrite subst_app_simpl /=. + rewrite ctx_inst_subst_length subst_telescope_length List.rev_length. + split => //. + now exists sps. + + + rewrite /mkProd_or_LetIn /= in sp, wat. + destruct args as [|a args]; simpl in eq; try lia. + specialize (X (subst_context [a] 0 Δ) ltac:(now autorewrite with len)). + specialize (X args ltac:(now rewrite context_assumptions_subst)). + eapply isType_tProd in wat as wat' => //. + destruct wat' as [wat' wat''] => //. + specialize (X (subst [a] #|Δ| T)). + depelim sp. + eapply cumul_Prod_inv in c as [[eqann conv] cum]; auto. + eapply (substitution_cumul0 _ _ _ _ _ _ a) in cum; auto. + eapply typing_spine_strengthen in sp; eauto. + rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r in sp; auto. + eapply type_Cumul' in t. + 2:{ eauto. } + 2:now eapply conv_cumul, symmetry. + forward X. { + pose proof wfΓΔ as wfΓΔ'. + rewrite app_context_assoc in wfΓΔ'. eapply All_local_env_app_inv in wfΓΔ' as [wfΓΔ' _]. + eapply (isType_subst wfΣ wfΓΔ') in wat''; eauto. + 2:{ repeat constructor. now rewrite subst_empty. } + now rewrite subst_it_mkProd_or_LetIn Nat.add_0_r in wat''. } + specialize (X sp). + destruct X as [args_sub [[sps wat'''] sp']]. + rewrite List.rev_app_distr /=. + revert args_sub wat''' sp'. + rewrite -subst_telescope_subst_context => args_sub wat''' sp'. + exists (PCUICTyping.ctx_inst_ass t args_sub); simpl. + rewrite subst_app_simpl /= ctx_inst_subst_length subst_telescope_length List.rev_length. + split => //. + now exists sps. +Qed. + Lemma typing_spine_app {cf:checker_flags} Σ Γ ty args na A B arg : wf Σ.1 -> typing_spine Σ Γ ty args (tProd na A B) -> @@ -1871,6 +2345,7 @@ Proof. assumption. Qed. +From MetaCoq.PCUIC Require Import PCUICInst. Local Open Scope sigma. @@ -1902,20 +2377,17 @@ Proof. eapply meta_conv. eauto. simpl. autorewrite with sigma. - apply inst_ext. rewrite ren_lift_renaming. - autorewrite with sigma. + apply inst_ext. unfold Upn. rewrite subst_consn_compose. autorewrite with sigma. apply subst_consn_proper. - 2:{ rewrite -(subst_compose_assoc (↑^#|Δ|)). - rewrite subst_consn_shiftn. + 2:{ rewrite subst_consn_shiftn. 2:now autorewrite with len. autorewrite with sigma. rewrite subst_consn_shiftn //. rewrite List.rev_length. now apply context_subst_length2 in inst_ctx_subst0. } clear -inst_ctx_subst0. - rewrite subst_consn_compose. rewrite map_inst_idsn. now autorewrite with len. now apply context_subst_extended_subst. + simpl. rewrite smash_context_acc. @@ -1923,73 +2395,74 @@ Proof. depelim inst_ctx_subst0; apply IHinst_subslet0; auto. Qed. -Lemma extended_subst_app Γ Γ' : - extended_subst (Γ ++ Γ') 0 = - extended_subst (subst_context (extended_subst Γ' 0) 0 - (lift_context (context_assumptions Γ') #|Γ'| Γ)) 0 ++ - extended_subst Γ' (context_assumptions Γ). +Lemma ctx_inst_sub_subst {cf : checker_flags} {Σ} {wfΣ : wf Σ} + {Γ Δ : context} {args} : + forall ci : ctx_inst Σ Γ args (List.rev Δ), + ctx_inst_sub ci = map (subst0 (List.rev args)) (extended_subst Δ 0). Proof. - induction Γ as [|[na [b|] ty] Γ] in |- *; simpl; auto. - - autorewrite with len. - rewrite IHΓ. simpl. rewrite app_comm_cons. - f_equal. - erewrite subst_app_simpl'. - 2:autorewrite with len; reflexivity. - simpl. - rewrite lift_context_snoc subst_context_snoc /=. - autorewrite with len. f_equal. f_equal. - rewrite !context_assumptions_fold. - rewrite -{3}(Nat.add_0_r #|Γ|). - erewrite <- (simpl_lift _ _ _ _ (#|Γ| + #|Γ'|)). all:try lia. - rewrite distr_lift_subst_rec. autorewrite with len. - f_equal. apply lift_extended_subst. - - rewrite lift_context_snoc subst_context_snoc /=. lia_f_equal. - rewrite lift_extended_subst. rewrite IHΓ /=. - rewrite map_app. rewrite !(lift_extended_subst _ (S _)). - rewrite (lift_extended_subst _ (context_assumptions Γ)). - rewrite map_map_compose. - f_equal. apply map_ext. intros. - rewrite simpl_lift; lia_f_equal. + intros ci. + pose proof (ctx_inst_sub_spec ci). + eapply make_context_subst_spec in H. + revert H. generalize (ctx_inst_sub ci). clear ci. + intros l cs. + apply context_subst_extended_subst in cs. + rewrite List.rev_involutive in cs. + rewrite cs. apply map_ext => t. + now rewrite subst0_inst. +Qed. + +Lemma typing_spine_ctx_inst_smash {cf : checker_flags} {Σ} {wfΣ : wf Σ} + {Γ Δ : context} {T args args' T'} : + wf Σ.1 -> + #|args| = context_assumptions Δ -> + wf_local Σ Γ -> + isType Σ Γ (it_mkProd_or_LetIn Δ T) -> + typing_spine Σ Γ (it_mkProd_or_LetIn Δ T) (args ++ args') T' -> + spine_subst Σ Γ args (List.rev args) (smash_context [] Δ) × + isType Σ Γ (subst_let_expand (List.rev args) Δ T) × + typing_spine Σ Γ (subst_let_expand (List.rev args) Δ T) args' T'. +Proof. + intros. + eapply typing_spine_ctx_inst in X2 as [argsi [isty sp]]; tea. + unshelve epose proof (ctx_inst_spine_subst _ argsi); pcuic. + now eapply isType_it_mkProd_or_LetIn_wf_local. + pose proof (spine_subst_smash _ X2). + intuition auto. + destruct X1 as [s Hs]. + eapply (isType_it_mkProd_or_LetIn_app _ _ []) in Hs. + 2:eapply X3. now exists s. + rewrite (ctx_inst_sub_subst argsi) in sp. + rewrite /subst_let_expand. + rewrite /expand_lets /expand_lets_k /=. + rewrite distr_subst. len. + rewrite simpl_subst_k. now len. + assumption. +Qed. + +Lemma shift_subst_consn_tip t : ↑ ∘s ([t] ⋅n ids) =1 ids. +Proof. + rewrite /subst_consn; intros [|i] => /= //. Qed. Lemma subst_rel0_lift_id n t : subst [tRel 0] n (lift 1 (S n) t) = t. Proof. - sigma. rewrite -{2}(subst_ids t). - apply inst_ext. - unfold Upn. sigma. unfold shiftk at 1 => /=. - rewrite Nat.add_0_r. - assert(idsn n ⋅n (tRel n ⋅ ↑^n) =1 idsn (S n) ⋅n ↑^n). - { pose proof (@subst_consn_app _ (idsn n) [(tRel 0).[↑^n]] (↑^n)). - simpl in H. rewrite -> (subst_consn_subst_cons (tRel 0).[↑^n] []) in H. - simpl in H. rewrite -> subst_consn_nil in H. - unfold shiftk at 3 in H. rewrite Nat.add_0_r in H. - rewrite -H. unfold shiftk at 1; now rewrite Nat.add_0_r. } - rewrite H. rewrite ren_shiftk. rewrite subst_consn_ids_ren. - unfold lift_renaming. rewrite compose_ren. - intros i. unfold ren, ids; simpl. f_equal. - elim: Nat.leb_spec => H'. unfold subst_consn. - elim: nth_error_spec => [i' e l|]. - rewrite app_length ren_ids_length /= in l. lia. - rewrite app_length ren_ids_length /=. lia. - unfold subst_consn. - elim: nth_error_spec => [i' e l|]. - rewrite (@ren_ids_lt (S n) i) in e. lia. congruence. - rewrite app_length ren_ids_length /=. lia. -Qed. - -Lemma subst_context_lift_id Γ : subst_context [tRel 0] 0 (lift_context 1 1 Γ) = Γ. + rewrite subst_reli_lift_id; try lia. + now rewrite lift0_id. +Qed. + +Lemma subst_context_lift_id Γ k : subst_context [tRel 0] k (lift_context 1 (S k) Γ) = Γ. Proof. rewrite subst_context_alt lift_context_alt. rewrite mapi_compose. replace Γ with (mapi (fun k x => x) Γ) at 2. 2:unfold mapi; generalize 0; induction Γ; simpl; intros; auto; congruence. apply mapi_ext. - autorewrite with len. + len. intros n [? [?|] ?]; unfold lift_decl, subst_decl, map_decl; simpl. generalize (Nat.pred #|Γ| - n). - intros. - now rewrite !Nat.add_0_r !Nat.add_1_r !subst_rel0_lift_id. - now rewrite !Nat.add_0_r !Nat.add_1_r !subst_rel0_lift_id. + 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 = @@ -1999,7 +2472,6 @@ Proof. autorewrite with len; rewrite ? (lift_extended_subst _ 1); f_equal; auto. - rewrite IHΓ. rewrite commut_lift_subst_rec. auto. - rewrite context_assumptions_fold. rewrite distr_subst. now autorewrite with len. - rewrite IHΓ. rewrite !map_map_compose. apply map_ext. @@ -2035,10 +2507,11 @@ Qed. Lemma arity_spine_it_mkProd_or_LetIn_smash {cf:checker_flags} Σ Γ Δ T args args' T' : wf Σ.1 -> subslet Σ Γ (List.rev args) (smash_context [] Δ) -> - arity_spine Σ Γ (subst0 (List.rev args) (subst0 (extended_subst Δ 0) (lift (context_assumptions Δ) #|Δ| 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. intros wfΣ subsl asp. + rewrite /subst_let_expand /expand_lets /expand_lets_k in asp. move: Δ T args subsl asp. induction Δ using ctx_length_rev_ind => T args subsl asp. - simpl in subsl. simpl in asp. rewrite subst_empty lift0_id in asp. depelim subsl. @@ -2050,9 +2523,10 @@ Proof. * constructor. rewrite /subst1 subst_it_mkProd_or_LetIn. rewrite Nat.add_0_r. rewrite smash_context_app smash_context_acc /= in subsl. - rewrite subst_empty 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. apply (X (subst_context [b] 0 Γ0) ltac:(now autorewrite with len) (subst [b] #|Γ0| T) _ subsl). rewrite extended_subst_app /= in asp. @@ -2062,9 +2536,8 @@ Proof. simpl in asp. autorewrite with len in asp. simpl in asp. autorewrite with len. - rewrite context_assumptions_fold. now rewrite -{1}(Nat.add_0_r #|Γ0|) distr_lift_subst_rec /= Nat.add_0_r. - * simpl in *. autorewrite with len in *. + * simpl in *. autorewrite with len in asp. simpl in asp. assert (len:=subslet_length subsl). autorewrite with len in len. simpl in len. @@ -2089,7 +2562,6 @@ Proof. 2:now autorewrite with len. simpl in asp. autorewrite with len. - rewrite context_assumptions_fold. rewrite -{1}(Nat.add_0_r #|Γ0|) distr_lift_subst_rec /= Nat.add_0_r. move: asp. rewrite subst_app_simpl /=; autorewrite with len. rewrite distr_subst. autorewrite with len. @@ -2103,7 +2575,6 @@ Proof. now rewrite subst_extended_subst H. Qed. - (** 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. *) @@ -2131,7 +2602,8 @@ Proof. eapply (substitution_cumul _ _ _ []). eauto. eapply wf. assumption. now depelim p. - - elimtype False; inv ass. + elimtype False; depelim ass'. + elimtype False; inv ass. Qed. Lemma spine_subst_cumul {cf:checker_flags} Σ Δ args Γ Γ' : @@ -2149,8 +2621,1057 @@ Proof. revert inst_ctx_subst0; generalize (List.rev args). intros l ctxs. induction ctxs in ass, Γ', ass', a2 |- *; depelim a2; try (simpl in H; noconf H); try constructor; auto. - * eapply IHctxs. now depelim ass. + * depelim c. constructor. eapply IHctxs. now depelim ass. now depelim ass'. auto. * elimtype False; depelim ass. - eapply subslet_cumul. 6:eauto. all:eauto. Qed. + +Lemma pre_type_mkApps_arity {cf} {Σ : global_env_ext} {wfΣ : wf Σ} (Γ : context) + (t : term) (u : list term) tty T : + Σ;;; Γ |- t : tty -> isType Σ Γ tty -> + arity_spine Σ Γ tty u T -> + Σ;;; Γ |- mkApps t u : T. +Proof. + intros Ht Hty Har. + eapply type_mkApps; tea. + eapply wf_arity_spine_typing_spine; tea. + constructor; tas. +Qed. + +Hint Rewrite subst_instance_assumptions to_extended_list_k_length : len. + +Require Import ssrbool. + +Lemma smash_context_app_def Γ na b ty : + smash_context [] (Γ ++ [{| decl_name := na; decl_body := Some b; decl_type := ty |}]) = + smash_context [] (subst_context [b] 0 Γ). +Proof. + now rewrite smash_context_app smash_context_acc /= subst_empty lift0_id lift0_context /= + subst_context_nil app_nil_r (smash_context_subst []). +Qed. + +Lemma smash_context_app_ass Γ na ty : + smash_context [] (Γ ++ [{| decl_name := na; decl_body := None; decl_type := ty |}]) = + smash_context [] Γ ++ [{| decl_name := na; decl_body := None; decl_type := ty |}]. +Proof. + now rewrite smash_context_app smash_context_acc /= subst_context_lift_id. +Qed. + +Lemma lift_context_add k k' n Γ : lift_context (k + k') n Γ = lift_context k n (lift_context k' n Γ). +Proof. + induction Γ => //. + rewrite !lift_context_snoc IHΓ; f_equal. + destruct a as [na [b|] ty]; rewrite /lift_decl /map_decl /=; simpl; f_equal; + len; rewrite simpl_lift //; try lia. +Qed. + +Lemma distr_lift_subst_context_rec n k s Γ k' : lift_context n (k' + k) (subst_context s k' Γ) = + subst_context (map (lift n k) s) k' (lift_context n (#|s| + k + k') Γ). +Proof. + rewrite !lift_context_alt !subst_context_alt. + rewrite !mapi_compose. + apply mapi_ext. + intros n' x. + rewrite /lift_decl /subst_decl !compose_map_decl. + apply map_decl_ext => y. len. + replace (Nat.pred #|Γ| - n' + (#|s| + k + k')) + with ((Nat.pred #|Γ| - n' + k') + #|s| + k) by lia. + rewrite -distr_lift_subst_rec. f_equal. lia. +Qed. + +Lemma assumption_context_app_inv Γ Δ : assumption_context Γ -> assumption_context Δ -> + assumption_context (Γ ++ Δ). +Proof. + induction 1; try constructor; auto. +Qed. + +Lemma closedn_ctx_upwards k k' Γ : + closedn_ctx k Γ -> k <= k' -> + closedn_ctx k' Γ. +Proof. + induction Γ; auto. rewrite !closed_ctx_decl /=. + move/andb_and => [cla clΓ] le. + rewrite (IHΓ clΓ le). + rewrite (closed_decl_upwards _ _ cla) //. lia. +Qed. + +Lemma closedn_expand_lets k (Γ : context) t : + closedn (k + context_assumptions Γ) (expand_lets Γ t) -> + closedn (k + #|Γ|) t. +Proof. + revert k t. + induction Γ as [|[na [b|] ty] Γ] using ctx_length_rev_ind; intros k t; simpl; auto. + - now rewrite /expand_lets /expand_lets_k subst_empty lift0_id. + - len. + rewrite !expand_lets_vdef. + specialize (H (subst_context [b] 0 Γ) ltac:(len; lia)). + len in H. + intros cl. + specialize (H _ _ cl). + eapply (closedn_subst_eq' _ k) in H. + simpl in *. now rewrite Nat.add_assoc. + - len. + rewrite !expand_lets_vass. simpl. intros cl. + specialize (H Γ ltac:(len; lia)). + rewrite (Nat.add_comm _ 1) Nat.add_assoc in cl. + now rewrite (Nat.add_comm _ 1) Nat.add_assoc. +Qed. + +Ltac len' := rewrite_strat (topdown (repeat (old_hints len))). + +Tactic Notation "len'" "in" hyp(id) := + rewrite_strat (topdown (repeat (old_hints len))) in id. + +Lemma closedn_expand_lets_eq k (Γ : context) k' t : + closedn_ctx k Γ -> + closedn (k + k' + context_assumptions Γ) (expand_lets_k Γ k' t) = + closedn (k + k' + #|Γ|) t. +Proof. + revert k k' t. + induction Γ as [|[na [b|] ty] Γ] using ctx_length_rev_ind; intros k k' t; + rewrite ?closedn_ctx_app /= /id /=; simpl; auto. + - now rewrite /expand_lets /expand_lets_k /= subst_empty lift0_id. + - move/andb_and=> [cld clΓ]. len'. + rewrite !expand_lets_k_vdef. + simpl in cld |- *. move/andb_and: cld => /= [clb _]. + specialize (H (subst_context [b] 0 Γ) ltac:(len; lia)). + len' in H; simpl in H. len. + rewrite H /=. + relativize k. eapply closedn_ctx_subst. simpl. 3:rewrite Nat.add_0_r //. + 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Γ]. + 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_ctx_expand_lets k Γ Δ : + closedn_ctx k Γ -> + closedn_ctx (k + #|Γ|) Δ -> + closedn_ctx (k + context_assumptions Γ) (expand_lets_ctx Γ Δ). +Proof. + intros clΓ clΔ. + rewrite /expand_lets_ctx /expand_lets_k_ctx. + rewrite -(Nat.add_0_r (k + context_assumptions Γ)). + eapply closedn_ctx_subst; len; simpl. + replace (k + context_assumptions Γ + #|Γ|) with (context_assumptions Γ + (k + #|Γ|)) by lia. + eapply closedn_ctx_lift => //. + eapply forallb_impl. 2:eapply closedn_extended_subst_gen; eauto. + simpl; auto. +Qed. + +Lemma closedn_to_extended_list_k k Γ k' : + k' + #|Γ| <= k -> + forallb (closedn k) (to_extended_list_k Γ k'). +Proof. + move=> le. rewrite /to_extended_list_k. + eapply Forall_forallb; eauto. 2:{ intros x H; eapply H. } + eapply Forall_impl. eapply reln_list_lift_above. constructor. + simpl; intros. + destruct H as [n [-> leq]]. simpl. + eapply Nat.ltb_lt. lia. +Qed. + +Lemma map_subst_extended_subst Γ k : + map (subst0 (List.rev (to_extended_list_k Γ k))) (extended_subst Γ 0) = + all_rels Γ k 0. +Proof. + unfold to_extended_list_k. + induction Γ in k |- *; simpl; auto. + destruct a as [na [b|] ty]; simpl. + f_equal. len. + rewrite lift0_id. + rewrite distr_subst. autorewrite with len. + 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 (map_subst_app_decomp [tRel k]). + simpl. f_equal. rewrite lift_extended_subst. + rewrite map_map_compose -IHΓ. apply map_ext. + intros x. f_equal. now rewrite Nat.add_1_r. + len. simpl. + rewrite simpl_subst // lift0_id //. +Qed. + +Lemma subst_ext_list_ext_subst Γ k' k t : + subst (List.rev (to_extended_list_k Γ k)) k' + (subst (extended_subst Γ 0) k' + (lift (context_assumptions Γ) (k' + #|Γ|) t)) = + subst (all_rels Γ k 0) k' t. +Proof. + epose proof (distr_subst_rec _ _ _ 0 _). + rewrite Nat.add_0_r in H. rewrite -> H. clear H. + 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 (all_rels Γ k 0) k' Δ. +Proof. + revert k k'; induction Δ using rev_ind; simpl; auto. + intros k k'; rewrite expand_lets_k_ctx_decl /map_decl /=. + rewrite !subst_context_app /=. + simpl; unfold app_context. + f_equal. specialize (IHΔ k (S k')). simpl in IHΔ. + rewrite -IHΔ. + destruct x; simpl. + destruct decl_body; simpl in * => //. + unfold subst_context, fold_context_k; simpl. + f_equal. + 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 Γ) = + subst_context (map (subst s k) s') 0 (subst_context s (#|s'| + k) Γ). +Proof. + rewrite !subst_context_alt. + rewrite !mapi_compose; len. + eapply mapi_ext. intros n x. + rewrite /subst_decl !compose_map_decl. + apply map_decl_ext. intros t. + rewrite Nat.add_0_r. + remember (Nat.pred #|Γ| - n) as i. + rewrite distr_subst_rec. lia_f_equal. +Qed. + +Lemma closed_ctx_subst n k ctx : closedn_ctx k ctx = true -> subst_context n k ctx = ctx. +Proof. + induction ctx in n, k |- *; auto. + simpl. + move/andb_and => /= [Hctx Hd]. + rewrite subst_context_snoc /snoc /= IHctx // subst_decl_closed //. +Qed. + +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 + (expand_lets_ctx Γ Δ)) = + subst_context (List.rev (to_extended_list_k (smash_context [] Γ) k)) 0 + (expand_lets_ctx Γ Δ). +Proof. + intros clΓ clΔ. + rewrite {1}/expand_lets_k_ctx. + rewrite PCUICClosed.closed_ctx_lift. + rewrite -(Nat.add_0_r (k + #|Γ|)). + eapply closedn_ctx_subst. simpl; len'. + eapply closedn_ctx_expand_lets. eapply closedn_ctx_upwards; eauto. lia. + eapply closedn_ctx_upwards; eauto. lia. + rewrite forallb_rev. now eapply closedn_to_extended_list_k. + rewrite subst_subst_context. len'. + rewrite map_rev extended_subst_to_extended_list_k. + rewrite (closed_ctx_subst _ (context_assumptions Γ + k)) //. + rewrite Nat.add_comm. eapply closedn_ctx_expand_lets => //. + eapply closedn_ctx_upwards; eauto. lia. + eapply closedn_ctx_upwards; eauto. lia. +Qed. + +Local Set SimplIsCbn. + +Lemma subst_lift1 x s : (subst0 (x :: s) ∘ lift0 1) =1 subst0 s. +Proof. + intros t. erewrite <- PCUICParallelReduction.subst_skipn'. + rewrite lift0_id. simpl. now rewrite skipn_S skipn_0. + lia. simpl. lia. +Qed. + +Lemma map_subst_lift1 x s l : map (subst0 (x :: s) ∘ lift0 1) l = map (subst0 s) l. +Proof. + apply map_ext. apply subst_lift1. +Qed. + +Lemma subst_extended_lift Γ k : + closed_ctx Γ -> + map (subst0 (List.rev (to_extended_list_k (smash_context [] Γ) k))) + (extended_subst Γ 0) = extended_subst Γ k. +Proof. + induction Γ in k |- *; intros cl; simpl; auto. + destruct a as [na [b|] ty] => /=. + len. + rewrite closed_ctx_decl in cl. move/andb_and: cl => [cld clΓ]. + simpl. f_equal. + rewrite distr_subst. len. + simpl in cld. + rewrite IHΓ //. f_equal. + rewrite simpl_subst_k ?lengths // lift_closed //. now move/andb_and: cld => /= //. + rewrite IHΓ //. + + cbn -[nth_error] => /=. rewrite nth_error_rev; len. + rewrite List.rev_involutive /=. + rewrite smash_context_acc /=. + f_equal; auto. rewrite reln_acc /=. + rewrite nth_error_app_ge; len. + replace (context_assumptions Γ - 0 - context_assumptions Γ) with 0 by lia. + now simpl. + rewrite reln_acc List.rev_app_distr /=. + rewrite lift_extended_subst. + rewrite map_map_compose. + rewrite map_subst_lift1. + rewrite closed_ctx_decl in cl. move/andb_and: cl => [cld clΓ]. + now rewrite IHΓ // Nat.add_1_r. +Qed. +From MetaCoq.PCUIC Require Import PCUICInst. + +(* Lemma Upn_rshiftk n s k : ⇑^n s ∘s shiftk k =1 shiftk k ∘s (idsn n ⋅n s). +Proof. + intros i. rewrite Upn_eq; sigma. + destruct (leb_spec_Set (S i) n). + - rewrite subst_consn_lt'. len; try lia. + cbn. + rewrite /subst_fn nth_error_map /= idsn_lt /shiftk; len; try lia. + rewrite subst_consn_lt'; len; try lia. + simpl. + now destruct nth_error => /= //; len. + reflexivity. *) + +Lemma closed_subst_map_lift s n k t : + closedn (#|s| + k) t -> + subst (map (lift0 n) s) k t = subst s (n + k) (lift n k t). +Proof. + intros cl. + sigma. + eapply PCUICInst.inst_ext_closed; tea. + intros x Hx. + rewrite -Upn_Upn Nat.add_comm Upn_Upn Upn_compose shiftn_Upn; sigma. + now rewrite !Upn_subst_consn_lt; len; try lia. +Qed. + +Lemma subst_map_lift_lift_context (Γ : context) k s : + closedn_ctx #|s| Γ -> + subst_context (map (lift0 k) s) 0 Γ = + subst_context s k (lift_context k 0 Γ). +Proof. + induction Γ as [|[? [] ?] ?] in k |- *; intros cl; auto; + rewrite lift_context_snoc !subst_context_snoc /= /subst_decl /map_decl /=; + rewrite closed_ctx_decl in cl; move/andb_and: cl => [cld clΓ]. + - rewrite IHΓ //. f_equal. f_equal. f_equal; + len. + rewrite closed_subst_map_lift //. now move/andb_and: cld => /=. + lia_f_equal. + len. + rewrite closed_subst_map_lift //. now move/andb_and: cld => /=. + lia_f_equal. + - f_equal. apply IHΓ => //. + f_equal; len. rewrite closed_subst_map_lift //. + lia_f_equal. +Qed. + +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. + intros ->; induction Γ as [|[? [] ?] ?] in |- *; auto; + 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. + len. + rewrite commut_lift_subst_rec. lia. lia_f_equal. + - f_equal. apply IHΓ => //. + f_equal; len. rewrite commut_lift_subst_rec //; try lia. + lia_f_equal. +Qed. + +Lemma context_subst_subst_extended_subst inst s Δ : + context_subst Δ inst s -> + s = map (subst0 (List.rev inst)) (extended_subst Δ 0). +Proof. + intros sp. + induction sp. + - simpl; auto. + - rewrite List.rev_app_distr /= lift0_id. f_equal. + rewrite lift_extended_subst. + rewrite map_map_compose. rewrite IHsp. apply map_ext. + intros. rewrite (subst_app_decomp [_]). f_equal. + simpl. rewrite simpl_subst ?lift0_id //. + - simpl. len. + f_equal; auto. + rewrite IHsp. + rewrite distr_subst. f_equal. + simpl; len. + pose proof (context_subst_length2 sp). + rewrite -H. rewrite -(List.rev_length args). + rewrite -(Nat.add_0_r #|List.rev args|). + rewrite simpl_subst_rec; try lia. + now rewrite lift0_id. +Qed. + +Lemma spine_subst_extended_subst {cf:checker_flags} {Σ Γ inst s Δ} : + spine_subst Σ Γ inst s Δ -> + s = map (subst0 (List.rev inst)) (extended_subst Δ 0). +Proof. + intros [_ _ sp _]. now apply context_subst_subst_extended_subst in sp. +Qed. + + +Lemma spine_subst_app {cf:checker_flags} Σ Γ Δ Δ' inst inst' insts : + wf Σ.1 -> + #|inst| = context_assumptions Δ -> + wf_local Σ (Γ ,,, Δ ,,, Δ') -> + spine_subst Σ Γ inst (skipn #|Δ'| insts) Δ * + spine_subst Σ Γ inst' (firstn #|Δ'| insts) (subst_context (skipn #|Δ'| insts) 0 Δ') -> + spine_subst Σ Γ (inst ++ inst') insts (Δ ,,, Δ'). +Proof. + intros wfΣ len wf [[wfdom wfcodom cs subst] [wfdom' wfcodom' cs' subst']]. + split; auto. + now rewrite app_context_assoc. + eapply context_subst_app_inv; split; auto. + rewrite skipn_all_app_eq; try lia. auto. + rewrite (firstn_app_left _ 0) ?Nat.add_0_r // firstn_0 // app_nil_r //. + rewrite -(firstn_skipn #|Δ'| insts). + eapply subslet_app; auto. +Qed. +Lemma context_assumptions_lift {n k Γ} : context_assumptions (lift_context n k Γ) = context_assumptions Γ. +Proof. apply context_assumptions_fold. Qed. +Lemma context_assumptions_subst {n k Γ} : context_assumptions (subst_context n k Γ) = context_assumptions Γ. +Proof. apply context_assumptions_fold. Qed. +Hint Rewrite @context_assumptions_lift @context_assumptions_subst : len. + +Lemma conv_ctx_rel_context_assumptions {cf} {Σ} {Γ} {Δ Δ'} : + conv_context_rel Σ Γ Δ Δ' -> + context_assumptions Δ = context_assumptions Δ'. +Proof. + induction 1; auto. + depelim p; simpl; auto. lia. +Qed. + +Lemma cumul_ctx_rel_context_assumptions {cf} {Σ} {Γ} {Δ Δ'} : + cumul_ctx_rel Σ Γ Δ Δ' -> + context_assumptions Δ = context_assumptions Δ'. +Proof. + induction 1; auto. + depelim p; simpl; auto. lia. +Qed. + +(* Lemma subslet_subs {cf} {Σ} {wfΣ : wf Σ} {Γ i Δ Δ'} : +cumul_ctx_rel Σ Γ Δ Δ' -> +ctx_inst Σ Γ i (Li *) + +Lemma cumul_expand_lets {cf} {Σ} {wfΣ : wf Σ} {Γ} {Δ} {T T'} : + wf_local Σ (Γ ,,, Δ) -> + Σ ;;; Γ ,,, Δ |- T <= T' -> + Σ ;;; Γ ,,, smash_context [] Δ |- expand_lets Δ T <= expand_lets Δ T'. +Proof. + intros wf cum. + eapply (weakening_cumul _ _ _ (smash_context [] Δ)) in cum; tea. + rewrite /expand_lets /expand_lets_k. + eapply (substitution_cumul _ _ _ []) in cum; tea. len in cum; tea. + destruct (wf_local_app_inv wf). + simpl. + eapply weakening_wf_local => //. + now eapply wf_local_smash_end. + len. + now eapply PCUICContexts.subslet_extended_subst. +Qed. + +Lemma conv_expand_lets {cf} {Σ} {wfΣ : wf Σ} {Γ} {Δ} {T T'} : + wf_local Σ (Γ ,,, Δ) -> + Σ ;;; Γ ,,, Δ |- T = T' -> + Σ ;;; Γ ,,, smash_context [] Δ |- expand_lets Δ T = expand_lets Δ T'. +Proof. + intros wf cum. + eapply (weakening_conv _ _ _ (smash_context [] Δ)) in cum; tea. + rewrite /expand_lets /expand_lets_k. + eapply (substitution_conv _ _ _ []) in cum; tea. len in cum; tea. + destruct (wf_local_app_inv wf). + simpl. + eapply weakening_wf_local => //. + now eapply wf_local_smash_end. + len. + now eapply PCUICContexts.subslet_extended_subst. +Qed. + +Lemma conv_context_app {cf:checker_flags} {Σ Γ Δ Δ'} : + conv_context_rel Σ Γ Δ Δ' -> + conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). +Proof. + intros HΔ. + eapply All2_fold_app. + * apply (length_of HΔ). + * reflexivity. + * eapply (All2_fold_impl HΔ). intros ???? []; constructor; auto. +Qed. + +Lemma cumul_context_app {cf:checker_flags} {Σ Γ Δ Δ'} : + cumul_ctx_rel Σ Γ Δ Δ' -> + cumul_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). +Proof. + intros HΔ. + eapply All2_fold_app. + * apply (length_of HΔ). + * reflexivity. + * apply HΔ. +Qed. + +Lemma conv_terms_lift {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ args args'} : + conv_terms Σ Γ args args' -> + conv_terms Σ (Γ ,,, Δ) (map (lift0 #|Δ|) args) (map (lift0 #|Δ|) args'). +Proof. + intros conv. + eapply All2_map. + eapply (All2_impl conv). + intros x y eqxy. + now eapply (weakening_conv _ _ []). +Qed. + +Lemma subslet_conv_ctx {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Γ' Δ Δ'} {s} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + conv_context_rel Σ Γ Δ' Δ -> + subslet Σ (Γ ,,, Δ) s Γ' -> + subslet Σ (Γ ,,, Δ') s Γ'. +Proof. + intros wfl wfr cumul. + induction 1; constructor; auto. + * eapply context_conversion; tea. + apply conv_context_sym; tea. + now eapply conv_context_app. + * eapply context_conversion; tea. + apply conv_context_sym; tea. + now eapply conv_context_app. +Qed. + +Lemma subslet_cumul_ctx {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Γ' Δ Δ'} {s} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + cumul_ctx_rel Σ Γ Δ' Δ -> + subslet Σ (Γ ,,, Δ) s Γ' -> + subslet Σ (Γ ,,, Δ') s Γ'. +Proof. + intros wfl wfr cumul. + induction 1; constructor; auto. + * eapply context_cumulativity; tea. + now eapply cumul_context_app. + * eapply context_cumulativity; tea. + now eapply cumul_context_app. +Qed. + +Lemma conv_ctx_rel_conv_extended_subst {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + conv_context_rel Σ Γ Δ Δ' -> + conv_terms Σ (Γ ,,, smash_context [] Δ) (extended_subst Δ 0) (extended_subst Δ' 0) × + conv_context_rel Σ Γ (smash_context [] Δ) (smash_context [] Δ'). +Proof. + intros wfl wfr cum. + induction cum in |- *; simpl; auto. + - split; constructor. + - depelim p; simpl; + depelim wfl; depelim wfr; + specialize (IHcum wfl wfr) as [conv cum']. + * split; try constructor; auto. + + rewrite smash_context_acc /=. + rewrite !(lift_extended_subst _ 1). + now eapply (conv_terms_lift (Δ := [_])). + + simpl; rewrite !(smash_context_acc _ [_]) /=; + constructor; auto. + constructor; simpl; auto. + eapply conv_expand_lets in c; tea. + etransitivity;tea. rewrite /expand_lets /expand_lets_k. simpl. + rewrite -(length_of cum). + rewrite -(conv_ctx_rel_context_assumptions cum). + move: (context_assumptions_smash_context [] Γ0); cbn => <-. simpl. + change (Γ ,,, smash_context [] Γ0) with (Γ ,,, smash_context [] Γ0 ,,, []). + eapply (conv_subst_conv _ _ _ _ []); tea. + { eapply subslet_untyped_subslet. + now eapply PCUICContexts.subslet_extended_subst. } + { eapply subslet_untyped_subslet. + eapply subslet_conv_ctx. 3:tea. + now eapply wf_local_smash_end. + now eapply wf_local_smash_end. + now eapply PCUICContexts.subslet_extended_subst. } + * split; auto. + constructor; auto. + len. + eapply conv_expand_lets in c; tea. + etransitivity; tea. + rewrite /expand_lets /expand_lets_k. simpl. + rewrite -(length_of cum). + rewrite -(conv_ctx_rel_context_assumptions cum). + move: (context_assumptions_smash_context [] Γ0); cbn => <-. simpl. + change (smash_context [] Γ0 ++ Γ) with (Γ ,,, smash_context [] Γ0 ,,, []). + eapply (conv_subst_conv _ _ _ _ []); tea. + { eapply subslet_untyped_subslet. + now eapply PCUICContexts.subslet_extended_subst. } + { eapply subslet_untyped_subslet. + eapply subslet_conv_ctx. 3:tea. + now eapply wf_local_smash_end. + now eapply wf_local_smash_end. + now eapply PCUICContexts.subslet_extended_subst. } +Qed. + +Lemma cumul_ctx_rel_conv_extended_subst {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + cumul_ctx_rel Σ Γ Δ Δ' -> + conv_terms Σ (Γ ,,, smash_context [] Δ) (extended_subst Δ 0) (extended_subst Δ' 0) × + cumul_ctx_rel Σ Γ (smash_context [] Δ) (smash_context [] Δ'). +Proof. + intros wfl wfr cum. + induction cum in |- *; simpl; auto. + - split; constructor. + - depelim p; simpl; + depelim wfl; depelim wfr; + specialize (IHcum wfl wfr) as [conv cum']. + * split; try constructor; auto. + + rewrite smash_context_acc /=. + rewrite !(lift_extended_subst _ 1). + now eapply (conv_terms_lift (Δ := [_])). + + simpl; rewrite !(smash_context_acc _ [_]) /=; + constructor; auto. + constructor; simpl; auto. + eapply cumul_expand_lets in c; tea. + etransitivity;tea. rewrite /expand_lets /expand_lets_k. simpl. + red. + rewrite -(length_of cum). + rewrite -(cumul_ctx_rel_context_assumptions cum). + move: (context_assumptions_smash_context [] Γ0); cbn => <-. simpl. + change (Γ ,,, smash_context [] Γ0) with (Γ ,,, smash_context [] Γ0 ,,, []). + eapply (cumul_subst_conv _ _ _ _ []); tea. + { eapply subslet_untyped_subslet. + now eapply PCUICContexts.subslet_extended_subst. } + { eapply subslet_untyped_subslet. + eapply subslet_cumul_ctx. 3:tea. + now eapply wf_local_smash_end. + now eapply wf_local_smash_end. + now eapply PCUICContexts.subslet_extended_subst. } + * split; auto. + constructor; auto. + len. + eapply conv_expand_lets in c; tea. + etransitivity; tea. + rewrite /expand_lets /expand_lets_k. simpl. + rewrite -(length_of cum). + rewrite -(cumul_ctx_rel_context_assumptions cum). + move: (context_assumptions_smash_context [] Γ0); cbn => <-. simpl. + change (smash_context [] Γ0 ++ Γ) with (Γ ,,, smash_context [] Γ0 ,,, []). + eapply (conv_subst_conv _ _ _ _ []); tea. + { eapply subslet_untyped_subslet. + now eapply PCUICContexts.subslet_extended_subst. } + { eapply subslet_untyped_subslet. + eapply subslet_cumul_ctx. 3:tea. + now eapply wf_local_smash_end. + now eapply wf_local_smash_end. + now eapply PCUICContexts.subslet_extended_subst. } +Qed. + +Lemma conv_ctx_rel_smash {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + conv_context_rel Σ Γ Δ Δ' -> + conv_context_rel Σ Γ (smash_context [] Δ) (smash_context [] Δ'). +Proof. + now intros; apply conv_ctx_rel_conv_extended_subst. +Qed. + +Lemma cumul_ctx_rel_smash {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + cumul_ctx_rel Σ Γ Δ Δ' -> + cumul_ctx_rel Σ Γ (smash_context [] Δ) (smash_context [] Δ'). +Proof. + now intros; apply cumul_ctx_rel_conv_extended_subst. +Qed. + + +Lemma conv_terms_conv_ctx {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} {ts ts'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + conv_context_rel Σ Γ Δ Δ' -> + conv_terms Σ (Γ ,,, Δ') ts ts' -> + conv_terms Σ (Γ ,,, Δ) ts ts'. +Proof. + intros wfl wfr cum conv. + eapply (All2_impl conv). + intros x y xy. + eapply conv_conv_ctx; tea. + apply conv_context_sym; tea. + now eapply conv_context_app. +Qed. + +Lemma conv_terms_cumul_ctx {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} {ts ts'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + cumul_ctx_rel Σ Γ Δ Δ' -> + conv_terms Σ (Γ ,,, Δ') ts ts' -> + conv_terms Σ (Γ ,,, Δ) ts ts'. +Proof. + intros wfl wfr cum conv. + eapply (All2_impl conv). + intros x y xy. + eapply conv_cumul_ctx; tea. + now eapply cumul_context_app. +Qed. + +Lemma conv_expand_lets_conv_ctx {cf} {Σ} {wfΣ : wf Σ} {Γ} {Δ Δ'} {T T'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + Σ ;;; Γ ,,, Δ |- T = T' -> + conv_context_rel Σ Γ Δ Δ' -> + Σ ;;; Γ ,,, smash_context [] Δ |- expand_lets Δ T = expand_lets Δ' T'. +Proof. + intros wfl wfr cum cumΓ. + rewrite /expand_lets /expand_lets_k. + rewrite -(length_of cumΓ). + rewrite -(conv_ctx_rel_context_assumptions cumΓ). + change (Γ ,,, smash_context [] Δ) with (Γ ,,, smash_context [] Δ ,,, []). + eapply (subst_conv _ _ _ []); tea. + 3:{ eapply conv_ctx_rel_conv_extended_subst; tea. } + * eapply PCUICContexts.subslet_extended_subst; tea. + * eapply subslet_conv_ctx; cycle 2. + + eapply conv_ctx_rel_smash; tea. + + eapply PCUICContexts.subslet_extended_subst; tea. + + now eapply wf_local_smash_end. + + now eapply wf_local_smash_end. + * simpl. + rewrite -[context_assumptions _](smash_context_length [] Δ). + eapply weakening_wf_local; tea. + now apply wf_local_smash_end. + * simpl. + rewrite -[context_assumptions _](smash_context_length [] Δ). + now eapply weakening_conv. +Qed. + +Lemma cumul_expand_lets_cumul_ctx {cf} {Σ} {wfΣ : wf Σ} {Γ} {Δ Δ'} {T T'} : + wf_local Σ (Γ ,,, Δ) -> + wf_local Σ (Γ ,,, Δ') -> + Σ ;;; Γ ,,, Δ |- T <= T' -> + cumul_ctx_rel Σ Γ Δ Δ' -> + Σ ;;; Γ ,,, smash_context [] Δ |- expand_lets Δ T <= expand_lets Δ' T'. +Proof. + intros wfl wfr cum cumΓ. + rewrite /expand_lets /expand_lets_k. + rewrite -(length_of cumΓ). + rewrite -(cumul_ctx_rel_context_assumptions cumΓ). + change (Γ ,,, smash_context [] Δ) with (Γ ,,, smash_context [] Δ ,,, []). + eapply (subst_cumul _ _ _ []); tea. + 3:{ eapply cumul_ctx_rel_conv_extended_subst; tea. } + * eapply PCUICContexts.subslet_extended_subst; tea. + * eapply subslet_cumul_ctx; cycle 2. + + eapply cumul_ctx_rel_smash; tea. + + eapply PCUICContexts.subslet_extended_subst; tea. + + now eapply wf_local_smash_end. + + now eapply wf_local_smash_end. + * simpl. + rewrite -[context_assumptions _](smash_context_length [] Δ). + eapply weakening_wf_local; tea. + now apply wf_local_smash_end. + * simpl. + rewrite -[context_assumptions _](smash_context_length [] Δ). + now eapply weakening_cumul. +Qed. + +Lemma ctx_inst_cumul {cf} {Σ} {wfΣ : wf Σ} {Γ i Δ Δ'} : + cumul_ctx_rel Σ Γ Δ Δ' -> + ctx_inst Σ Γ i (List.rev Δ) -> + wf_local_rel Σ Γ Δ -> + wf_local_rel Σ Γ Δ' -> + ctx_inst Σ Γ i (List.rev Δ'). +Proof. + induction 1 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. simpl in t0. + destruct i as [|i t] using rev_case. + { rewrite skipn_nil in H => //. } + assert (context_assumptions (List.rev Γ0) = #|i|). + apply (f_equal (@length _)) in H. simpl in H. + rewrite List.skipn_length app_length /= in H. lia. + rewrite skipn_all_app_eq // in H. noconf H. + intros HΔ; depelim HΔ. + intros HΔ'; depelim HΔ'. + destruct l0 as [s Hs]. simpl. + rewrite (ctx_inst_sub_subst dom) in t0. + rewrite (firstn_app_left _ 0) ?firstn_0 // ?Nat.add_0_r // app_nil_r in dom. + specialize (IHX _ dom HΔ HΔ'). + eapply (ctx_inst_app IHX). + simpl. constructor; [|constructor]. + rewrite (ctx_inst_sub_subst IHX). + rewrite (firstn_app_left _ 0) ?firstn_0 // ?Nat.add_0_r // app_nil_r in t0. + simpl. + rewrite context_assumptions_rev in H0. + assert (context_assumptions Γ' = #|i|) by now rewrite -(cumul_ctx_rel_context_assumptions X). + rewrite map_subst_expand_lets in t0; len=> //. + rewrite map_subst_expand_lets; len=> //. + unshelve epose proof (ctx_inst_spine_subst _ IHX); tea. + now eapply typing_wf_local in Hs. + eapply spine_subst_smash in X0; tea. + econstructor; tea. + + red in Hs. + eapply typing_expand_lets in Hs. + eapply (substitution _ _ _ (List.rev i) []) in Hs; tea. + simpl in Hs. now rewrite subst_context_nil /= in Hs. + exact X0. + + unshelve epose proof (ctx_inst_spine_subst _ dom); tea. + eapply wf_local_app; tea. now eapply typing_wf_local. + pose proof (spine_codom_wf _ _ _ _ _ X1). + eapply spine_subst_smash in X1; tea. + unshelve eapply (substitution_cumul _ _ _ [] _ _ _ _ _ X1). + simpl. eapply X1. simpl. + eapply cumul_expand_lets_cumul_ctx; tea. + now eapply typing_wf_local in Hs. + * 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. + rewrite List.skipn_length /= in H. + apply firstn_length_le_inv in H0. lia. + rewrite H0 in H, dom. rewrite firstn_all in dom. + intros HΔ; depelim HΔ. + intros HΔ'; depelim HΔ'. + destruct l as [s Hs]. simpl in l0. + red in Hs, l0. + specialize (IHX _ dom). + forward IHX. apply wf_local_app_inv; pcuic. + forward IHX. apply wf_local_app_inv; pcuic. + red in l2. pcuic. + simpl. + rewrite -(app_nil_r i). + eapply (ctx_inst_app IHX). simpl. + rewrite (ctx_inst_sub_subst IHX) /=. + constructor. constructor. +Qed. + +(* Fixpoint smash_telescope (Γ Δ : telescope) : telescope := + match Δ with + | ({| decl_body := None |} as d) :: Δ => + d :: smash_telescope Δ + | {| decl_body := Some b |} :: Δ => + subst_telescope [b] 0 Δ *) + +Lemma subst_context_rev_subst_telescope s k Γ : + subst_context s k (List.rev Γ) = List.rev (subst_telescope s k Γ). +Proof. + induction Γ in s, k |- *. + - simpl; auto. + - rewrite subst_telescope_cons /= subst_context_app IHΓ. + reflexivity. +Qed. + +Lemma ctx_inst_smash_acc {cf} {Σ} {Γ i Δ} : + ctx_inst Σ Γ i Δ <~> + ctx_inst Σ Γ i (List.rev (smash_context [] (List.rev Δ))). +Proof. + split. + - induction 1. + + constructor. + + simpl. + rewrite smash_context_app_ass. len. + rewrite List.rev_app_distr /=. + constructor. auto. + rewrite subst_telescope_subst_context. + rewrite -smash_context_subst /=; len. + now rewrite subst_context_rev_subst_telescope. + + simpl. rewrite smash_context_app_def. + now rewrite subst_context_rev_subst_telescope. + - induction Δ using ctx_length_ind in i |- *; simpl; auto. + destruct d as [na [b|] ty] => /=. + * rewrite smash_context_app_def /=. + rewrite subst_context_rev_subst_telescope. + intros ctxi. constructor. + apply X => //. now rewrite subst_telescope_length //. + * rewrite smash_context_app_ass List.rev_app_distr /=. + intros ctxi; depelim ctxi. + constructor => //. + apply X. rewrite subst_telescope_length //. + rewrite subst_telescope_subst_context in ctxi. + rewrite -(smash_context_subst []) in ctxi. + now rewrite subst_context_rev_subst_telescope in ctxi. +Qed. + +Lemma ctx_inst_smash {cf} {Σ} {Γ i Δ} : + ctx_inst Σ Γ i (List.rev Δ) <~> + ctx_inst Σ Γ i (List.rev (smash_context [] Δ)). +Proof. + split; intros. + - apply (fst ctx_inst_smash_acc) in X. now rewrite List.rev_involutive in X. + - apply (snd ctx_inst_smash_acc). now rewrite List.rev_involutive. +Qed. + +Lemma subst_context_subst_telescope s k Γ : + subst_context s k (List.rev Γ) = List.rev (subst_telescope 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'; len; lia_f_equal. +Qed. + +Lemma cumul_ctx_rel_app {cf} {Σ Γ Δ Δ'} : + cumul_ctx_rel Σ Γ Δ Δ' <~> cumul_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). +Proof. + split. + - intros; eapply PCUICContextRelation.All2_fold_app. + apply (length_of X). reflexivity. apply X. + - intros; eapply PCUICContextRelation.All2_fold_app_inv. + move: (length_of X); len; lia. + assumption. +Qed. + +Lemma cumul_ctx_rel_trans {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ Δ' Δ''} : + cumul_ctx_rel Σ Γ Δ Δ' -> + cumul_ctx_rel Σ Γ Δ' Δ'' -> + cumul_ctx_rel Σ Γ Δ Δ''. +Proof. + move/cumul_ctx_rel_app => h /cumul_ctx_rel_app h'. + apply cumul_ctx_rel_app. + now eapply cumul_context_trans; tea. +Qed. + +Lemma subslet_def {cf} {Σ : global_env_ext} {Γ Δ s na t T t'} : + subslet Σ Γ s Δ -> + Σ;;; Γ |- subst0 s t : subst0 s T -> + t' = subst0 s t -> + subslet Σ Γ (t' :: s) (Δ ,, vdef na t T). +Proof. + now intros sub Ht ->; constructor. +Qed. + +Lemma subslet_ass_tip {cf} {Σ : global_env_ext} {Γ na t T} : + Σ;;; Γ |- t : T -> + subslet Σ Γ [t] [vass na T]. +Proof. + intros; constructor. constructor. + all:now rewrite !subst_empty. +Qed. + +Lemma subslet_def_tip {cf} {Σ : global_env_ext} {Γ na t T} : + Σ;;; Γ |- t : T -> + subslet Σ Γ [t] [vdef na t T]. +Proof. + intros; apply subslet_def. constructor. + all:now rewrite !subst_empty. +Qed. + +Lemma OnOne2_ctx_inst {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {P} {Γ inst inst' Δ} : + (forall Γ Δ' Δ s s', wf_local Σ (Γ ,,, Δ' ,,, Δ) -> + subslet Σ Γ (List.rev s) Δ' -> + subslet Σ Γ (List.rev s') Δ' -> + OnOne2 (P Σ Γ) s s' -> + conv_context Σ (Γ ,,, subst_context (List.rev s) 0 Δ) + (Γ ,,, subst_context (List.rev s') 0 Δ)) -> + wf_local Σ (Γ ,,, (List.rev Δ)) -> + PCUICTyping.ctx_inst + (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + forall u : term, P Σ Γ t u -> Σ;;; Γ |- u : T) Σ Γ inst Δ -> + ctx_inst Σ Γ inst Δ -> + OnOne2 (P Σ Γ) inst inst' -> + ctx_inst Σ Γ inst' Δ. +Proof. + intros HP wf c. + induction c in inst', wf |- *; intros ctxi; depelim ctxi; intros o. + - depelim o. + - 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. + eapply ctx_inst_cumul. + 2:{ instantiate (1:=subst_context [i] 0 (List.rev Δ)). + rewrite -subst_telescope_subst_context List.rev_involutive. exact ctxi. } + eapply cumul_ctx_rel_app. + eapply conv_cumul_context. + eapply (HP _ _ _ [i] [hd']); tea. + repeat constructor. now rewrite subst_empty. repeat constructor. + now rewrite subst_empty. constructor. auto. + eapply wf_local_app_inv. eapply substitution_wf_local; tea. + repeat (constructor; tea). rewrite subst_empty; tea. + eapply wf_local_app_inv. eapply substitution_wf_local; tea. + repeat (constructor; tea). rewrite subst_empty; tea. now eapply t0. + constructor; auto. eapply IHc. + rewrite -subst_context_subst_telescope. + eapply substitution_wf_local; tea. + repeat (constructor; tea). rewrite subst_empty; tea. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + exact wf. tas. tas. + - constructor. eapply IHc; eauto. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + rewrite -subst_context_subst_telescope. + eapply substitution_wf_local; tea. + repeat (constructor; tea). eapply subslet_def_tip. + eapply wf_local_app_inv in wf as [wf _]. now depelim wf. +Qed. + +Lemma All2_ctx_inst {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {P} {Γ inst inst' Δ} : + (forall Γ Δ' Δ s s', wf_local Σ (Γ ,,, Δ' ,,, Δ) -> + subslet Σ Γ (List.rev s) Δ' -> + subslet Σ Γ (List.rev s') Δ' -> + All2 (P Σ Γ) s s' -> + conv_context Σ (Γ ,,, subst_context (List.rev s) 0 Δ) + (Γ ,,, subst_context (List.rev s') 0 Δ)) -> + wf_local Σ (Γ ,,, (List.rev Δ)) -> + PCUICTyping.ctx_inst + (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + forall u : term, P Σ Γ t u -> Σ;;; Γ |- u : T) Σ Γ inst Δ -> + ctx_inst Σ Γ inst Δ -> + All2 (P Σ Γ) inst inst' -> + ctx_inst Σ Γ inst' Δ. +Proof. + intros HP wf c. + induction c in inst', wf |- *; intros ctxi; depelim ctxi; intros o. + - depelim o. constructor. + - 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. + eapply ctx_inst_cumul. + 2:{ instantiate (1:=subst_context [i] 0 (List.rev Δ)). + rewrite -subst_telescope_subst_context List.rev_involutive. eapply IHc => //. + rewrite -subst_context_subst_telescope. + eapply substitution_wf_local; tea. + repeat (constructor; tea). rewrite subst_empty; tea. } + eapply cumul_ctx_rel_app. + eapply conv_cumul_context. + eapply (HP _ _ _ [i] [y]); tea. + repeat constructor. now rewrite subst_empty. + now apply subslet_ass_tip. + now repeat constructor. + * eapply wf_local_app_inv. eapply substitution_wf_local; tea. + now apply subslet_ass_tip. + * eapply wf_local_app_inv. eapply substitution_wf_local; tea. + now apply subslet_ass_tip. + - constructor. eapply IHc; eauto. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + rewrite -subst_context_subst_telescope. + eapply substitution_wf_local; tea. + repeat (constructor; tea). eapply subslet_def_tip. + eapply wf_local_app_inv in wf as [wf _]. now depelim wf. +Qed. + +Lemma ctx_inst_eq_context {cf} {Σ : global_env_ext} {Γ} {wfΣ : wf Σ} {Δ : context} {args args'} : + 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 Δ -> + All2 upto_names' args args' -> + ctx_inst Σ Γ args' Δ. +Proof. + intros wf ctxi ctxi' a. + eapply All2_ctx_inst; tea. + 2:exact ctxi. 2:auto. + cbn; clear -wfΣ; intros. + eapply conv_context_rel_app. + eapply (conv_ctx_subst (Γ'':=[])); tea. + eapply conv_context_rel_app; reflexivity. + eapply All2_rev. + eapply All2_impl; tea. + intros. constructor. now apply upto_names_impl_eq_term. + now eapply subslet_untyped_subslet. + now eapply subslet_untyped_subslet. +Qed. \ No newline at end of file diff --git a/pcuic/theories/PCUICStrengthening.v b/pcuic/theories/PCUICStrengthening.v new file mode 100644 index 000000000..1936343bd --- /dev/null +++ b/pcuic/theories/PCUICStrengthening.v @@ -0,0 +1,813 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Morphisms. +From MetaCoq.Template Require Import config utils. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction + PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICTyping PCUICWeakeningEnv + PCUICClosed PCUICReduction PCUICPosition PCUICGeneration + PCUICSigmaCalculus PCUICRename PCUICOnFreeVars. + +Require Import ssreflect ssrbool. +From Equations Require Import Equations. + +Implicit Types cf : checker_flags. + +Definition noccur_between_decl k n d := + option_default (noccur_between k n) d.(decl_body) true && + noccur_between k n d.(decl_type). + +Definition noccur_between_ctx k n (t : context) : bool := + alli (fun k' => noccur_between_decl (k + k') n) 0 (List.rev t). + +Lemma noccur_between_ctx_cons k n d Γ : + noccur_between_ctx k n (d :: Γ) = + noccur_between_decl (k + #|Γ|) n d && noccur_between_ctx k n Γ. +Proof. + unfold noccur_between_ctx. + simpl. rewrite alli_app /= andb_true_r. + now rewrite Nat.add_0_r List.rev_length andb_comm. +Qed. + + +Lemma shiftn_ext_noccur_between f f' k n k' i : + (i < k' + k \/ k' + k + n <= i) -> + (forall i, i < k \/ k + n <= i -> f i = f' i) -> + shiftn k' f i = shiftn k' f' i. +Proof. + intros. + unfold shiftn. destruct (Nat.ltb_spec i k'). + - auto. + - rewrite H0; auto. lia. +Qed. + +Lemma rename_ext_cond f f' k n : (forall i, i < k \/ k + n <= i -> f i = f' i) -> + (forall t, noccur_between k n t -> rename f t = rename f' t). +Proof. +intros. revert k n t H0 f f' H. +apply: term_noccur_between_list_ind; simpl in |- *; intros; try easy ; + try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); + try solve [f_equal; solve_all]. +- f_equal; auto. apply H0. intros. + eapply (shiftn_ext_noccur_between f f' k n); eauto. +- f_equal; auto. apply H0. intros. + eapply (shiftn_ext_noccur_between f f' k n); eauto. +- f_equal; auto. eapply H1. intros. + eapply (shiftn_ext_noccur_between f f' k n); eauto. +- destruct X. f_equal; auto; solve_all. + * apply e. intros. + eapply (shiftn_ext_noccur_between f f' k n); eauto. + * apply map_branch_eq_spec. apply H1. + intros; eapply (shiftn_ext_noccur_between f f' k n); eauto. +- red in X. f_equal; solve_all. + eapply map_def_eq_spec; auto. apply b. + rewrite fix_context_length. + intros; eapply (shiftn_ext_noccur_between f f' k n); eauto. +- f_equal; auto. red in X. solve_all. + eapply map_def_eq_spec; auto. apply b. + rewrite fix_context_length. + intros. eapply (shiftn_ext_noccur_between f f' k n); eauto. +Qed. + +Lemma rename_decl_ext_cond f f' k n : (forall i, i < k \/ k + n <= i -> f i = f' i) -> + (forall t, noccur_between_decl k n t -> rename_decl f t = rename_decl f' t). +Proof. + intros Hi d. move/andb_and=> [clb clt]. + rewrite /rename_decl. + destruct d as [na [b|] ty] => /=; rewrite /map_decl /=; simpl in *; f_equal. + - f_equal. now eapply rename_ext_cond. + - now eapply rename_ext_cond. + - now eapply rename_ext_cond. +Qed. + + +Definition strengthen k n := + fun i => if i + shiftn k (strengthen k' n) i = strengthen (k + k') n i. +Proof. + rewrite /shiftn /strengthen. + destruct (Nat.ltb_spec i k); auto. + - destruct (Nat.ltb_spec i (k + k')); lia. + - destruct (Nat.ltb_spec (i - k) k'); destruct (Nat.ltb_spec i (k + k')); lia. +Qed. + +Lemma shiftn_strengthen k k' n t : + noccur_between (k' + k) n t -> + rename (shiftn k (strengthen k' n)) t = rename (strengthen (k + k') n) t. +Proof. + intros nocc. + eapply rename_ext_cond; tea. + intros. eapply shiftn_strengthen_rel. lia. +Qed. + +Definition strengthen_context (Γ Γs Δ : context) := + Γ ,,, rename_context (strengthen 0 #|Γs|) Δ. + +Definition strengthen_rename Δ Γs i := + if i + nth_error (strengthen_context Γ Γs Δ') (strengthen #|Δ| #|Γs| i) = + option_map (map_decl (rename (strengthen_rename #|Δ| #|Γs| i))) + (nth_error (Γ ,,, Γs ,,, Δ') i). +Proof. + simpl. + rewrite /strengthen_context /strengthen /nocc_betweenp. + (* Again, => _ is counter-intuitive to me here. e.g when doing + repeat (nat_compare_specs => /= //) => /= _. it's not equivalent + to the line below. + *) + repeat (nat_compare_specs => /= //). all:move=> _. + * rewrite (nth_error_app_context_ge i); len => //. + rewrite (nth_error_app_context_ge (i - #|Δ|)); len; try lia => //. + rewrite (nth_error_app_context_ge (i - #|Γs|)); len; try lia => //. + replace (i - #|Δ| - #|Γs|) with (i - #|Γs| - #|Δ|) by lia. + destruct nth_error => /= //. f_equal. + rewrite -{1}[c](map_decl_id c). + apply map_decl_ext => x. + rewrite -(rename_ren_id x). + apply rename_ext. + rewrite /strengthen_rename. nat_compare_specs. + reflexivity. + * rewrite nth_error_app_lt; len => //. + rewrite nth_error_app_lt; len => //. + rewrite /rename_context. + rewrite nth_error_lift_context_eq Nat.add_0_r. + rewrite /lift_context fold_context_k_compose option_map_two. + destruct (nth_error Δ i) eqn:hnth => //. + + rewrite (nth_error_fold_context_k _ _ _ _ _ _ hnth) /=; eauto. + f_equal. rewrite compose_map_decl. apply map_decl_ext => t. + rewrite !lift_rename !rename_compose. + eapply rename_ext => k. + rewrite /strengthen_rename /shiftn /lift_renaming /= /strengthen. + now repeat nat_compare_specs => /= //. + + now apply nth_error_None in hnth. +Qed. + +Lemma strengthen_shiftn k n : strengthen k n ∘ (shiftn k (rshiftk n)) =1 id. +Proof. + intros i; rewrite /strengthen /shiftn /rshiftk /id. + repeat nat_compare_specs. +Qed. + +Lemma rshiftk_shiftn k n l i : rshiftk k (shiftn n l i) = shiftn (n + k) l (rshiftk k i). +Proof. + intros. + rewrite /rshiftk. + rewrite /shiftn. repeat nat_compare_specs. + replace (k + i - (n + k)) with (i - n) by lia. lia. +Qed. + +Lemma S_rshiftk k n : S (rshiftk k n) = rshiftk (S k) n. +Proof. reflexivity. Qed. + +Lemma strengthen_lift_renaming n k i : strengthen k n (lift_renaming n k i) = i. +Proof. + rewrite /strengthen /lift_renaming. + repeat nat_compare_specs. +Qed. + +Lemma strengthen_lift n k t : rename (strengthen k n) (lift n k t) = t. +Proof. + rewrite lift_rename rename_compose. + setoid_rewrite strengthen_lift_renaming. + now rewrite rename_ren_id. +Qed. + + +Lemma strengthen_lift_ctx n k t : rename_context (strengthen k n) (lift_context n k t) = t. +Proof. + rewrite -rename_context_lift_context. + rewrite /rename_context fold_context_k_compose. + rewrite -{2}(fold_context_k_id t). + apply fold_context_k_ext => i x. + rewrite rename_compose shiftn_compose. + setoid_rewrite strengthen_lift_renaming. + now rewrite shiftn_id rename_ren_id. +Qed. + +Lemma strengthen_urenaming_gen Γ Γs Δ : + let Δ' := lift_context #|Γs| 0 Δ in + urenaming (nocc_betweenp #|Δ| #|Γs|) + (strengthen_context Γ Γs Δ') + (Γ ,,, Γs ,,, Δ') + (strengthen #|Δ| #|Γs|). +Proof. + intros Δ' i d hpi hnth. + rewrite lookup_strengthen_context /= // hnth /=. + eexists; split; eauto. + destruct d as [na b ty]; simpl in *. + unfold nocc_betweenp in hpi. + move/orP: hpi. intros hi. + move: hnth. rewrite /Δ'. + move: hi => []; [move/Nat.ltb_lt|move/Nat.leb_le] => hi. + - rewrite nth_error_app_context_lt; len; try lia. + rewrite nth_error_lift_context_eq Nat.add_0_r. + destruct nth_error eqn:hnth => /= // [=] <- <- <-. + repeat split. + + rewrite rename_compose lift_rename !rename_compose. + apply rename_ext. + intros k. + change (S (rshiftk i (lift_renaming #|Γs| (#|Δ| - S i) k))) + with (rshiftk (S i) (lift_renaming #|Γs| (#|Δ| - S i) k)). + rewrite lift_renaming_spec. + rewrite /strengthen_rename. nat_compare_specs. + rewrite (strengthen_shiftn _ _ _) /id. + rewrite rshiftk_shiftn Nat.sub_add // S_rshiftk. + rewrite -lift_renaming_spec strengthen_lift_renaming. + rewrite /strengthen. nat_compare_specs. + + destruct (decl_body c) => /= //. + f_equal. + rewrite rename_compose lift_rename !rename_compose. + apply rename_ext. + intros k. + change (S (rshiftk i (lift_renaming #|Γs| (#|Δ| - S i) k))) + with (rshiftk (S i) (lift_renaming #|Γs| (#|Δ| - S i) k)). + rewrite lift_renaming_spec. + rewrite /strengthen_rename. nat_compare_specs. + rewrite (strengthen_shiftn _ _ _) /id. + rewrite rshiftk_shiftn Nat.sub_add // S_rshiftk. + rewrite -lift_renaming_spec strengthen_lift_renaming. + rewrite /strengthen. nat_compare_specs. + - rewrite nth_error_app_context_ge; len; try lia. + rewrite nth_error_app_context_ge; len; try lia. + intros hnth. + repeat split. + + rewrite !rename_compose. + apply rename_ext => k. + rewrite /strengthen /strengthen_rename /rshiftk /id. + repeat nat_compare_specs. + + destruct b => //. simpl. f_equal. + rewrite !rename_compose. + apply rename_ext => k. + rewrite /strengthen /strengthen_rename /rshiftk /id. + repeat nat_compare_specs. +Qed. + +Lemma strengthen_urenaming Γ Γs Δ : + let Δ' := lift_context #|Γs| 0 Δ in + urenaming (nocc_betweenp #|Δ| #|Γs|) + (Γ ,,, Δ) + (Γ ,,, Γs ,,, Δ') + (strengthen #|Δ| #|Γs|). +Proof. + pose proof (strengthen_urenaming_gen Γ Γs Δ). + simpl in X. + rewrite /strengthen_context in X. + now rewrite strengthen_lift_ctx in X. +Qed. + +Lemma nth_error_noccur_between_ctx k n Γ i d : + noccur_between_ctx k n Γ -> + nth_error Γ i = Some d -> + noccur_between_decl (k + (#|Γ| - S i)) n d. +Proof. + rewrite /noccur_between_ctx. + intros alli nth. apply alli_Alli in alli. + eapply Alli_rev_nth_error in alli; eauto. +Qed. + + +Definition isLift n k t := + ∑ t', t = lift n k t'. + +Lemma isLift_rel n k i : + isLift n k (tRel i) -> nocc_betweenp k n i. +Proof. + intros [t' eq]. destruct t' => //. + simpl in eq. noconf eq. + unfold nocc_betweenp. + repeat nat_compare_specs => /= //. +Qed. + +Lemma All_local_env_over_simpl {cf:checker_flags} Σ Γ : + forall wfΓ : wf_local Σ Γ, + All_local_env_over typing + (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ) + (t T : term) (_ : Σ;;; Γ |- t : T) => + forall Γl Γs Δ : context, + Γ = Γl,,, Γs,,, lift_context #|Γs| 0 Δ -> + isLift #|Γs| #|Δ| t -> + isLift #|Γs| #|Δ| T -> + Σ;;; Γl,,, Δ |- rename (strengthen #|Δ| #|Γs|) t + : rename (strengthen #|Δ| #|Γs|) T) Σ Γ wfΓ -> + All_local_env + (lift_typing (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + forall Γl Γs Δ : context, + Γ = Γl,,, Γs,,, lift_context #|Γs| 0 Δ -> + isLift #|Γs| #|Δ| t -> + isLift #|Γs| #|Δ| T -> + Σ;;; Γl,,, Δ |- rename (strengthen #|Δ| #|Γs|) t + : rename (strengthen #|Δ| #|Γs|) T) Σ) Γ. +Proof. + intros wfΓ. unfold lift_typing. + induction 1; constructor; intuition auto. + - destruct tu as [s Hs]; exists s; intuition auto. + - destruct tu as [s Hs]; exists s; intuition auto. +Qed. + +Lemma isLift_lift n k t : isLift n k (lift n k t). +Proof. eexists; eauto. Qed. + +Definition is_strengthenable {cf:checker_flags} {Σ Γ t T} (d : Σ ;;; Γ |- t : T) (k n : nat) : bool. +Proof. + revert Γ t T d k. + fix aux 4. + intros. destruct d. + - exact (nocc_betweenp k n n0). + - exact true. + - exact (aux _ _ _ d1 k && aux _ _ _ d2 (S k)). + - exact (aux _ _ _ d1 k && aux _ _ _ d2 (S k)). + - exact [&& aux _ _ _ d1 k, aux _ _ _ d2 k & aux _ _ _ d3 (S k)]. + - exact [&& aux _ _ _ d1 k, aux _ _ _ d2 k & aux _ _ _ d3 k]. + - exact true. + - exact true. + - exact true. + - exact true. + - exact true. + - exact true. + - exact true. + - exact (aux _ _ _ d1 k && aux _ _ _ d2 k). +Defined. + +Lemma is_strengthenable_isLift {cf:checker_flags} {Σ Γ t T} (d : Σ ;;; Γ |- t : T) {n k}: + is_strengthenable d k n -> + isLift n k t × isLift n k T. +Proof. + induction d in n, k |- *; simpl; intros. + - admit. + - split; eexists (tSort _); simpl; eauto. + - move/andP: H => [isd1 isd2]. + specialize (IHd1 _ _ isd1) as [[A' ->] _]. + specialize (IHd2 _ _ isd2) as [[B' ->] _]. + split. + * eexists (tProd na _ _); simpl; eauto. + * now eexists (tSort _). + - admit. + - admit. + - move/and3P: H => [hd1 hd2 hd3]. + specialize (IHd1 _ _ hd1) as [[p' eq] _]. + specialize (IHd2 _ _ hd2) as [[? ->] _]. + specialize (IHd3 _ _ hd3) as [[? ->] ?]. + split. + * now eexists (tApp _ _). + * destruct p' => //. + noconf eq. + rewrite /subst1. + rewrite -(distr_lift_subst_rec _ [_]) /=. + now eexists _. + - split. + * now eexists (tConst _ _). + * admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - move/andP: H => [hd1 hd2]. + split. + * apply (IHd1 _ _ hd1). + * eapply (IHd2 _ _ hd2). +Admitted. + +Lemma typing_rename_prop {cf:checker_flags} : + forall Σ {wfΣ : wf Σ.1} Γ t T (d : Σ ;;; Γ |- t : T), + forall Γl Γs Δ, + is_strengthenable d #|Δ| #|Γs| -> + Γ = Γl ,,, Γs ,,, lift_context #|Γs| 0 Δ -> + Σ ;;; Γl ,,, Δ |- rename (strengthen #|Δ| #|Γs|) t : rename (strengthen #|Δ| #|Γs|) T. +Proof. + intros Σ wfΣ Γ t T d Γl. induction d; simpl. + - intros ? ? hn ->. admit. + - intros. admit. + - intros ? ?. + move/andP => [isd1 isd2]. intros ->. + rewrite /=. econstructor. + + eapply IHd1; eauto. + + specialize (IHd1 _ _ isd1 eq_refl). + pose proof (is_strengthenable_isLift _ isd1) as [[A' ->] _]. + specialize (IHd2 _ (Δ,, vass na A') isd2). + forward IHd2. { now rewrite lift_context_snoc Nat.add_0_r. } + rewrite strengthen_lift. + rewrite shiftn_strengthen. { pose proof (is_strengthenable_isLift _ isd2). admit. } + apply IHd2. + - admit. + - admit. + - intros ? ?. move/and3P => [hd1 hd2 hd3]; intros ->. + specialize (IHd1 _ _ hd1 eq_refl). + specialize (IHd2 _ _ hd2 eq_refl). + specialize (IHd3 _ _ hd3 eq_refl). + eapply meta_conv. + + eapply type_App. + * simpl in IHd1. eapply IHd1; tea. + * simpl in IHd2. eapply IHd2. + * eapply IHd3. + + now rewrite rename_subst10. + - intros. + autorewrite with sigma. + admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - intros Γs Δ. move/andP=> [hd1 hd2]. intros ->. + specialize (IHd1 _ _ hd1 eq_refl). + specialize (IHd2 _ _ hd2 eq_refl). + epose proof (is_strengthenable_isLift _ hd1). + epose proof (is_strengthenable_isLift _ hd2). + eapply type_Cumul; eauto. + eapply cumul_renameP; eauto. + * apply (strengthen_urenaming Γl Γs Δ). + * destruct X. admit. +Admitted. + +Lemma noccur_iss {cf:checker_flags} : + forall Σ {wfΣ : wf Σ.1} Γ t T (d : Σ ;;; Γ |- t : T), + forall Γl Γs Δ, + Γ = Γl ,,, Γs ,,, lift_context #|Γs| 0 Δ -> + isLift #|Γs| #|Δ| t -> + ∑ T' (d' : Σ ;;; Γ |- t : T'), (is_strengthenable d' #|Δ| #|Γs|) × cumul Σ Γ T' T. +Proof. + intros. induction d in Γs, Δ, X |- *. + - eexists; unshelve eexists; [econstructor; eauto|]. + simpl. split; auto. 2:reflexivity. admit. + - admit. + - admit. + - admit. + - admit. + - destruct X as [[] ?]; noconf e. + specialize (IHd2 _ _ (isLift_lift _ _ _)) as [? [IHd2 [isd2 ?]]]. + specialize (IHd3 _ _ (isLift_lift _ _ _)) as [? [IHd3 [isd3 ?]]]. + pose proof (is_strengthenable_isLift _ isd2) as [? [? ->]]. + eapply invert_cumul_prod_r in c as [? [? [? [[[? ?] ?] ?]]]]. + exists (x3 {0 := (lift #|Γs| #|Δ| v)}). + unshelve eexists. + * epose proof (type_reduction IHd2 r). + econstructor. + 2:eauto. 1:admit. + eapply type_Cumul'. + + eapply IHd3. + + admit. + + admit. + * simpl. admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - specialize (IHd1 _ _ X) as [A' [dA' [? ?]]]. + exists A', dA'. split; auto. admit. +Admitted. + + +Lemma all_free_vars_true t : all_free_vars xpredT t. +Proof. +Admitted. + +Lemma strengthen_thm {cf} : forall Σ {wfΣ : wf Σ.1} Γ t T (d : Σ ;;; Γ |- t : T), + forall Γl Γs Δ, + Γ = Γl ,,, Γs ,,, lift_context #|Γs| 0 Δ -> + isLift #|Γs| #|Δ| t -> + isLift #|Γs| #|Δ| T -> + Σ ;;; Γl ,,, Δ |- rename (strengthen #|Δ| #|Γs|) t : rename (strengthen #|Δ| #|Γs|) T. +Proof. + intros. + pose proof (noccur_iss _ _ _ _ d _ _ _ H X) as [T' [d' [isd cum]]]. + pose proof (typing_rename_prop _ _ _ _ d' _ _ _ isd H). + eapply type_Cumul'; eauto. + * destruct X0 as [? ->]. + rewrite strengthen_lift. admit. + * subst Γ. eapply cumul_renameP; eauto. + + eapply strengthen_urenaming. + + epose proof (is_strengthenable_isLift _ isd). admit. + + admit. + + unfold on_ctx_free_vars. + rewrite alli_app. apply/andP; split. + - rewrite /lift_context. + rewrite alli_fold_context_k_prop. + clear. eapply alli_Alli. + eapply forall_nth_error_Alli. + intros i x hnth. simpl. + eapply nth_error_Some_length in hnth. + rewrite {1}/nocc_betweenp. nat_compare_specs. + nat_compare_specs. simpl. + rewrite Nat.add_0_r. + rewrite /all_free_vars_decl. + rewrite test_decl_map_decl. + eapply (test_decl_impl (fun _ => true)). + { intros k _. + eapply all_free_vars_impl. + 2:{ erewrite all_free_vars_lift. apply all_free_vars_true. } + intros k'. + rewrite /strengthenP /nocc_betweenp /addnP. + repeat nat_compare_specs => /= //. } + destruct x as [na [?|] ? ]=> //. +Admitted. + +Lemma typing_rename_prop {cf:checker_flags} : env_prop + (fun Σ Γ t A => + forall Γl Γs Δ, + Γ = Γl ,,, Γs ,,, lift_context #|Γs| 0 Δ -> + isLift #|Γs| #|Δ| t -> + isLift #|Γs| #|Δ| A -> + Σ ;;; Γl ,,, Δ |- rename (strengthen #|Δ| #|Γs|) t : rename (strengthen #|Δ| #|Γs|) A) + (fun Σ Γ => + forall Γl Γs Δ, + Γ = Γl ,,, Γs ,,, lift_context #|Γs| 0 Δ -> + wf_local Σ (Γl ,,, Δ)). +Proof. + apply typing_ind_env. + + - intros Σ wfΣ Γ wfΓ HΓ. + intros Γl Γs Δ ->. + eapply wf_local_app. { clear HΓ. eapply wf_local_app_inv in wfΓ as [wfΓ _]. + now apply wf_local_app_inv in wfΓ as []. } + apply All_local_env_over_simpl in HΓ. + apply All_local_env_app_inv in HΓ as [Hl HΔ]. + clear Hl. apply All_local_env_fold in HΔ. clear -HΔ. + induction HΔ; constructor; firstorder eauto. + * red. exists x. + specialize (p _ _ _ eq_refl). rewrite Nat.add_0_r in p. + specialize (p (isLift_lift _ _ _) ((tSort x); eq_refl)). + simpl in p. now rewrite strengthen_lift in p. + * red. exists x. + specialize (p _ _ _ eq_refl). rewrite Nat.add_0_r in p. + specialize (p (isLift_lift _ _ _) ((tSort x); eq_refl)). + simpl in p. now rewrite strengthen_lift in p. + * red. + specialize (t1 _ _ _ eq_refl). rewrite Nat.add_0_r in t1. + specialize (t1 (isLift_lift _ _ _) (isLift_lift _ _ _)). + simpl in t1. now rewrite !strengthen_lift in t1. + + - intros Σ wfΣ Γ wfΓ n decl isdecl ihΓ Γl Γs Δ -> islt isla. + simpl in *. specialize (ihΓ _ _ _ eq_refl). + have hf := strengthen_urenaming Γl Γs Δ. + eapply hf in isdecl as h => //. + 2:{ now apply isLift_rel in islt. } + destruct h as [decl' [isdecl' [? [h1 h2]]]]. + rewrite lift0_rename rename_compose h1 -lift0_rename. + econstructor. all:auto. + rewrite /strengthen_context in isdecl'. + now rewrite strengthen_lift_ctx in isdecl'. + + - intros Σ wfΣ Γ wfΓ l X H0 ? ? ? -> isl isl'. + simpl. constructor. all: eauto. + + - intros Σ wfΣ Γ wfΓ na A B s1 s2 X hA ihA hB ihB ? ? ? -> isl isl'. + rewrite /=. econstructor. + + eapply ihA; eauto. all: admit. + + destruct isl. destruct x => //. simpl in e. noconf e. + specialize (ihB Γl Γs (Δ ,, vass na x1)). + forward ihB. { now rewrite lift_context_snoc Nat.add_0_r. } + specialize (ihB (isLift_lift _ _ _) (tSort _; eq_refl)). + rewrite strengthen_lift. + simpl in ihB. rewrite shiftn_strengthen. { admit. } + apply ihB. + + - intros Σ wfΣ Γ wfΓ na A t s1 B X hA ihA ht iht P Δ f hf. + simpl. + (* /andP [_ havB]. *) + simpl. econstructor. + + eapply ihA; eauto. + + eapply iht; eauto; simpl. + eapply renaming_extP. { now rewrite -(shiftnP_add 1). } + eapply renaming_vass. 2: eauto. + constructor. + * destruct hf as [hΔ hf]. auto. + * simpl. exists s1. eapply ihA; eauto. + - intros Σ wfΣ Γ wfΓ na b B t s1 A X hB ihB hb ihb ht iht P Δ f hf. + simpl. econstructor. + + eapply ihB; tea. + + eapply ihb; tea. + + eapply iht; tea. + eapply renaming_extP. { now rewrite -(shiftnP_add 1). } + eapply renaming_vdef. 2: eauto. + constructor. + * destruct hf. assumption. + * simpl. eexists. eapply ihB; tea. + * simpl. eapply ihb; tea. + - intros Σ wfΣ Γ wfΓ t na A B s u X hty ihty ht iht hu ihu P Δ f hf. + simpl. eapply meta_conv. + + eapply type_App. + * simpl in ihty. eapply ihty; tea. + * simpl in iht. eapply iht. eassumption. + * eapply ihu. eassumption. + + autorewrite with sigma. rewrite !subst1_inst. sigma. + eapply inst_ext => i. + unfold subst_cons, ren, shiftn, subst_compose. simpl. + destruct i. + * simpl. reflexivity. + * simpl. replace (i - 0) with i by lia. + reflexivity. + - intros Σ wfΣ Γ wfΓ cst u decl X X0 isdecl hconst P Δ f hf. + simpl. eapply meta_conv. + + constructor. all: eauto. apply hf. + + rewrite rename_subst_instance. f_equal. + rewrite rename_closed. 2: auto. + eapply declared_constant_closed_type. all: eauto. + - intros Σ wfΣ Γ wfΓ ind u mdecl idecl isdecl X X0 hconst P Δ σ hf. + simpl. eapply meta_conv. + + econstructor. all: eauto. apply hf. + + rewrite rename_subst_instance. f_equal. + rewrite rename_closed. 2: auto. + eapply declared_inductive_closed_type. all: eauto. + - intros Σ wfΣ Γ wfΓ ind i u mdecl idecl cdecl isdecl X X0 hconst P Δ f hf. + simpl. eapply meta_conv. + + econstructor. all: eauto. apply hf. + + rewrite rename_closed. 2: reflexivity. + eapply declared_constructor_closed_type. all: eauto. + - intros Σ wfΣ Γ wfΓ ci p c brs indices ps mdecl idecl isdecl HΣ. + intros IHΔ ci_npar predctx wfp Hpret IHpret IHpredctx isallowed. + intros Hc IHc iscof ptm wfbrs Hbrs P Δ f Hf. + simpl. + rewrite rename_mkApps. + rewrite map_app. simpl. + rewrite /ptm. rewrite rename_it_mkLambda_or_LetIn. + relativize #|predctx|. + * erewrite rename_predicate_preturn. + rewrite /predctx. + rewrite (rename_case_predicate_context isdecl wfp). + eapply type_Case; eauto. + + now eapply rename_wf_predicate. + + eapply IHpret. + rewrite -rename_case_predicate_context //. + split. + ++ apply All_local_env_app_inv in IHpredctx as []. + eapply wf_local_app_renaming; eauto. apply a0. + ++ rewrite /predctx. + rewrite -(case_predicate_context_length (ci:=ci) wfp). + eapply urenaming_ext. + { len. now rewrite -shiftnP_add. } + { reflexivity. } + eapply urenaming_context. apply Hf. + + simpl. unfold id. + specialize (IHc _ _ _ Hf). + now rewrite rename_mkApps map_app in IHc. + + now eapply rename_wf_branches. + + eapply Forall2_All2 in wfbrs. + eapply All2i_All2_mix_left in Hbrs; eauto. + eapply All2i_nth_hyp in Hbrs. + eapply All2i_map_right, (All2i_impl Hbrs) => i cdecl br. + set (brctxty := case_branch_type _ _ _ _ _ _ _ _). + move=> [Hnth [wfbr [[Hbr Hbrctx] [IHbr [Hbty IHbty]]]]]. + rewrite -(rename_closed_constructor_body mdecl cdecl f). + { eapply (declared_constructor_closed (c:=(ci.(ci_ind),i))); eauto. + split; eauto. } + rewrite rename_case_branch_type //. + rewrite -/brctxty. intros brctx'. + assert (wf_local Σ (Δ,,, brctx'.1)). + { rewrite /brctx'. cbn. + apply All_local_env_app_inv in Hbrctx as []. + eapply wf_local_app_renaming; tea. apply a0. } + repeat split. + ++ eapply IHbr. + split => //. + rewrite /brctx' /brctxty; cbn. + rewrite (wf_branch_length wfbr). + erewrite <- case_branch_type_length; eauto. + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + eapply urenaming_context, Hf. + ++ eapply IHbty. split=> //. + rewrite /brctx'; cbn. + rewrite (wf_branch_length wfbr). + erewrite <- case_branch_type_length; eauto. + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + eapply urenaming_context, Hf. + * rewrite /predctx case_predicate_context_length //. + - intros Σ wfΣ Γ wfΓ p c u mdecl idecl pdecl isdecl args X X0 hc ihc e ty + P Δ f hf. + simpl. eapply meta_conv. + + econstructor. + * eassumption. + * eapply meta_conv. + -- eapply ihc; tea. + -- rewrite rename_mkApps. simpl. reflexivity. + * rewrite map_length. assumption. + + rewrite rename_subst0. simpl. rewrite map_rev. f_equal. + rewrite rename_subst_instance. f_equal. + rewrite rename_closedn. 2: reflexivity. + eapply declared_projection_closed_type in isdecl. + rewrite List.rev_length. rewrite e. assumption. + + - intros Σ wfΣ Γ wfΓ mfix n decl types H1 hdecl X ihmfixt ihmfixb wffix P Δ f hf. + apply All_local_env_app_inv in X as [_ X]. + eapply wf_local_app_renaming in X; tea. + simpl. eapply meta_conv. + + eapply type_Fix. + * eapply fix_guard_rename; eauto. + * rewrite nth_error_map. rewrite hdecl. simpl. reflexivity. + * apply hf. + * apply All_map, (All_impl ihmfixt). + intros x [s [Hs IHs]]. + exists s. now eapply IHs. + * apply All_map, (All_impl ihmfixb). + intros x [Hb IHb]. + destruct x as [na ty bo rarg]. simpl in *. + rewrite rename_fix_context. + eapply meta_conv. + ++ apply (IHb P (Δ ,,, rename_context f types) (shiftn #|mfix| f)). + split; auto. subst types. rewrite -(fix_context_length mfix). + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + apply urenaming_context; auto. apply hf. + ++ len; now sigma. + * now eapply rename_wf_fixpoint. + + reflexivity. + + - intros Σ wfΣ Γ wfΓ mfix n decl types guard hdecl X ihmfixt ihmfixb wfcofix P Δ f hf. + apply All_local_env_app_inv in X as [_ X]. + eapply wf_local_app_renaming in X; eauto. + simpl. eapply meta_conv. + + eapply type_CoFix; auto. + * eapply cofix_guard_rename; eauto. + * rewrite nth_error_map. rewrite hdecl. simpl. reflexivity. + * apply hf. + * apply All_map, (All_impl ihmfixt). + intros x [s [Hs IHs]]. + exists s. now eapply IHs. + * apply All_map, (All_impl ihmfixb). + intros x [Hb IHb]. + destruct x as [na ty bo rarg]. simpl in *. + rewrite rename_fix_context. + eapply meta_conv. + ++ apply (IHb P (Δ ,,, rename_context f types) (shiftn #|mfix| f)). + split; auto. subst types. rewrite -(fix_context_length mfix). + eapply urenaming_ext. + { now rewrite app_context_length -shiftnP_add. } + { reflexivity. } + apply urenaming_context; auto. apply hf. + ++ len. now sigma. + * now eapply rename_wf_cofixpoint. + + reflexivity. + + - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht htB ihB cum P Δ f hf. + eapply type_Cumul. + + eapply iht; tea. + + eapply ihB; tea. + + eapply cumul_renameP. all: try eassumption. + * apply hf. + * pose proof (type_closed _ ht). + now eapply closedn_all_free_vars in H. + * pose proof (subject_closed _ htB). + now eapply closedn_all_free_vars in H. + * pose proof (closed_ctx_all_free_vars P _ (closed_wf_local _ (typing_wf_local ht))). + rewrite -{2}(app_context_nil_l Γ). + eapply on_ctx_free_vars_extend => //. +Qed. + + +Lemma strengthening_wf_local {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} : + wf_local Σ (Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'') -> + wf_local Σ (Γ ,,, Γ''). +Proof. + intros wfΓ'. + pose proof (env_prop_wf_local _ _ typing_rename_prop _ wfΣ _ wfΓ'). simpl in X. + eapply All_local_env_app_inv in X as [XΓ XΓ']. + apply wf_local_app_inv in wfΓ' as [wfΓ wfΓ'']. + apply wf_local_app_inv in wfΓ as [wfΓ wfΓ']. + apply wf_local_app => //. + apply All_local_env_fold in XΓ'. + eapply (All_local_env_impl_ind XΓ'). + intros Δ t [T|] IH; unfold lift_typing; simpl. + - rewrite -/(lift_context #|Γ'| 0 Δ). + intros Hf. red. + rewrite Nat.add_0_r in Hf. rewrite !lift_rename in Hf. + specialize (Hf (nocc_betweenp #|Δ| #|Γ'|) (Γ ,,, Δ) (strengthen #|Δ| #|Γ'|)). + forward Hf. + * split. + + apply wf_local_app; auto. + + len. rewrite /shiftnP. + epose proof (strengthen_urenaming Γ Γ' Δ). simpl in X. + rewrite /strengthen_context in X. + rewrite /PCUICRename.shiftnP. + + eapply (Hf (fun x => true)). + split. + + apply wf_local_app; auto. + apply All_local_env_fold in IH. apply IH. + + apply (weakening_renaming _ Γ Δ Γ''). + - intros [s Hs]; exists s. red. + rewrite -/(lift_context #|Γ''| 0 Δ). + rewrite Nat.add_0_r !lift_rename. + apply (Hs (fun _ => true)). + split. + + apply wf_local_app; auto. + apply All_local_env_fold in IH. apply IH. + + apply (weakening_renaming _ Γ Δ Γ''). +Qed. \ No newline at end of file diff --git a/pcuic/theories/PCUICSubstitution.v b/pcuic/theories/PCUICSubstitution.v index 46164e095..080524222 100644 --- a/pcuic/theories/PCUICSubstitution.v +++ b/pcuic/theories/PCUICSubstitution.v @@ -1,15 +1,18 @@ - (* Distributed under the terms of the MIT license. *) +(* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import utils config. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction - PCUICLiftSubst PCUICEquality PCUICPosition PCUICSigmaCalculus - PCUICUnivSubst PCUICTyping PCUICWeakeningEnv PCUICClosed - PCUICReduction PCUICWeakening PCUICCumulativity PCUICUnivSubstitution. + PCUICLiftSubst PCUICEquality PCUICPosition PCUICCases PCUICSigmaCalculus + PCUICUnivSubst PCUICContextSubst PCUICTyping PCUICWeakeningEnv PCUICClosed + PCUICReduction PCUICContextRelation PCUICContextReduction PCUICWeakening PCUICCumulativity PCUICUnivSubstitution + PCUICRename PCUICInst. Require Import ssreflect. From Equations Require Import Equations. (** * Substitution lemmas for typing derivations. *) +Implicit Types (cf : checker_flags) (Σ : global_env_ext). + Local Set Keyed Unification. Set Default Goal Selector "!". @@ -18,42 +21,27 @@ Hint Rewrite @app_context_length : wf. Generalizable Variables Σ Γ t T. +Local Open Scope sigma_scope. + +(** Substitution in contexts is just a particular kind of instantiation. *) + +Lemma subst_context_inst_context s k Γ : + subst_context s k Γ = inst_context (⇑^k (s ⋅n ids)) Γ. +Proof. + rewrite /subst_context. + now setoid_rewrite subst_inst'; setoid_rewrite Upn_Upn. +Qed. + (** Well-typed substitution into a context with *no* let-ins *) Inductive subs {cf:checker_flags} (Σ : global_env_ext) (Γ : context) : list term -> context -> Type := | emptys : subs Σ Γ [] [] | cons_ass Δ s na t T : subs Σ Γ s Δ -> Σ ;;; Γ |- t : subst0 s T -> subs Σ Γ (t :: s) (Δ ,, vass na T). -(** Linking a context (with let-ins), an instance (reversed substitution) - for its assumptions and a well-formed substitution for it. *) - -Inductive context_subst : context -> list term -> list term -> Type := -| context_subst_nil : context_subst [] [] [] -| context_subst_ass Γ args s na t a : - context_subst Γ args s -> - context_subst (vass na t :: Γ) (args ++ [a]) (a :: s) -| context_subst_def Γ args s na b t : - context_subst Γ args s -> - context_subst (vdef na b t :: Γ) args (subst s 0 b :: s). - -(** Promoting a substitution for the non-let declarations of ctx into a - substitution for the whole context *) - -Fixpoint make_context_subst ctx args s := - match ctx with - | [] => match args with - | [] => Some s - | a :: args => None - end - | d :: ctx => - match d.(decl_body) with - | Some body => make_context_subst ctx args (subst0 s body :: s) - | None => match args with - | a :: args => make_context_subst ctx args (a :: s) - | [] => None - end - end - end. +Lemma subs_length {cf:checker_flags} {Σ} {Γ s Δ} : subs Σ Γ s Δ -> #|s| = #|Δ|. +Proof. + induction 1; simpl; auto. f_equal. auto. +Qed. (** Well-typed substitution into a context with let-ins *) @@ -67,39 +55,38 @@ Inductive subslet {cf:checker_flags} Σ (Γ : context) : list term -> context -> Σ ;;; Γ |- subst0 s t : subst0 s T -> subslet Σ Γ (subst0 s t :: s) (Δ ,, vdef na t T). -Lemma subslet_nth_error {cf:checker_flags} Σ Γ s Δ decl n t : +Lemma subslet_nth_error {cf:checker_flags} {Σ Γ s Δ decl n} : subslet Σ Γ s Δ -> nth_error Δ n = Some decl -> - nth_error s n = Some t -> + ∑ t, nth_error s n = Some t × + let ty := subst0 (skipn (S n) s) (decl_type decl) in + Σ ;;; Γ |- t : ty × match decl_body decl return Type with | Some t' => let b := subst0 (skipn (S n) s) t' in - let ty := subst0 (skipn (S n) s) (decl_type decl) in - ((t = b) * (Σ ;;; Γ |- b : ty))%type - | None => - let ty := subst0 (skipn (S n) s) (decl_type decl) in - Σ ;;; Γ |- t : ty + (t = b) + | None => unit end. Proof. induction 1 in n |- *; simpl; auto; destruct n; simpl; try congruence. - - intros [= <-]. intros [= ->]. - simpl. exact t1. + - intros [= <-]. exists t; split; auto. + simpl. split; auto. exact tt. - intros. destruct decl as [na' [b|] ty]; cbn in *. - + specialize (IHX _ H H0). intuition auto. + + specialize (IHX _ H) as [t' [hnth [hty heq]]]. exists t'; intuition auto. + now apply IHX. - - intros [= <-]. intros [= <-]. + - intros [= <-]. eexists; split; eauto. simpl. split; auto. - apply IHX. Qed. Lemma subslet_length {cf:checker_flags} {Σ Γ s Δ} : subslet Σ Γ s Δ -> #|s| = #|Δ|. Proof. - induction 1; simpl; auto with arith. + induction 1; simpl; f_equal; auto. Qed. Lemma subst_decl_closed n k d : closed_decl k d -> subst_decl n k d = d. Proof. - case: d => na [body|] ty; rewrite /closed_decl /subst_decl /map_decl /=. + case: d => na [body|] ty; rewrite /subst_decl /map_decl /=. - move/andb_and => [cb cty]. rewrite !subst_closedn //. - move=> cty; now rewrite !subst_closedn //. Qed. @@ -107,9 +94,8 @@ Qed. Lemma closed_ctx_subst n k ctx : closed_ctx ctx = true -> subst_context n k ctx = ctx. Proof. induction ctx in n, k |- *; auto. - unfold closed_ctx, id. - rewrite mapi_app forallb_app List.rev_length /= Nat.add_0_r. - move/andb_and => /= [Hctx /andb_and [Ha _]]. + rewrite closedn_ctx_cons. + move/andb_and => /= [Hctx Hd]. rewrite subst_context_snoc /snoc /= IHctx // subst_decl_closed //. now apply: closed_decl_upwards. Qed. @@ -118,7 +104,7 @@ Lemma closed_tele_subst n k ctx : closed_ctx ctx -> mapi (fun (k' : nat) (decl : context_decl) => subst_decl n (k' + k) decl) (List.rev ctx) = List.rev ctx. Proof. - rewrite /closedn_ctx /mapi. simpl. generalize 0. + rewrite test_context_k_eq /mapi. simpl. generalize 0. induction ctx using rev_ind; try easy. move=> n0. rewrite /closedn_ctx !rev_app_distr /id /=. @@ -157,7 +143,7 @@ Qed. Lemma subst_length {cf:checker_flags} Σ Γ s Γ' : subs Σ Γ s Γ' -> #|s| = #|Γ'|. Proof. - induction 1; simpl; auto with arith. + induction 1; simpl; lia. Qed. Lemma subs_nth_error_ge {cf:checker_flags} Σ Γ Γ' Γ'' v s : @@ -176,10 +162,10 @@ Lemma nth_error_subst_context (Γ' : context) s (v : nat) k : option_map (subst_decl s (#|Γ'| - S v + k)) (nth_error Γ' v). Proof. induction Γ' in v |- *; intros. - - simpl. unfold subst_context, fold_context; simpl; rewrite nth_error_nil. easy. + - simpl. unfold subst_context, fold_context_k; simpl; rewrite nth_error_nil. easy. - simpl. destruct v; rewrite subst_context_snoc. + simpl. repeat f_equal; try lia. - + simpl. rewrite IHΓ'; simpl in *; (lia || congruence). + + simpl. rewrite IHΓ'; simpl in *. lia_f_equal. Qed. Lemma subs_nth_error_lt {cf:checker_flags} Σ Γ Γ' Γ'' v s : @@ -204,12 +190,31 @@ Proof. erewrite nth_error_subst_context. f_equal. unfold subst_decl. rewrite Nat.add_0_r. reflexivity. Qed. -Lemma subst_iota_red s k pars c args brs : - subst s k (iota_red pars c args brs) = - iota_red pars c (List.map (subst s k) args) (List.map (on_snd (subst s k)) brs). +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. - unfold iota_red. rewrite !subst_mkApps. f_equal; auto using map_skipn. - rewrite nth_map; simpl; auto. + unfold expand_lets, expand_lets_k; simpl; intros clx. + len. + rewrite !subst_extended_subst. + rewrite distr_subst. f_equal. + len. rewrite subst_closedn //. + rewrite Nat.add_assoc; eapply closedn_lift. + now rewrite Nat.add_comm. +Qed. + +Lemma subst_iota_red s k pars args br : + #|skipn pars args| = context_assumptions br.(bcontext) -> + subst s k (iota_red pars args br) = + iota_red pars (List.map (subst s k) args) (map_branch_k (subst s) k br). +Proof. + intros hctx. rewrite !subst_inst. rewrite inst_iota_red //. + f_equal; try setoid_rewrite <-subst_inst' => //. + rewrite /map_branch_k /map_branch_shift; f_equal. + * rewrite mapi_context_inst /shiftf. setoid_rewrite subst_inst'. + rewrite mapi_context_fold. + eapply fold_context_k_ext => i t. now sigma. + * simpl. rewrite subst_inst'. now sigma. Qed. Lemma subst_unfold_fix n k mfix idx narg fn : @@ -290,11 +295,10 @@ Proof. intros wfΣ Hk Hty. pose proof (typing_wf_local Hty). apply typecheck_closed in Hty; eauto. - destruct Hty as [_ Hcl]. - rewrite -> andb_and in Hcl. destruct Hcl as [clb clty]. - pose proof (closed_upwards k clb). + destruct Hty as [_ [Hcl [Ht HT]%andb_and]]. + pose proof (closed_upwards k Ht). simpl in *. forward H0 by lia. - pose proof (closed_upwards k clty). + pose proof (closed_upwards k HT). simpl in *. forward H1 by lia. apply (subst_closedn n) in H0; apply (subst_closedn n) in H1; auto. Qed. @@ -305,7 +309,7 @@ Lemma subst_wf_local `{checker_flags} Σ Γ n k : subst_context n k Γ = Γ. Proof. intros wfΣ. - induction 1; auto; unfold subst_context, snoc; rewrite fold_context_snoc0; + induction 1; auto; unfold subst_context, snoc; rewrite fold_context_k_snoc0; auto; unfold snoc; f_equal; auto; unfold map_decl; simpl. - destruct t0 as [s Hs]. unfold vass. simpl. f_equal. @@ -319,22 +323,22 @@ Qed. Lemma subst_declared_constant `{H:checker_flags} Σ cst decl n k u : wf Σ -> declared_constant Σ cst decl -> - map_constant_body (subst n k) (map_constant_body (subst_instance_constr u) decl) = - map_constant_body (subst_instance_constr u) decl. + map_constant_body (subst n k) (map_constant_body (subst_instance u) decl) = + map_constant_body (subst_instance u) decl. Proof. intros. eapply declared_decl_closed in H0; eauto. unfold map_constant_body. do 2 red in H0. destruct decl as [ty [body|] univs]; simpl in *. - rewrite -> andb_and in H0. intuition. - rewrite <- (closedn_subst_instance_constr 0 body u) in H1. - rewrite <- (closedn_subst_instance_constr 0 ty u) in H2. + rewrite <- (closedn_subst_instance 0 body u) in H1. + rewrite <- (closedn_subst_instance 0 ty u) in H2. f_equal. + apply subst_closedn; eauto using closed_upwards with arith wf. + f_equal. apply subst_closedn; eauto using closed_upwards with arith wf. - red in H0. f_equal. intuition. simpl in *. - rewrite <- (closedn_subst_instance_constr 0 ty u) in H0. + rewrite <- (closedn_subst_instance 0 ty u) in H0. rewrite andb_true_r in H0. eapply subst_closedn; eauto using closed_upwards with arith wf. Qed. @@ -342,7 +346,19 @@ Qed. Definition subst_mutual_inductive_body n k m := map_mutual_inductive_body (fun k' => subst n (k' + k)) m. -Lemma subst_declared_minductive {cf:checker_flags} Σ cst decl n k : +Lemma subst_fix_context: + forall (mfix : list (def term)) n (k : nat), + fix_context (map (map_def (subst n k) (subst n (#|mfix| + k))) mfix) = + subst_context n k (fix_context mfix). +Proof. + intros mfix n k. unfold fix_context. + rewrite map_vass_map_def_subst rev_mapi. + fold (fix_context mfix). + rewrite (subst_context_alt n k (fix_context mfix)). + now rewrite /subst_decl mapi_length fix_context_length. +Qed. + +(* Lemma subst_declared_minductive {cf:checker_flags} Σ cst decl n k : wf Σ -> declared_minductive Σ cst decl -> subst_mutual_inductive_body n k decl = decl. @@ -354,7 +370,7 @@ Proof. rewrite /closed_inductive_decl /lift_mutual_inductive_body. destruct decl; simpl. move/andb_and => [clpar clbodies]. f_equal. - - now rewrite [fold_context _ _]closed_ctx_subst. + - now rewrite [fold_context_k _ _]closed_ctx_subst. - eapply forallb_All in clbodies. eapply Alli_mapi_id. * eapply (All_Alli clbodies). intros; eauto. @@ -368,7 +384,7 @@ Proof. + eapply All_map_id. eapply forallb_All in ct. eapply (All_impl ct). intros x. destruct x as [[id ty] arg]; unfold on_pi2; intros c; simpl; repeat f_equal. - apply subst_closedn. unfold cdecl_type in c; simpl in c. + apply subst_closedn. unfold cstr_type in c; simpl in c. eapply closed_upwards; eauto; lia. + simpl in X. rewrite -X in cp. eapply forallb_All in cp. eapply All_map_id; eauto. @@ -378,9 +394,9 @@ Proof. eapply closed_upwards; eauto; lia. Qed. -Lemma subst_declared_inductive {cf:checker_flags} Σ ind mdecl idecl n k : +Lemma subst_declared_inductive {cf:checker_flags} ind Σ mdecl idecl n k : wf Σ -> - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> map_one_inductive_body (context_assumptions mdecl.(ind_params)) (length (arities_context mdecl.(ind_bodies))) (fun k' => subst n (k' + k)) (inductive_ind ind) idecl = idecl. @@ -413,8 +429,8 @@ Proof. Qed. Lemma subst_declared_constructor {cf:checker_flags} Σ c u mdecl idecl cdecl n k : - wf Σ -> declared_constructor Σ mdecl idecl c cdecl -> - subst (map (subst_instance_constr u) n) k (type_of_constructor mdecl cdecl c u) = (type_of_constructor mdecl cdecl c u). + wf Σ -> declared_constructor Σ c mdecl idecl cdecl -> + subst (map (subst_instance u) n) k (type_of_constructor mdecl cdecl c u) = (type_of_constructor mdecl cdecl c u). Proof. unfold declared_constructor. destruct c as [i ci]. intros wfΣ [Hidecl Hcdecl]. eapply (subst_declared_inductive _ _ _ _ n k) in Hidecl; eauto. @@ -428,12 +444,12 @@ Proof. intros. rewrite <- H2 at 2. rewrite <- subst0_inds_subst. f_equal. - now rewrite <- subst_subst_instance_constr. + now rewrite <- subst_instance_subst. Qed. Lemma subst_declared_projection {cf:checker_flags} Σ c mdecl idecl pdecl n k : wf Σ -> - declared_projection Σ mdecl idecl c pdecl -> + declared_projection Σ c mdecl idecl pdecl -> on_snd (subst n (S (ind_npars mdecl + k))) pdecl = pdecl. Proof. intros. @@ -443,19 +459,7 @@ Proof. - eapply closed_upwards; eauto; try lia. - destruct pdecl; reflexivity. Qed. - -Lemma subst_fix_context: - forall (mfix : list (def term)) n (k : nat), - fix_context (map (map_def (subst n k) (subst n (#|mfix| + k))) mfix) = - subst_context n k (fix_context mfix). -Proof. - intros mfix n k. unfold fix_context. - rewrite map_vass_map_def_subst rev_mapi. - fold (fix_context mfix). - rewrite (subst_context_alt n k (fix_context mfix)). - now rewrite /subst_decl mapi_length fix_context_length. -Qed. - +*) Lemma subst_destArity ctx t n k : match destArity ctx t with | Some (args, s) => @@ -473,7 +477,7 @@ Qed. Lemma decompose_prod_n_assum0 ctx t : decompose_prod_n_assum ctx 0 t = Some (ctx, t). Proof. destruct t; simpl; reflexivity. Qed. - +(* Lemma subst_instantiate_params_subst n k params args s t : forall s' t', instantiate_params_subst params args s t = Some (s', t') -> @@ -500,55 +504,6 @@ Proof. now rewrite <- IHparams. Qed. -Lemma decompose_prod_n_assum_extend_ctx {ctx n t ctx' t'} ctx'' : - decompose_prod_n_assum ctx n t = Some (ctx', t') -> - decompose_prod_n_assum (ctx ++ ctx'') n t = Some (ctx' ++ ctx'', t'). -Proof. - induction n in ctx, t, ctx', t', ctx'' |- *. - - simpl. intros [= -> ->]. eauto. - - simpl. - destruct t; simpl; try congruence. - + intros H. eapply (IHn _ _ _ _ ctx'' H). - + intros H. eapply (IHn _ _ _ _ ctx'' H). -Qed. - -Lemma subst_it_mkProd_or_LetIn n k ctx t : - subst n k (it_mkProd_or_LetIn ctx t) = - it_mkProd_or_LetIn (subst_context n k ctx) (subst n (length ctx + k) t). -Proof. - induction ctx in n, k, t |- *; simpl; try congruence. - pose (subst_context_snoc n k ctx a). unfold snoc in e. rewrite e. clear e. - simpl. rewrite -> IHctx. - pose (subst_context_snoc n k ctx a). simpl. now destruct a as [na [b|] ty]. -Qed. - -Lemma to_extended_list_k_subst n k c k' : - to_extended_list_k (subst_context n k c) k' = to_extended_list_k c k'. -Proof. - unfold to_extended_list_k. revert k'. - unf_term. generalize (@nil term) at 1 2. - induction c in n, k |- *; simpl; intros. 1: reflexivity. - rewrite subst_context_snoc. unfold snoc. simpl. - destruct a. destruct decl_body. - - unfold subst_decl, map_decl. simpl. - now rewrite IHc. - - simpl. apply IHc. -Qed. - -Lemma to_extended_list_k_map_subst: - forall n (k : nat) (c : context) k', - #|c| + k' <= k -> - to_extended_list_k c k' = map (subst n k) (to_extended_list_k c k'). -Proof. - intros n k c k'. - pose proof (to_extended_list_k_spec c k'). - symmetry. solve_all. - destruct H as [x' [-> Hx']]. intuition. simpl. - destruct (leb_spec_Set k x'). - - lia. - - reflexivity. -Qed. - Lemma subst_instantiate_params n k params args t ty : closed_ctx params -> instantiate_params params args t = Some ty -> @@ -565,6 +520,21 @@ Proof. move/instantiate_params_subst_length: E => -> /=. do 2 f_equal. lia. Qed. Hint Rewrite subst_instantiate_params : lift. +*) + +Lemma to_extended_list_k_map_subst: + forall n (k : nat) (c : context) k', + #|c| + k' <= k -> + to_extended_list_k c k' = map (subst n k) (to_extended_list_k c k'). +Proof. + intros n k c k'. + pose proof (to_extended_list_k_spec c k'). + symmetry. solve_all. + destruct H as [x' [-> Hx']]. intuition. simpl. + destruct (leb_spec_Set k x'). + - lia. + - reflexivity. +Qed. Lemma wf_arities_context' {cf:checker_flags}: forall (Σ : global_env_ext) mind (mdecl : mutual_inductive_body), @@ -595,7 +565,7 @@ Proof. apply X. Qed. -Lemma wf_arities_context {cf:checker_flags} Σ mind mdecl : wf Σ -> +Lemma wf_arities_context {cf:checker_flags} (Σ : global_env) mind mdecl : wf Σ -> declared_minductive Σ mind mdecl -> wf_local (Σ, ind_universes mdecl) (arities_context mdecl.(ind_bodies)). Proof. intros wfΣ Hdecl. @@ -603,151 +573,23 @@ Proof. eapply wf_arities_context'; eauto. Qed. -Lemma on_constructor_closed {cf:checker_flags} {Σ mind mdecl u idecl indices cdecl cs} : +Lemma on_constructor_closed {cf:checker_flags} {Σ : global_env} {mind mdecl u idecl indices cdecl cs} : wf Σ -> on_constructor (lift_typing typing) (Σ, ind_universes mdecl) mdecl (inductive_ind mind) indices idecl cdecl cs -> let cty := subst0 (inds (inductive_mind mind) u (ind_bodies mdecl)) - (subst_instance_constr u (snd (fst cdecl))) + (subst_instance u cdecl.(cstr_type)) in closed cty. Proof. - intros wfΣ [? ? ? [s Hs] Hparams]. + intros wfΣ [? ? ? [s Hs] _ _ _ _]. pose proof (typing_wf_local Hs). - destruct cdecl as [[id cty] car]. + destruct cdecl as [id cty car]. apply subject_closed in Hs; eauto. rewrite arities_context_length in Hs. simpl in *. eapply (closedn_subst _ 0 0). - clear. unfold inds. induction #|ind_bodies mdecl|; simpl; try constructor; auto. - - simpl. now rewrite -> inds_length, closedn_subst_instance_constr. -Qed. - -Lemma context_subst_length {Γ a s} : context_subst Γ a s -> #|Γ| = #|s|. -Proof. induction 1; simpl; congruence. Qed. - -Lemma context_subst_assumptions_length {Γ a s} : context_subst Γ a s -> context_assumptions Γ = #|a|. -Proof. induction 1; simpl; try congruence. rewrite app_length /=. lia. Qed. - -(* Lemma context_subst_app {cf:checker_flags} Γ Γ' a s : *) -(* context_subst (Γ' ++ Γ) a s -> *) -(* { a0 & { a1 & { s0 & { s1 & (context_subst Γ a0 s0 * context_subst (subst_context s0 0 Γ') a1 s1 *) -(* * (a = a0 ++ a1) * (s = s1 ++ s0))%type } } } }. *) -(* Proof. *) -(* induction Γ' in Γ, a, s |- *. simpl. *) -(* exists a, [], s, []. rewrite app_nil_r; intuition. constructor. *) - -(* simpl. intros Hs. *) -(* inv Hs. *) -(* - specialize (IHΓ' _ _ _ H). *) -(* destruct IHΓ' as (a0' & a1' & s1 & s2 & ((sa0 & sa1) & eqargs) & eqs0). *) -(* subst. exists a0', (a1' ++ [a1]), s1, (a1 :: s2). intuition eauto. *) -(* rewrite subst_context_snoc. constructor. auto. now rewrite app_assoc. *) -(* - specialize (IHΓ' _ _ _ H). *) -(* destruct IHΓ' as (a0' & a1' & s1 & s2 & ((sa0 & sa1) & eqargs) & eqs0). *) -(* subst. exists a0', a1', s1, (subst s2 0 (subst s1 #|Γ'| b) :: s2). intuition eauto. *) -(* rewrite -> subst_context_snoc, Nat.add_0_r. *) -(* unfold subst_decl; simpl. unfold map_decl. simpl. *) -(* econstructor. auto. simpl. f_equal. *) -(* rewrite -> subst_app_simpl; auto. simpl. *) -(* pose proof(context_subst_length _ _ _ sa1) as Hs1. *) -(* rewrite subst_context_length in Hs1. rewrite -> Hs1. auto. *) -(* Qed. *) - -Lemma make_context_subst_rec_spec ctx args s tele args' s' : - context_subst ctx args s -> - make_context_subst tele args' s = Some s' -> - context_subst (List.rev tele ++ ctx) (args ++ args') s'. -Proof. - induction tele in ctx, args, s, args', s' |- *. - - move=> /= Hc. case: args'. - + move => [= <-]. - now rewrite app_nil_r. - + move=> a l //. - - move=> Hc /=. case: a => [na [body|] ty] /=. - -- specialize (IHtele (vdef na body ty :: ctx) args (subst0 s body :: s) args' s'). - move=> /=. rewrite <- app_assoc. - move/(IHtele _). move=> H /=. apply H. - constructor. auto. - -- case: args' => [|a args']; try congruence. - specialize (IHtele (vass na ty :: ctx) (args ++ [a]) (a :: s) args' s'). - move=> /=. rewrite <- app_assoc. - move/(IHtele _). move=> H /=. simpl in H. rewrite <- app_assoc in H. apply H. - constructor. auto. -Qed. - -Lemma make_context_subst_spec tele args s' : - make_context_subst tele args [] = Some s' -> - context_subst (List.rev tele) args s'. -Proof. - move/(make_context_subst_rec_spec [] [] [] _ _ _ context_subst_nil). - rewrite app_nil_r /= //. -Qed. - -Lemma subst_telescope_cons s k d Γ : - subst_telescope s k (d :: Γ) = - map_decl (subst s k) d :: subst_telescope s (S k) Γ. -Proof. - simpl. - unfold subst_telescope, mapi. simpl. - rewrite Nat.add_0_r; f_equal. - rewrite mapi_rec_Sk. apply mapi_rec_ext. - intros. simpl. now rewrite Nat.add_succ_r. -Qed. - -Lemma subst_telescope_comm_rec s k s' k' Γ: - subst_telescope (map (subst s' k) s) k' (subst_telescope s' (#|s| + k' + k) Γ) = - subst_telescope s' (k' + k) (subst_telescope s k' Γ). -Proof. - induction Γ in k, k' |- *; rewrite ?subst_telescope_cons; simpl; auto. - f_equal. - * unfold map_decl. simpl. - f_equal. - + destruct a as [na [b|] ty]; simpl; auto. - f_equal. now rewrite distr_subst_rec. - + now rewrite distr_subst_rec. - * specialize (IHΓ k (S k')). now rewrite Nat.add_succ_r in IHΓ. -Qed. - -Lemma subst_telescope_comm s k s' Γ: - subst_telescope (map (subst s' k) s) 0 (subst_telescope s' (#|s| + k) Γ) = - subst_telescope s' k (subst_telescope s 0 Γ). -Proof. - now rewrite -(subst_telescope_comm_rec _ _ _ 0) Nat.add_0_r. -Qed. - -Lemma instantiate_params_subst_make_context_subst ctx args s ty s' ty' : - instantiate_params_subst ctx args s ty = Some (s', ty') -> - ∑ ctx'', - make_context_subst ctx args s = Some s' /\ - decompose_prod_n_assum [] (length ctx) ty = Some (ctx'', ty'). -Proof. - induction ctx in args, s, ty, s' |- *; simpl. - - case: args => [|a args'] // [= <- <-]. exists []; intuition congruence. - - case: a => [na [body|] ty''] /=. - + destruct ty; try congruence. - intros. move: (IHctx _ _ _ _ H) => [ctx'' [Hmake Hdecomp]]. - eapply (decompose_prod_n_assum_extend_ctx [vdef na0 ty1 ty2]) in Hdecomp. - unfold snoc. eexists; intuition eauto. - + destruct ty; try congruence. - case: args => [|a args']; try congruence. - move=> H. move: (IHctx _ _ _ _ H) => [ctx'' [Hmake Hdecomp]]. - eapply (decompose_prod_n_assum_extend_ctx [vass na0 ty1]) in Hdecomp. - unfold snoc. eexists; intuition eauto. -Qed. - -Lemma instantiate_params_make_context_subst ctx args ty ty' : - instantiate_params ctx args ty = Some ty' -> - ∑ ctx' ty'' s', - decompose_prod_n_assum [] (length ctx) ty = Some (ctx', ty'') /\ - make_context_subst (List.rev ctx) args [] = Some s' /\ ty' = subst0 s' ty''. -Proof. - unfold instantiate_params. - case E: instantiate_params_subst => // [[s ty'']]. - move=> [= <-]. - eapply instantiate_params_subst_make_context_subst in E. - destruct E as [ctx'' [Hs Hty'']]. - exists ctx'', ty'', s. split; auto. - now rewrite -> List.rev_length in Hty''. + - simpl. now rewrite -> inds_length, closedn_subst_instance. Qed. Lemma subst_cstr_concl_head ind u mdecl (arity : context) args : @@ -755,14 +597,14 @@ Lemma subst_cstr_concl_head ind u mdecl (arity : context) args : let s := (inds (inductive_mind ind) u (ind_bodies mdecl)) in inductive_ind ind < #|ind_bodies mdecl| -> subst s (#|arity| + #|ind_params mdecl|) - (subst_instance_constr u (mkApps head (to_extended_list_k (ind_params mdecl) #|arity| ++ args))) + (subst_instance u (mkApps head (to_extended_list_k (ind_params mdecl) #|arity| ++ args))) = mkApps (tInd ind u) (to_extended_list_k (ind_params mdecl) #|arity| ++ - map (subst s (#|arity| + #|ind_params mdecl|)) (map (subst_instance_constr u) args)). + map (subst s (#|arity| + #|ind_params mdecl|)) (map (subst_instance u) args)). Proof. intros. - rewrite subst_instance_constr_mkApps subst_mkApps. + rewrite subst_instance_mkApps subst_mkApps. f_equal. - - subst head. simpl subst_instance_constr. + - subst head. simpl subst_instance. rewrite (subst_rel_eq _ _ (#|ind_bodies mdecl| - S (inductive_ind ind)) (tInd ind u)) //; try lia. subst s. rewrite inds_spec rev_mapi nth_error_mapi /=. elim nth_error_spec. @@ -770,7 +612,7 @@ Proof. f_equal. destruct ind; simpl. f_equal. f_equal. simpl in H. lia. + rewrite List.rev_length. lia. - rewrite !map_app. f_equal. - rewrite map_subst_instance_constr_to_extended_list_k. + rewrite map_subst_instance_to_extended_list_k. erewrite to_extended_list_k_map_subst at 2. + now rewrite Nat.add_comm. + lia. @@ -820,20 +662,9 @@ Proof. move=> [= <-]. now rewrite (IHHa _ _ E'). Qed. -Lemma map_subst_instance_constr_to_extended_list_k u ctx k : - to_extended_list_k (subst_instance_context u ctx) k - = to_extended_list_k ctx k. -Proof. - unfold to_extended_list_k. - cut (map (subst_instance_constr u) [] = []); [|reflexivity]. - unf_term. generalize (@nil term); intros l Hl. - induction ctx in k, l, Hl |- *; cbnr. - destruct a as [? [] ?]; cbnr; eauto. - unf_term. eapply IHctx; cbn; congruence. -Qed. - +(* Lemma subst_build_case_predicate_type ind mdecl idecl u params ps pty n k : - closed_ctx (subst_instance_context u (ind_params mdecl)) -> + closed_ctx (subst_instance u (ind_params mdecl)) -> closed (ind_type idecl) -> build_case_predicate_type ind mdecl idecl params u ps = Some pty -> build_case_predicate_type ind mdecl @@ -845,14 +676,14 @@ Lemma subst_build_case_predicate_type ind mdecl idecl u params ps pty n k : Proof. intros closedparams closedtype. unfold build_case_predicate_type; simpl. - case_eq (instantiate_params (subst_instance_context u (ind_params mdecl)) params - (subst_instance_constr u (ind_type idecl))); + case_eq (instantiate_params (subst_instance u (ind_params mdecl)) params + (subst_instance u (ind_type idecl))); [|discriminate ]. intros ipars Hipars. apply (subst_instantiate_params n k) in Hipars; tas. rewrite ind_type_map. simpl. rewrite subst_closedn in Hipars. - { rewrite closedn_subst_instance_constr; eapply closed_upwards; tea; lia. } + { rewrite closedn_subst_instance; eapply closed_upwards; tea; lia. } rewrite subst_closedn; [eapply closed_upwards; tea; lia|]. rewrite Hipars. specialize (subst_destArity [] ipars n k); @@ -875,8 +706,8 @@ Qed. Lemma subst_build_branches_type {cf:checker_flags} n k Σ ind mdecl idecl indices args u p brs cs : wf Σ -> - declared_inductive Σ mdecl ind idecl -> - closed_ctx (subst_instance_context u (ind_params mdecl)) -> + declared_inductive Σ ind mdecl idecl -> + closed_ctx (subst_instance u (ind_params mdecl)) -> on_inductive (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl -> on_constructors (lift_typing typing) (Σ, ind_universes mdecl) @@ -892,16 +723,16 @@ Proof. { eapply All2_All_left; tea. intros x y u'; exact (y; u'). } clear Honcs brs. intros j [[id t] i] [t' k'] [cs' Honc]. - case_eq (instantiate_params (subst_instance_context u (ind_params mdecl)) args + case_eq (instantiate_params (subst_instance u (ind_params mdecl)) args (subst0 (inds (inductive_mind ind) u (ind_bodies mdecl)) - (subst_instance_constr u t))); + (subst_instance u t))); [|discriminate]. intros ty Heq; cbn. pose proof (on_constructor_closed wfΣ (u:=u) Honc) as clt; cbn in clt. eapply (closed_upwards k) in clt; try lia. remember (subst0 (inds (inductive_mind ind) u (ind_bodies mdecl)) - (subst_instance_constr u t)) as ty'. + (subst_instance u t)) as ty'. apply (subst_instantiate_params n k) in Heq as Heq'; tas. erewrite subst_closedn in Heq'; tas. rewrite Heq'. @@ -909,21 +740,21 @@ Proof. destruct Heq as [ctx' [ty'' [s' [Hty [Hsubst Ht0]]]]]. subst ty; simpl. rewrite Heqty' in Hty. - destruct Honc as [Hcshape_args ? cshape_eq Hty' _ _]; unfold cdecl_type in *; simpl in *. - rewrite cshape_eq in Hty. - rewrite -> !subst_instance_constr_it_mkProd_or_LetIn in Hty. + destruct Honc as [Hcstr_args ? cdecl_eq Hty' _ _]; unfold cstr_type in *; simpl in *. + rewrite cdecl_eq in Hty. + rewrite -> !subst_instance_it_mkProd_or_LetIn in Hty. rewrite !subst_it_mkProd_or_LetIn in Hty. assert (H0: #|subst_context (inds (inductive_mind ind) u (ind_bodies mdecl)) 0 - (subst_instance_context u (ind_params mdecl))| - = #|subst_instance_context u (ind_params mdecl)|). { + (subst_instance u (ind_params mdecl))| + = #|subst_instance u (ind_params mdecl)|). { now rewrite subst_context_length. } rewrite <- H0 in Hty. rewrite decompose_prod_n_assum_it_mkProd in Hty. injection Hty. clear Hty. intros Heqty'' <-. revert Heqty''. - rewrite !subst_instance_context_length Nat.add_0_r. - rewrite subst_context_length subst_instance_context_length. - rewrite (subst_cstr_concl_head ind u mdecl cs'.(cshape_args) cs'.(cshape_indices)). + rewrite !subst_instance_length Nat.add_0_r. + rewrite subst_context_length subst_instance_length. + rewrite (subst_cstr_concl_head ind u mdecl cs'.(cstr_args) cs'.(cstr_indices)). { destruct wfidecl as [Hmdecl Hnth]. now apply nth_error_Some_length in Hnth. } @@ -932,9 +763,9 @@ Proof. try by rewrite is_ind_app_head_mkApps. rewrite !decompose_app_mkApps; try by reflexivity. simpl. rewrite !map_app !subst_context_length - !subst_instance_context_length Nat.add_0_r. - eapply subst_to_extended_list_k with (k:=#|cs'.(cshape_args)|) in Hsubst as XX. - rewrite map_subst_instance_constr_to_extended_list_k in XX. + !subst_instance_length Nat.add_0_r. + eapply subst_to_extended_list_k with (k:=#|cs'.(cstr_args)|) in Hsubst as XX. + rewrite map_subst_instance_to_extended_list_k in XX. rewrite !XX; clear XX. apply make_context_subst_spec in Hsubst as Hsubst'. rewrite rev_involutive in Hsubst'. @@ -944,25 +775,25 @@ Proof. move: E chopm. rewrite chop_n_app ?map_length. { rewrite <- H1. apply onNpars in onmind. - now rewrite subst_instance_context_assumptions. } + now rewrite subst_instance_assumptions. } move=> [= <- <-] chopm. - move: {chopm}(chopm _ (subst n (#|cs'.(cshape_args)| + k))). + move: {chopm}(chopm _ (subst n (#|cs'.(cstr_args)| + k))). rewrite map_app. move=> chopm; rewrite {}chopm /=. inversion 1; subst. f_equal. unfold on_snd; cbn; f_equal. rewrite !app_nil_r /on_snd /=. rewrite subst_it_mkProd_or_LetIn !subst_context_length !subst_mkApps - !subst_instance_context_length !map_app. + !subst_instance_length !map_app. f_equal. f_equal. -- rewrite -> commut_lift_subst_rec by lia. arith_congr. -- f_equal. simpl. f_equal. rewrite !subst_mkApps /= !map_app. f_equal. f_equal. rewrite /to_extended_list -to_extended_list_k_map_subst. - ++ rewrite !subst_context_length subst_instance_context_length. lia. + ++ rewrite !subst_context_length subst_instance_length. lia. ++ now rewrite to_extended_list_k_subst. Qed. - +*) Hint Unfold subst1 : subst. Hint Rewrite subst_mkApps distr_subst: subst. @@ -976,6 +807,12 @@ Inductive untyped_subslet (Γ : context) : list term -> context -> Type := untyped_subslet Γ s Δ -> untyped_subslet Γ (subst0 s t :: s) (Δ ,, vdef na t T). +Lemma subslet_untyped_subslet {cf:checker_flags} Σ Γ s Γ' : subslet Σ Γ s Γ' -> untyped_subslet Γ s Γ'. +Proof. + induction 1; constructor; auto. +Qed. +Coercion subslet_untyped_subslet : subslet >-> untyped_subslet. + Lemma decompose_prod_assum_it_mkProd_or_LetIn ctx t ctx' t' : decompose_prod_assum ctx t = (ctx', t') -> it_mkProd_or_LetIn ctx t = it_mkProd_or_LetIn ctx' t'. @@ -1107,25 +944,12 @@ Proof. rewrite subst_context_app. simpl. rewrite /app_context. f_equal. + lia_f_equal. - + rewrite /subst_context // /fold_context /= /map_decl /=. + + rewrite /subst_context // /fold_context_k /= /map_decl /=. lia_f_equal. Qed. -Lemma smash_context_app Δ Γ Γ' : - smash_context Δ (Γ ++ Γ') = smash_context (smash_context Δ Γ) Γ'. -Proof. - revert Δ; induction Γ as [|[na [b|] ty]]; intros Δ; simpl; auto. -Qed. - Arguments Nat.sub : simpl nomatch. -Lemma extended_subst_length Γ n : #|extended_subst Γ n| = #|Γ|. -Proof. - induction Γ in n |- *; simpl; auto. - now destruct a as [? [?|] ?] => /=; simpl; rewrite IHΓ. -Qed. -Hint Rewrite extended_subst_length : len. - Lemma assumption_context_skipn Γ n : assumption_context Γ -> assumption_context (skipn n Γ). @@ -1144,209 +968,6 @@ Proof. intros -> ; reflexivity. Qed. -Lemma lift_extended_subst (Γ : context) k : - extended_subst Γ k = map (lift0 k) (extended_subst Γ 0). -Proof. - induction Γ as [|[? [] ?] ?] in k |- *; simpl; auto. - - rewrite IHΓ. f_equal. - autorewrite with len. - rewrite distr_lift_subst. f_equal. - autorewrite with len. rewrite simpl_lift; lia_f_equal. - - rewrite Nat.add_0_r; f_equal. - rewrite IHΓ (IHΓ 1). - rewrite map_map_compose. apply map_ext => x. - rewrite simpl_lift; try lia. - now rewrite Nat.add_1_r. -Qed. - -Lemma lift_extended_subst' Γ k k' : extended_subst Γ (k + k') = map (lift0 k) (extended_subst Γ k'). -Proof. - induction Γ as [|[? [] ?] ?] in k |- *; simpl; auto. - - rewrite IHΓ. f_equal. - autorewrite with len. - rewrite distr_lift_subst. f_equal. - autorewrite with len. rewrite simpl_lift; lia_f_equal. - - f_equal. - rewrite (IHΓ (S k)) (IHΓ 1). - rewrite map_map_compose. apply map_ext => x. - rewrite simpl_lift; lia_f_equal. -Qed. - -Lemma subst_extended_subst_k s Γ k k' : extended_subst (subst_context s k Γ) k' = - map (subst s (k + context_assumptions Γ + k')) (extended_subst Γ k'). -Proof. - induction Γ as [|[na [b|] ty] Γ]; simpl; auto; rewrite subst_context_snoc /=; - autorewrite with len; f_equal; auto. - - rewrite IHΓ. - rewrite commut_lift_subst_rec; try lia. - rewrite distr_subst. autorewrite with len. f_equal. - now rewrite context_assumptions_fold. - - elim: Nat.leb_spec => //. lia. - - rewrite (lift_extended_subst' _ 1 k') IHΓ. - rewrite (lift_extended_subst' _ 1 k'). - rewrite !map_map_compose. - apply map_ext. - intros x. - erewrite (commut_lift_subst_rec); lia_f_equal. -Qed. - -Lemma extended_subst_subst_instance_constr u Γ n : - map (subst_instance_constr u) (extended_subst Γ n) = - extended_subst (subst_instance_context u Γ) n. -Proof. - induction Γ as [|[?[]?] ?] in n |- *; simpl; auto. - - autorewrite with len. - f_equal; auto. - rewrite -subst_subst_instance_constr. - rewrite -lift_subst_instance_constr /=. - f_equal. apply IHΓ. - - f_equal; auto. -Qed. - -Local Open Scope sigma_scope. - -Lemma inst_extended_subst_shift (Γ : context) k : - map (inst ((extended_subst Γ 0 ⋅n ids) ∘s ↑^k)) (idsn #|Γ|) = - map (inst (extended_subst Γ k ⋅n ids)) (idsn #|Γ|). -Proof. - intros. - rewrite !map_idsn_spec. - apply nat_recursion_ext => x l' Hx. - f_equal. f_equal. - edestruct (@subst_consn_lt _ (extended_subst Γ k) x) as [d [Hd Hσ]]. - { now (autorewrite with len; lia). } - simpl. rewrite Hσ. - edestruct (@subst_consn_lt _ (extended_subst Γ 0) x) as [d' [Hd' Hσ']]; - try (autorewrite with len; trivial). - unfold subst_compose. rewrite Hσ'. - apply some_inj. - rewrite -Hd. change (Some d'.[↑^k]) with (option_map (fun x => inst (↑^k) x) (Some d')). - rewrite -Hd'. - rewrite (lift_extended_subst _ k). - rewrite nth_error_map. apply option_map_ext => t. - now autorewrite with sigma. -Qed. - -Lemma subst_context_decompo s s' Γ k : - subst_context (s ++ s') k Γ = - subst_context s' k (subst_context (map (lift0 #|s'|) s) k Γ). -Proof. - intros. - rewrite !subst_context_alt !mapi_compose. - apply mapi_ext => i x. - destruct x as [na [b|] ty] => //. - - rewrite /subst_decl /map_decl /=; f_equal. - + rewrite !mapi_length. f_equal. - now rewrite subst_app_decomp. - + rewrite mapi_length. - now rewrite subst_app_decomp. - - rewrite /subst_decl /map_decl /=; f_equal. - rewrite !mapi_length. now rewrite subst_app_decomp. -Qed. - -Lemma fold_context_compose f g Γ : - fold_context f (fold_context g Γ) = fold_context (fun n x => f n (g n x)) Γ. -Proof. - induction Γ; simpl; auto; rewrite !fold_context_snoc0. - simpl. rewrite IHΓ. f_equal. - rewrite PCUICAstUtils.compose_map_decl. - now rewrite fold_context_length. -Qed. - -Lemma fold_context_ext f g Γ : - f =2 g -> - fold_context f Γ = fold_context g Γ. -Proof. - intros hfg. - induction Γ; simpl; auto; rewrite !fold_context_snoc0. - simpl. rewrite IHΓ. f_equal. apply PCUICAstUtils.map_decl_ext. - intros. now apply hfg. -Qed. - -Lemma smash_context_acc Γ Δ : - smash_context Δ Γ = - subst_context (extended_subst Γ 0) 0 (lift_context (context_assumptions Γ) #|Γ| Δ) - ++ smash_context [] Γ. -Proof. - revert Δ. - induction Γ as [|[? [] ?] ?]; intros Δ. - - simpl; auto. - now rewrite subst0_context app_nil_r lift0_context. - - simpl. autorewrite with len. - rewrite IHΓ; auto. - rewrite subst_context_nil. f_equal. - rewrite (subst_context_decompo [_] _). - simpl. autorewrite with len. - rewrite lift0_id. - rewrite subst0_context. - unfold subst_context, lift_context. - rewrite !fold_context_compose. - apply fold_context_ext. intros n n' -> x. - rewrite Nat.add_0_r. - autorewrite with sigma. - apply inst_ext. - setoid_rewrite ren_lift_renaming. - autorewrite with sigma. - rewrite !Upn_compose. - apply Upn_ext. - autorewrite with sigma. - unfold Up. - rewrite subst_consn_subst_cons. - autorewrite with sigma. - reflexivity. - - - simpl. - rewrite IHΓ /=. auto. - rewrite (IHΓ [_]). auto. rewrite !app_assoc. f_equal. - rewrite app_nil_r. unfold map_decl. simpl. unfold app_context. - simpl. rewrite lift_context_app subst_context_app /app_context. simpl. - unfold lift_context at 2. unfold subst_context at 2, fold_context. simpl. - f_equal. - unfold subst_context, lift_context. - rewrite !fold_context_compose. - apply fold_context_ext. intros n n' ->. intros x. - rewrite Nat.add_0_r. - - autorewrite with sigma. - apply inst_ext. rewrite !ren_lift_renaming. - autorewrite with sigma. - rewrite !Upn_compose. - autorewrite with sigma. - apply Upn_ext. - unfold Up. - - rewrite subst_consn_subst_cons. - autorewrite with sigma. - apply subst_cons_proper; auto. - rewrite !Upn_eq. autorewrite with sigma. - rewrite subst_consn_compose. - setoid_rewrite subst_consn_compose at 2 3. - apply subst_consn_proper. - { rewrite -inst_extended_subst_shift; auto. } - - autorewrite with sigma. - rewrite -subst_compose_assoc. - rewrite shiftk_compose. - autorewrite with sigma. - setoid_rewrite <- (compose_ids_l ↑) at 2. - rewrite -subst_consn_compose. - rewrite - !subst_compose_assoc. - rewrite -shiftk_shift shiftk_compose. - autorewrite with sigma. - rewrite subst_consn_compose. - rewrite -shiftk_compose subst_compose_assoc. - rewrite subst_consn_shiftn. - 2:now autorewrite with len. - autorewrite with sigma. - rewrite -shiftk_shift. - rewrite -shiftk_compose subst_compose_assoc. - rewrite subst_consn_shiftn. - 2:now autorewrite with len. - now autorewrite with sigma. -Qed. - -Hint Rewrite context_assumptions_app context_assumptions_fold : len. - Lemma map_option_out_impl {A B} (l : list A) (f g : A -> option B) x : (forall x y, f x = Some y -> g x = Some y) -> map_option_out (map f l) = Some x -> @@ -1398,11 +1019,46 @@ Proof. erewrite decompose_app_subst; eauto. simpl. auto. Qed. -Lemma decompose_prod_assum_mkApps ctx ind u args : - decompose_prod_assum ctx (mkApps (tInd ind u) args) = (ctx, mkApps (tInd ind u) args). +Lemma 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. + +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. - apply (decompose_prod_assum_it_mkProd ctx []). - now rewrite is_ind_app_head_mkApps. + induction Γ as [|[? [] ?] ?] in |- *; simpl; auto; + intros; destruct n; simpl in *; rewrite ?subst_context_snoc in H0; simpl in H0. + - noconf H0; simpl. + specialize (H 0 _ eq_refl). simpl in H; discriminate. + - specialize (H 0 _ eq_refl). simpl in H; discriminate. + - noconf H0; simpl. auto. + - eapply IHΓ; intros; eauto. + now specialize (H (S n0) d0 H1). +Qed. + +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. + induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto. + - intros. eapply (IHΓ (subst_context [t] 0 Δ)); tea. + now apply nth_error_ass_subst_context. + - intros. eapply IHΓ. 2:eauto. + intros. + pose proof (nth_error_Some_length H1). autorewrite with len in H2. simpl in H2. + destruct (eq_dec n0 #|Δ|). + * subst. + rewrite nth_error_app_ge in H1; try lia. + rewrite Nat.sub_diag /= in H1. noconf H1. + reflexivity. + * rewrite nth_error_app_lt in H1; try lia. eauto. Qed. Lemma substitution_check_one_cofix s k mfix inds : @@ -1509,120 +1165,171 @@ Qed. Arguments iota_red : simpl never. -Lemma substitution_red1 {cf:checker_flags} (Σ : global_env_ext) Γ Γ' Γ'' s M N : +(** 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 -> + n < #|l| -> + nth_error_app_spec l l' n (Some x) +| nth_error_app_spec_right x : + nth_error l' (n - #|l|) = Some x -> + #|l| <= n < #|l| + #|l'| -> + nth_error_app_spec l l' n (Some x) +| nth_error_app_spec_out : #|l| + #|l'| <= n -> nth_error_app_spec l l' n None. + +Lemma nth_error_appP {A} (l l' : list A) (n : nat) : nth_error_app_spec l l' n (nth_error (l ++ l') n). +Proof. + destruct (Nat.ltb n #|l|) eqn:lt; [apply Nat.ltb_lt in lt|apply Nat.ltb_nlt in lt]. + * rewrite nth_error_app_lt //. + destruct (snd (nth_error_Some' _ _) lt) as [x eq]. + rewrite eq. + constructor; auto. + * destruct (Nat.ltb n (#|l| + #|l'|)) eqn:ltb'; [apply Nat.ltb_lt in ltb'|apply Nat.ltb_nlt in ltb']. + + rewrite nth_error_app2; try lia. + destruct nth_error eqn:hnth. + - constructor 2; auto; try lia. + - constructor. + eapply nth_error_None in hnth. lia. + + case: nth_error_spec => //; try lia. + { intros. len in l0. lia. } + len. intros. constructor. lia. +Qed. + +Lemma nth_error_app_context (Γ Δ : context) (n : nat) : + nth_error_app_spec Δ Γ n (nth_error (Γ ,,, Δ) n). +Proof. + apply nth_error_appP. +Qed. + +(** Substitution without lets in Γ' *) +Lemma subs_usubst {cf:checker_flags} Σ Γ Γ' Γ'' s : + subs Σ Γ s Γ' -> + usubst (Γ,,, Γ',,, Γ'') (⇑^#|Γ''| (s ⋅n ids)) (Γ,,, subst_context s 0 Γ''). +Proof. + intros subs n decl. + case: (nth_error_app_context (Γ ,,, Γ') Γ'' n) => // x hnth hlt [=] hx; subst x => b hb. + - left; eexists n, _. + split; auto. + * rewrite Upn_eq /subst_consn idsn_lt //. + * rewrite nth_error_app_lt; len => //. + change (fun m => S (n + m)) with (lift_renaming (S n) 0). + rewrite nth_error_subst_context /= hnth /=. split; eauto. + rewrite /= hb /=. f_equal. + rewrite subst_inst. rewrite Nat.add_0_r. + rewrite rename_inst. + replace #|Γ''| with ((#|Γ''| - S n) + S n) at 2 by lia. + set (k := S n). + sigma. apply inst_ext. + rewrite -shiftn_Upn - !Upn_Upn. intros i; lia_f_equal. + - move: hnth. + case: (nth_error_app_context Γ Γ' _) => // x' hnth hn' [=] eq; subst x'. + * elimtype False. + revert subs hnth hb; generalize (n - #|Γ''|); clear. + intros n subs; induction subs in n |- *; simpl => //. + { now rewrite nth_error_nil //. } + { destruct n; simpl. + * intros [= <-] => //. + * intros hnth. now specialize (IHsubs _ hnth). } + * left; exists (n - #|Γ'|), decl. + repeat split. + + rewrite Upn_eq /subst_consn nth_error_idsn_None //; try lia. + unfold subst_compose. + apply subs_length in subs. + rewrite (proj2 (nth_error_None _ _)); try (len; lia). + simpl. len. unfold shiftk. lia_f_equal. + + rewrite nth_error_app_ge; len; try lia. + rewrite -hnth. lia_f_equal. + + rewrite -lift_renaming_0_rshift hb /=. + f_equal. rewrite rename_inst. rewrite lift_renaming_spec shiftn0 ren_shiftk. + apply inst_ext. + apply subs_length in subs. + replace (S n) with ((S (n - #|Γ''|)) + #|Γ''|) by lia. + rewrite -shiftk_compose subst_compose_assoc. + rewrite shiftn_Upn -subst_compose_assoc. + replace (S (n - #|Γ''|)) with ((S (n - #|Γ''|) - #|Γ'|) + #|Γ'|) by lia. + rewrite -shiftk_compose !subst_compose_assoc. + rewrite -(subst_compose_assoc _ _ (↑^#|Γ''|)). + rewrite subst_consn_shiftn //. + rewrite !shiftk_compose. intros i; lia_f_equal. +Qed. + +Lemma untyped_subslet_length {Γ s Δ} : untyped_subslet Γ s Δ -> #|s| = #|Δ|. +Proof. + induction 1; simpl; lia. +Qed. + +(* Let-expanding substitution *) +Lemma subslet_usubst {Γ Δ Γ' s} : + untyped_subslet Γ s Δ -> + usubst (Γ,,, Δ,,, Γ') (⇑^#|Γ'| (s ⋅n ids)) (Γ,,, subst_context s 0 Γ'). +Proof. + intros subs n decl. + case: (nth_error_app_context (Γ ,,, Δ) Γ' n) => // x hnth hlt [=] hx; subst x => b hb. + - left; eexists n, _. + split; auto. + * rewrite Upn_eq /subst_consn idsn_lt //. + * rewrite nth_error_app_lt; len => //. + change (fun m => S (n + m)) with (lift_renaming (S n) 0). + rewrite nth_error_subst_context /= hnth /=. split; eauto. + rewrite /= hb /=. f_equal. + rewrite subst_inst. rewrite Nat.add_0_r. + rewrite rename_inst. rewrite ren_lift_renaming Upn_0. + replace #|Γ'| with ((#|Γ'| - S n) + S n) at 2 by lia. + set (k := S n). + sigma. apply inst_ext. + rewrite -shiftn_Upn - !Upn_Upn. intros i; lia_f_equal. + - move: hnth. + case: (nth_error_app_context Γ Δ _) => // x' hnth hn' [=] eq; subst x'. + * right. + 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. + 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. 2:lia. + rewrite !subst_compose_assoc. + rewrite subst_consn_compose. sigma. + rewrite -subst_compose_assoc -shiftk_shift -subst_compose_assoc. + rewrite -shiftk_shift. + rewrite (shift_subst_consn_ge (S n)). 2:len; lia. now len. + * left; exists (n - #|s|), decl. + pose proof (untyped_subslet_length subs). + repeat split. + + rewrite Upn_eq /subst_consn nth_error_idsn_None //; try lia. + unfold subst_compose. + rewrite (proj2 (nth_error_None _ _)); try (len; lia). + simpl. len. unfold shiftk. lia_f_equal. + + rewrite nth_error_app_ge; len; try lia. + rewrite -hnth. lia_f_equal. + + rewrite -lift_renaming_0_rshift hb /=. + f_equal; sigma. + apply inst_ext. rewrite -shiftk_shift. + rewrite - !subst_compose_assoc -shiftk_shift. + replace (S n) with ((S n - #|Γ'|) + #|Γ'|) by lia. + rewrite -shiftk_compose subst_compose_assoc shiftn_Upn. + replace (S n - #|Γ'|) with (S (n - #|Γ'| - #|s|) + #|s|) by lia. + rewrite -shiftk_compose subst_compose_assoc -(subst_compose_assoc (↑^#|s|)). + rewrite subst_consn_shiftn //. sigma. + rewrite -shiftk_shift. rewrite -shiftk_shift_l shiftk_compose. + now replace (n - #|Γ'| - #|s| + S #|Γ'|) with (S (n - #|s|)) by lia. +Qed. + +Lemma substitution_red1 {cf:checker_flags} (Σ : global_env_ext) {Γ Γ' Γ'' s M N} : wf Σ -> subs Σ Γ s Γ' -> wf_local Σ Γ -> red1 Σ (Γ ,,, Γ' ,,, Γ'') M N -> - red1 Σ (Γ ,,, subst_context s 0 Γ'') (subst s #|Γ''| M) (subst s #|Γ''| N). + red Σ (Γ ,,, subst_context s 0 Γ'') (subst s #|Γ''| M) (subst s #|Γ''| N). Proof. intros wfΣ Hs wfΓ H. - remember (Γ ,,, Γ' ,,, Γ'') as Γ0. revert Γ Γ' Γ'' HeqΓ0 wfΓ Hs. - induction H using red1_ind_all in |- *; intros Γ0 Γ' Γ'' HeqΓ0 wfΓ Hs; try subst Γ; cbn -[iota_red]; - match goal with - |- context [iota_red _ _ _ _] => idtac - | |- _ => autorewrite with subst - end; - try solve [ econstructor; try inv wfM; eauto ]. - - - pose proof (subst_length _ _ _ _ Hs). - elim (leb_spec_Set); intros Hn. - + destruct (nth_error s) eqn:Heq. - * pose proof (nth_error_Some_length Heq). - rewrite -> nth_error_app_context_ge in H by lia. - rewrite -> nth_error_app_context_lt in H by lia. - destruct nth_error eqn:HΓ'. - -- destruct c as [na [b|] ty]; noconf H. - eapply subs_nth_error in Heq; eauto. simpl in Heq. destruct Heq. - -- noconf H. - * apply nth_error_None in Heq. - assert(S i = #|s| + (S (i - #|s|))) by lia. - rewrite H1. rewrite -> simpl_subst; try lia. - econstructor. - rewrite nth_error_app_context_ge // in H. - rewrite nth_error_app_context_ge // in H. 1: lia. - rewrite -> nth_error_app_context_ge. 2:(autorewrite with wf; lia). - rewrite <- H. f_equal. f_equal. autorewrite with wf. lia. - + rewrite -> nth_error_app_context_lt in H by lia. - pose (commut_lift_subst_rec body s (S i) (#|Γ''| - S i) 0). - assert(eq:#|Γ''| - S i + S i = #|Γ''|) by lia. - rewrite -> eq in e. rewrite <- e by lia. - constructor. - rewrite -> nth_error_app_context_lt by (autorewrite with wf; lia). - rewrite -> nth_error_subst_context. - unfold subst_decl; now rewrite -> option_map_decl_body_map_decl, H, Nat.add_0_r. - - - rewrite subst_iota_red. - autorewrite with subst. - constructor. - - - pose proof (subst_declared_constant _ _ _ s #|Γ''| u wfΣ H). - apply (f_equal cst_body) in H1. - rewrite <- !map_cst_body in H1. rewrite H0 in H1. simpl in H1. - injection H1. intros ->. - econstructor. all: eauto. - - - simpl. constructor. - now rewrite nth_error_map H. - - - constructor. - specialize (IHred1 Γ0 Γ' (Γ'' ,, vass na N) eq_refl). - now rewrite subst_context_snoc0 in IHred1. - - - constructor. - specialize (IHred1 Γ0 Γ' (Γ'' ,, _) eq_refl). - now rewrite subst_context_snoc0 in IHred1. - - - constructor. - induction X; constructor; auto. - intuition; eauto. - - - constructor. specialize (IHred1 _ _ (Γ'' ,, vass na M1) eq_refl). - now rewrite subst_context_snoc0 in IHred1. - - - constructor. - induction X; constructor; auto. - intuition. - - - constructor. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - induction X; simpl; constructor; simpl; intuition auto. - + eapply b0; eauto. - + congruence. - - - apply fix_red_body. rewrite !subst_fix_context. - solve_all. - rewrite <- (OnOne2_length X). - eapply OnOne2_map. unfold on_Trel; solve_all. - + rename_all_hyps. - specialize (forall_Γ Γ0 Γ' (Γ'' ,,, fix_context mfix0)). - rewrite app_context_assoc in forall_Γ. specialize (forall_Γ eq_refl). - rewrite -> app_context_length, fix_context_length in *. - rewrite -> subst_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - auto. - + congruence. + rewrite !subst_inst. + eapply red1_inst; eauto. + now eapply subs_usubst. +Qed. - - constructor. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - !induction X; simpl; constructor; auto. - intuition auto. - + rename_all_hyps. eapply forall_Γ; eauto. - + simpl. congruence. - - - apply cofix_red_body. rewrite !subst_fix_context. - solve_all. - rewrite <- (OnOne2_length X). - eapply OnOne2_map. unfold on_Trel; solve_all. - + rename_all_hyps. - specialize (forall_Γ Γ0 Γ' (Γ'' ,,, fix_context mfix0)). - rewrite app_context_assoc in forall_Γ. specialize (forall_Γ eq_refl). - rewrite -> app_context_length, fix_context_length in *. - rewrite -> subst_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - auto. - + congruence. -Qed. - -Lemma subst_skipn n s k t : n <= #|s| -> subst (skipn n s) k t = subst s k (lift n k t). +Lemma subst_skipn {n s k t} : n <= #|s| -> subst (skipn n s) k t = subst s k (lift n k t). Proof. intros Hn. assert (#|firstn n s| = n) by (rewrite firstn_length_le; lia). @@ -1632,332 +1339,26 @@ Proof. rewrite -{3}H. now rewrite simpl_subst_k. Qed. -Lemma substitution_let_red `{cf : checker_flags} (Σ : global_env_ext) Γ Δ Γ' s M N : +Lemma substitution_let_red `{cf : checker_flags} (Σ : global_env_ext) {Γ Δ Γ' s M N} : wf Σ -> subslet Σ Γ s Δ -> wf_local Σ Γ -> red1 Σ (Γ ,,, Δ ,,, Γ') M N -> red Σ (Γ ,,, subst_context s 0 Γ') (subst s #|Γ'| M) (subst s #|Γ'| N). Proof. intros wfΣ Hs wfΓ H. - remember (Γ ,,, Δ ,,, Γ') as Γ0. revert Γ Δ Γ' HeqΓ0 wfΓ Hs. - induction H using red1_ind_all in |- *; intros Γ0 Δ Γ' HeqΓ0 wfΓ Hs; try subst Γ; cbn -[iota_red]; - match goal with - |- context [iota_red _ _ _ _] => idtac - | |- _ => autorewrite with subst - end; - try solve [ apply red1_red; econstructor; try inv wfM; eauto ]. - - - pose proof (subslet_length Hs). - elim (leb_spec_Set); intros Hn. - + destruct (nth_error s) eqn:Heq. - * pose proof (nth_error_Some_length Heq). - rewrite -> nth_error_app_context_ge in H by lia. - rewrite -> nth_error_app_context_lt in H by lia. - destruct nth_error eqn:HΓ'. - -- destruct c as [na [b|] ty]; noconf H. - eapply subslet_nth_error in Heq; eauto. simpl in Heq. destruct Heq. - subst t. - pose (commut_lift_subst_rec body (skipn (S (i - #|Γ'|)) s) #|Γ'| 0 0). - forward e by lia. rewrite e. - simpl. rewrite subst_skipn. 1: auto with arith. - rewrite simpl_lift; auto with arith. - assert(S (i - #|Γ'|) + #|Γ'| = S i) as -> by lia. - reflexivity. - -- noconf H. - * apply nth_error_None in Heq. - assert(S i = #|s| + (S (i - #|s|))) by lia. - rewrite H1. rewrite -> simpl_subst; try lia. - apply red1_red. - econstructor. - rewrite nth_error_app_context_ge // in H. - rewrite nth_error_app_context_ge // in H. 1: lia. - rewrite -> nth_error_app_context_ge. 2:(autorewrite with wf; lia). - rewrite <- H. f_equal. f_equal. autorewrite with wf. lia. - + rewrite -> nth_error_app_context_lt in H by lia. - pose (commut_lift_subst_rec body s (S i) (#|Γ'| - S i) 0). - assert(eq:#|Γ'| - S i + S i = #|Γ'|) by lia. - rewrite -> eq in e. rewrite <- e by lia. - apply red1_red. constructor. - rewrite -> nth_error_app_context_lt by (autorewrite with wf; lia). - rewrite -> nth_error_subst_context. - unfold subst_decl; now rewrite -> option_map_decl_body_map_decl, H, Nat.add_0_r. - - - rewrite subst_iota_red. - autorewrite with subst. - apply red1_red; constructor. - - - pose proof (subst_declared_constant _ _ _ s #|Γ'| u wfΣ H). - apply (f_equal cst_body) in H1. - rewrite <- !map_cst_body in H1. rewrite H0 in H1. simpl in H1. - injection H1. intros ->. apply red1_red. - econstructor. all: eauto. - - - simpl. apply red1_red; constructor. - now rewrite nth_error_map H. - - - specialize (IHred1 Γ0 Δ Γ' eq_refl wfΓ Hs). - apply red_abs. 1: auto. reflexivity. - - - specialize (IHred1 Γ0 Δ (Γ' ,, _) eq_refl wfΓ Hs). - apply red_abs; auto. - now rewrite subst_context_snoc0 in IHred1. - - - specialize (IHred1 _ _ Γ' eq_refl wfΓ Hs). - apply red_letin; auto. - - - specialize (IHred1 _ _ Γ' eq_refl wfΓ Hs). - apply red_letin; auto. - - - specialize (IHred1 _ _ (Γ' ,, _) eq_refl wfΓ Hs). - apply red_letin; auto. - now rewrite subst_context_snoc0 in IHred1. - - - eqns_specialize_eqs IHred1. eapply red_case; auto. - apply All2_map, All2_same. intros. split; auto. - - - eqns_specialize_eqs IHred1. eapply red_case; auto. - apply All2_map, All2_same. intros. split; auto. - - - apply red_case; auto. - apply All2_map. - eapply OnOne2_All2; eauto. simpl. intuition eauto. - - - apply red_proj_c. eauto. - - - apply red_app; eauto. - - - eapply red_app; eauto. - - - eapply red_prod; eauto. - - - eapply red_prod; eauto. - specialize (IHred1 _ _ (_ ,, _) eq_refl wfΓ Hs). - simpl in IHred1. now rewrite subst_context_snoc0 in IHred1. - - - eapply red_evar; eauto. - eapply All2_map. eapply OnOne2_All2; tea; cbnr. - intuition. - - - eapply red_fix_one_ty. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - intros. - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + eapply ih ; eauto. - + cbn. f_equal. - - - eapply red_fix_one_body. - rewrite -> (OnOne2_length X). - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + cbn. specialize (ih Γ0 Δ (Γ' ,,, fix_context mfix0)). - rewrite app_context_assoc in ih. - specialize (ih eq_refl wfΓ Hs). - rewrite -> subst_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - rewrite app_context_length in ih. - rewrite fix_context_length in ih. - rewrite <- subst_fix_context in ih. - rewrite <- (OnOne2_length X). - eapply ih ; eauto. - + cbn. f_equal. - - - eapply red_cofix_one_ty. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - intros. - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + eapply ih ; eauto. - + cbn. f_equal. - - - eapply red_cofix_one_body. - rewrite -> (OnOne2_length X). - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + cbn. specialize (ih Γ0 Δ (Γ' ,,, fix_context mfix0)). - rewrite app_context_assoc in ih. - specialize (ih eq_refl wfΓ Hs). - rewrite -> subst_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - rewrite app_context_length in ih. - rewrite fix_context_length in ih. - rewrite <- subst_fix_context in ih. - rewrite <- (OnOne2_length X). - eapply ih ; eauto. - + cbn. f_equal. + rewrite !subst_inst. + eapply red1_inst; eauto. + now eapply (subslet_usubst Hs). Qed. -Lemma untyped_substlet_length {Γ s Δ} : untyped_subslet Γ s Δ -> #|s| = #|Δ|. -Proof. - induction 1; simpl; auto with arith. -Qed. - -Lemma substitution_untyped_let_red {cf:checker_flags} Σ Γ Δ Γ' s M N : +Lemma substitution_untyped_let_red {cf:checker_flags} (Σ : global_env_ext) Γ Δ Γ' s M N : wf Σ -> untyped_subslet Γ s Δ -> red1 Σ (Γ ,,, Δ ,,, Γ') M N -> red Σ (Γ ,,, subst_context s 0 Γ') (subst s #|Γ'| M) (subst s #|Γ'| N). Proof. intros wfΣ Hs H. - remember (Γ ,,, Δ ,,, Γ') as Γ0. revert Γ Δ Γ' HeqΓ0 Hs. - induction H using red1_ind_all in |- *; intros Γ0 Δ Γ' HeqΓ0 Hs; try subst Γ; cbn -[iota_red]; - match goal with - |- context [iota_red _ _ _ _] => idtac - | |- _ => autorewrite with subst - end; - try solve [ apply red1_red; econstructor; try inv wfM; eauto ]. - - - pose proof (untyped_substlet_length Hs). - elim (leb_spec_Set); intros Hn. - + destruct (nth_error s) eqn:Heq. - * pose proof (nth_error_Some_length Heq). - rewrite -> nth_error_app_context_ge in H by lia. - rewrite -> nth_error_app_context_lt in H by lia. - destruct nth_error eqn:HΓ'. 2: noconf H. - destruct c as [na [b|] ty]; noconf H. - eapply untyped_subslet_nth_error in Heq; eauto. simpl in Heq. - subst t. - pose (commut_lift_subst_rec body (skipn (S (i - #|Γ'|)) s) #|Γ'| 0 0). - forward e by lia. rewrite e. - simpl. rewrite subst_skipn. 1: auto with arith. - rewrite simpl_lift; auto with arith. - assert(S (i - #|Γ'|) + #|Γ'| = S i) as -> by lia. - reflexivity. - * apply nth_error_None in Heq. - assert(S i = #|s| + (S (i - #|s|))) by lia. - rewrite H1. rewrite -> simpl_subst; try lia. - apply red1_red. - econstructor. - rewrite nth_error_app_context_ge // in H. - rewrite nth_error_app_context_ge // in H. 1: lia. - rewrite -> nth_error_app_context_ge. 2:(autorewrite with wf; lia). - rewrite <- H. f_equal. f_equal. autorewrite with wf. lia. - + rewrite -> nth_error_app_context_lt in H by lia. - pose (commut_lift_subst_rec body s (S i) (#|Γ'| - S i) 0). - assert(eq:#|Γ'| - S i + S i = #|Γ'|) by lia. - rewrite -> eq in e. rewrite <- e by lia. - apply red1_red. constructor. - rewrite -> nth_error_app_context_lt by (autorewrite with wf; lia). - rewrite -> nth_error_subst_context. - unfold subst_decl; now rewrite -> option_map_decl_body_map_decl, H, Nat.add_0_r. - - - rewrite subst_iota_red. - autorewrite with subst. - apply red1_red; constructor. - - - pose proof (subst_declared_constant _ _ _ s #|Γ'| u wfΣ H). - apply (f_equal cst_body) in H1. - rewrite <- !map_cst_body in H1. rewrite H0 in H1. simpl in H1. - injection H1. intros ->. apply red1_red. - econstructor. all: eauto. - - - simpl. apply red1_red; constructor. - now rewrite nth_error_map H. - - - specialize (IHred1 Γ0 Δ Γ' eq_refl Hs). - apply red_abs. 1: auto. reflexivity. - - - specialize (IHred1 Γ0 Δ (Γ' ,, _) eq_refl Hs). - apply red_abs; auto with pcuic. - now rewrite subst_context_snoc0 in IHred1. - - - specialize (IHred1 _ _ Γ' eq_refl Hs). - apply red_letin; auto. - - - specialize (IHred1 _ _ Γ' eq_refl Hs). - apply red_letin; auto. - - - specialize (IHred1 _ _ (Γ' ,, _) eq_refl Hs). - apply red_letin; auto. - now rewrite subst_context_snoc0 in IHred1. - - - eqns_specialize_eqs IHred1. eapply red_case; auto. - apply All2_map, All2_same. intros. split; auto. - - - eqns_specialize_eqs IHred1. eapply red_case; auto. - apply All2_map, All2_same. intros. split; auto. - - - apply red_case; auto. - eapply All2_map. - eapply OnOne2_All2; eauto. simpl. intuition eauto. - - - apply red_proj_c. eauto. - - - apply red_app; eauto. - - - eapply red_app; eauto. - - - eapply red_prod; eauto. - - - eapply red_prod; eauto. - specialize (IHred1 _ _ (_ ,, _) eq_refl Hs). - simpl in IHred1. now rewrite subst_context_snoc0 in IHred1. - - - eapply red_evar; eauto. - eapply All2_map. eapply OnOne2_All2; tea; cbnr. - intuition. - - - eapply red_fix_one_ty. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - intros. - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + eapply ih ; eauto. - + cbn. f_equal. - - - eapply red_fix_one_body. - rewrite -> (OnOne2_length X). - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + cbn. specialize (ih Γ0 Δ (Γ' ,,, fix_context mfix0)). - rewrite app_context_assoc in ih. - specialize (ih eq_refl). - rewrite -> subst_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - rewrite app_context_length in ih. - rewrite fix_context_length in ih. - rewrite <- subst_fix_context in ih. - rewrite <- (OnOne2_length X). - eapply ih ; eauto. - + cbn. f_equal. - - - eapply red_cofix_one_ty. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - intros. - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + eapply ih ; eauto. - + cbn. f_equal. - - - eapply red_cofix_one_body. - rewrite -> (OnOne2_length X). - eapply OnOne2_map. eapply OnOne2_impl ; eauto. - intros [? ? ? ?] [? ? ? ?] [[? ih] e]. simpl in *. - inversion e. subst. clear e. - split. - + cbn. specialize (ih Γ0 Δ (Γ' ,,, fix_context mfix0)). - rewrite app_context_assoc in ih. - specialize (ih eq_refl). - rewrite -> subst_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - rewrite app_context_length in ih. - rewrite fix_context_length in ih. - rewrite <- subst_fix_context in ih. - rewrite <- (OnOne2_length X). - eapply ih ; eauto. - + cbn. f_equal. + rewrite !subst_inst. + eapply red1_inst; eauto. + now eapply subslet_usubst. Qed. Lemma substitution_untyped_red {cf:checker_flags} Σ Γ Δ Γ' s M N : @@ -1979,22 +1380,20 @@ Proof. - apply subst_eq_term. Qed. -Lemma subst_eq_decl `{checker_flags} le Σ ϕ l k d d' : +Lemma subst_eq_decl `{checker_flags} {le Σ ϕ l k d d'} : eq_decl le Σ ϕ d d' -> eq_decl le Σ ϕ (subst_decl l k d) (subst_decl l k d'). Proof. - destruct d, d', decl_body, decl_body0; - unfold eq_decl, map_decl; cbn; intuition auto using subst_compare_term, subst_eq_term. + intros []; constructor; auto; destruct le; + intuition eauto using subst_compare_term, subst_eq_term, subst_leq_term. Qed. Lemma subst_eq_context `{checker_flags} le Σ φ l l' n k : eq_context le Σ φ l l' -> eq_context le Σ φ (subst_context n k l) (subst_context n k l'). Proof. - induction l in l', n, k |- *; inversion 1. 1: constructor. - rewrite !subst_context_snoc. constructor. - - erewrite All2_length by eassumption. - now apply subst_eq_decl. - - now apply IHl. + induction 1; rewrite ?subst_context_snoc /=; constructor; auto. + erewrite (All2_fold_length X). simpl. + apply (subst_eq_decl p). Qed. Lemma substitution_red `{cf : checker_flags} (Σ : global_env_ext) Γ Δ Γ' s M N : @@ -2006,6 +1405,32 @@ Proof. - eapply substitution_let_red; eauto. - etransitivity; eauto. Qed. + +Lemma red_red_onctx {cf:checker_flags} Σ Γ Δ Γ' s s' ctx : + untyped_subslet Γ s Δ -> + onctx + (fun b : term => + forall Δ Γ'0 : context, + untyped_subslet Γ s Δ -> + red Σ (Γ,,, Γ'0) (subst s #|Γ'0| b) (subst s' #|Γ'0| b)) ctx -> + All2_fold + (fun (Γ0 Δ0 : context) (d d' : context_decl) => + red_decls Σ (Γ,,, Γ',,, mapi_context (shiftf (subst s) #|Γ'|) Γ0) + (Γ,,, Γ',,, mapi_context (shiftf (subst s') #|Γ'|) Δ0) + (map_decl (shiftf (subst s) #|Γ'| #|Γ0|) d) + (map_decl (shiftf (subst s') #|Γ'| #|Γ0|) d')) ctx ctx. +Proof. + intros hsubs. + induction 1; constructor; auto. + destruct p. destruct x as [na [b|] ty]; constructor; auto; simpl in *; + rewrite /shiftf. + - specialize (o _ (Γ' ,,, mapi_context (fun k' => subst s (k' + #|Γ'|)) l) hsubs). + len in o. now rewrite -app_context_assoc. + - specialize (r _ (Γ' ,,, mapi_context (fun k' => subst s (k' + #|Γ'|)) l) hsubs). + len in r. now rewrite -app_context_assoc. + - specialize (r _ (Γ' ,,, mapi_context (fun k' => subst s (k' + #|Γ'|)) l) hsubs). + len in r. now rewrite -app_context_assoc. +Qed. Lemma red_red {cf:checker_flags} (Σ : global_env_ext) Γ Δ Γ' s s' b : wf Σ -> All2 (red Σ Γ) s s' -> @@ -2019,7 +1444,8 @@ Proof. |- context [tRel _] => idtac | |- _ => cbn -[plus] end; try easy; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc; + autorewrite with map; + rewrite ?Nat.add_assoc; try solve [f_equal; auto; solve_all]. - unfold subst. @@ -2040,18 +1466,28 @@ Proof. - apply red_letin; eauto. now eapply (X1 Δ (Γ' ,, _)). - - apply red_app; eauto. - - apply red_case; eauto. - unfold on_Trel in *; solve_all. + - eapply (red_case (p:=(map_predicate_k id (subst s) #|Γ'| p))); simpl; solve_all. + * specialize (r _ (Γ' ,,, subst_context s #|Γ'| (pcontext p)) Hsubs). len in r. + now rewrite mapi_context_fold -app_context_assoc. + * eapply red_ctx_rel_red_context_rel => //. + eapply All2_fold_mapi. + eapply red_red_onctx; tea. + * red. solve_all. + eapply All_All2; tea => /=. solve_all; unfold on_Trel; simpl. + + specialize (b0 _ (Γ' ,,, mapi_context (shiftf (subst s) #|Γ'|) (bcontext x)) Hsubs). + len in b0. now rewrite -app_context_assoc. + + eapply red_ctx_rel_red_context_rel => //. + eapply All2_fold_mapi. + eapply red_red_onctx; tea. - apply red_proj_c; eauto. - apply red_fix_congr; eauto. - solve_all. + solve_all. eapply All_All2; tea; simpl; solve_all. rewrite subst_fix_context. specialize (b0 _ (Γ' ,,, subst_context s #|Γ'| (fix_context m)) Hsubs). now rewrite app_context_length subst_context_length app_context_assoc fix_context_length in b0. - apply red_cofix_congr; eauto. - red in X. solve_all. + red in X. solve_all. eapply All_All2; tea; simpl; solve_all. rewrite subst_fix_context. specialize (b0 _ (Γ' ,,, subst_context s #|Γ'| (fix_context m)) Hsubs). now rewrite app_context_length subst_context_length app_context_assoc fix_context_length in b0. @@ -2067,124 +1503,9 @@ Proof. - etransitivity; eauto. Qed. -(** The cumulativity relation is substitutive, yay! *) - -Fixpoint subst_stack s k π := - match π with - | ε => ε - | App u π => - let k' := #|stack_context π| + k in - App (subst s k' u) (subst_stack s k π) - | Fix mfix idx args π => - let k' := #|stack_context π| + k in - let k'' := #|mfix| + k' in - let mfix' := List.map (map_def (subst s k') (subst s k'')) mfix in - Fix mfix' idx (map (subst s k') args) (subst_stack s k π) - | Fix_mfix_ty na bo ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (subst s k') (subst s k'')) mfix1 in - let mfix2' := List.map (map_def (subst s k') (subst s k'')) mfix2 in - Fix_mfix_ty na (subst s k'' bo) ra mfix1' mfix2' idx (subst_stack s k π) - | Fix_mfix_bd na ty ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (subst s k') (subst s k'')) mfix1 in - let mfix2' := List.map (map_def (subst s k') (subst s k'')) mfix2 in - Fix_mfix_bd na (subst s k' ty) ra mfix1' mfix2' idx (subst_stack s k π) - | CoFix mfix idx args π => - let k' := #|stack_context π| + k in - let k'' := #|mfix| + k' in - let mfix' := List.map (map_def (subst s k') (subst s k'')) mfix in - CoFix mfix' idx (map (subst s k') args) (subst_stack s k π) - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (subst s k') (subst s k'')) mfix1 in - let mfix2' := List.map (map_def (subst s k') (subst s k'')) mfix2 in - CoFix_mfix_ty na (subst s k'' bo) ra mfix1' mfix2' idx (subst_stack s k π) - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (subst s k') (subst s k'')) mfix1 in - let mfix2' := List.map (map_def (subst s k') (subst s k'')) mfix2 in - CoFix_mfix_bd na (subst s k' ty) ra mfix1' mfix2' idx (subst_stack s k π) - | Case_p indn c brs π => - let k' := #|stack_context π| + k in - let brs' := List.map (on_snd (subst s k')) brs in - Case_p indn (subst s k' c) brs' (subst_stack s k π) - | Case indn pred brs π => - let k' := #|stack_context π| + k in - let brs' := List.map (on_snd (subst s k')) brs in - Case indn (subst s k' pred) brs' (subst_stack s k π) - | Case_brs indn pred c m brs1 brs2 π => - let k' := #|stack_context π| + k in - let brs1' := List.map (on_snd (subst s k')) brs1 in - let brs2' := List.map (on_snd (subst s k')) brs2 in - Case_brs indn (subst s k' pred) (subst s k' c) m brs1' brs2' (subst_stack s k π) - | Proj p π => - Proj p (subst_stack s k π) - | Prod_l na B π => - let k' := #|stack_context π| + k in - Prod_l na (subst s (S k') B) (subst_stack s k π) - | Prod_r na A π => - let k' := #|stack_context π| + k in - Prod_r na (subst s k' A) (subst_stack s k π) - | Lambda_ty na b π => - let k' := #|stack_context π| + k in - Lambda_ty na (subst s (S k') b) (subst_stack s k π) - | Lambda_tm na A π => - let k' := #|stack_context π| + k in - Lambda_tm na (subst s k' A) (subst_stack s k π) - | LetIn_bd na B u π => - let k' := #|stack_context π| + k in - LetIn_bd na (subst s k' B) (subst s (S k') u) (subst_stack s k π) - | LetIn_ty na b u π => - let k' := #|stack_context π| + k in - LetIn_ty na (subst s k' b) (subst s (S k') u) (subst_stack s k π) - | LetIn_in na b B π => - let k' := #|stack_context π| + k in - LetIn_in na (subst s k' b) (subst s k' B) (subst_stack s k π) - | coApp u π => - let k' := #|stack_context π| + k in - coApp (subst s k' u) (subst_stack s k π) - end. +Notation subst_predicate s := (map_predicate_k id (subst s)). -Lemma subst_zipc : - forall s k t π, - let k' := #|stack_context π| + k in - subst s k (zipc t π) = - zipc (subst s k' t) (subst_stack s k π). -Proof. - intros s k t π k'. - induction π in s, k, t, k' |- *. - all: try reflexivity. - all: try solve [ - simpl ; rewrite IHπ ; cbn ; reflexivity - ]. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite subst_mkApps. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. f_equal. - unfold map_def at 1. cbn. f_equal. - rewrite fix_context_alt_length. - rewrite !app_length. cbn. rewrite !map_length. - f_equal. f_equal. lia. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite subst_mkApps. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. f_equal. - unfold map_def at 1. cbn. f_equal. - rewrite fix_context_alt_length. - rewrite !app_length. cbn. rewrite !map_length. - f_equal. f_equal. lia. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. cbn. reflexivity. -Qed. +(** The cumulativity relation is substitutive, yay! *) Lemma substitution_untyped_cumul {cf:checker_flags} Σ Γ Γ' Γ'' s M N : wf Σ.1 -> untyped_subslet Γ s Γ' -> @@ -2325,10 +1646,10 @@ Proof. rewrite !map_cst_type. eapply subst_declared_constant in H as ->; eauto. - eapply refine_type. econstructor; eauto. - eapply on_declared_inductive in isdecl as [on_mind on_ind]; auto. + eapply on_declared_inductive in as isdecl [on_mind on_ind]; auto. apply onArity in on_ind as [[s' Hindty] _]. apply typecheck_closed in Hindty as [_ Hindty]; eauto. symmetry. - move/andb_and/proj1: Hindty. rewrite -(closedn_subst_instance_constr _ _ u) => Hty. + move/andb_and/proj1: Hindty. rewrite -(closedn_subst_instance _ _ u) => Hty. apply: (subst_closedn s #|Δ|); auto with wf. eapply closed_upwards. eauto. simpl; lia. @@ -2474,218 +1795,133 @@ Proof. Qed. *) +Lemma usubst_well_subst {cf} Σ Γ σ Δ : + usubst Γ σ Δ -> + (forall x decl, nth_error Γ x = Some decl -> + Σ ;;; Δ |- σ x : (decl.(decl_type)).[↑^(S x) ∘s σ]) -> + well_subst Σ Γ σ Δ. +Proof. + intros us hty. + intros x decl hnth. + split. + * specialize (hty x decl hnth). + now sigma. + * apply (us x decl hnth). +Qed. + +Lemma subslet_well_subst {cf} {Σ} {wfΣ : wf Σ} {Γ Γ' s Δ} : + subslet Σ Γ s Γ' -> + wf_local Σ (Γ ,,, subst_context s 0 Δ) -> + well_subst Σ (Γ ,,, Γ' ,,, Δ) (⇑^#|Δ| (s ⋅n ids)) (Γ ,,, subst_context s 0 Δ). +Proof. + intros hs hsΔ. + apply usubst_well_subst. + * apply (subslet_usubst hs). + * intros x decl. + case: nth_error_app_context => //. + { intros d hnth hn [= ->]. + rewrite {1}Upn_eq subst_consn_lt; len => //. rewrite /subst_fn. + rewrite idsn_lt //. + eapply meta_conv. + - econstructor; auto. + rewrite nth_error_app_lt; len => //. + now rewrite nth_error_subst_context hnth. + - rewrite /subst_decl. simpl. + rewrite lift0_inst !subst_inst_aux Nat.add_0_r. + sigma. rewrite -shiftk_shift -subst_compose_assoc -shiftk_shift. + rewrite subst_shift_comm. + rewrite -subst_fn_subst_consn. lia_f_equal. } + { intros n hnth; len; intros hd [= ->]. + pose proof (subslet_length hs). + move: hnth; case: nth_error_app_context => //. + * intros n hnth hx [= ->]. + rewrite {1}Upn_eq subst_consn_ge; len => //; try lia. + rewrite subst_consn_compose. + rewrite subst_consn_lt; len; try lia. + unfold subst_fn. rewrite nth_error_map. + destruct (subslet_nth_error hs hnth) as [t [hnths [hty hb]]]. + rewrite hnths /=. sigma in hty. + eapply meta_conv in hty. + 2:now rewrite skipn_subst ?Upn_0; try lia. + eapply (shift_typing (Δ := subst_context s 0 Δ)) in hty. + 2:tas. + 2:now len. + rewrite inst_assoc in hty. + rewrite Upn_eq. + eapply meta_conv; eauto. + eapply inst_ext. + rewrite (shift_subst_consn_ge (S x)); len; try lia. + rewrite subst_compose_assoc. + now replace (S x - #|Δ|) with (S (x - #|Δ|)) by lia. + * intros n hnth hn [= ->]. + eapply meta_conv_all. + 2:reflexivity. + 2:{ rewrite Upn_subst_consn_ge; try lia. rewrite compose_ids_l. + instantiate (1 := tRel (x - #|s|)). + rewrite /shiftk. lia_f_equal. } + 2:{ econstructor; eauto. } + eapply meta_conv. + { econstructor; tas. + rewrite nth_error_app_context_ge; len; try lia. + rewrite H. erewrite <- hnth. lia_f_equal. } + rewrite lift0_inst. + rewrite Upn_eq. + rewrite shift_subst_consn_ge; len; try lia. + rewrite subst_consn_compose shift_subst_consn_ge; len; try lia. + rewrite H. rewrite shiftk_compose. lia_f_equal. + } +Qed. + +Lemma All_local_env_inst {cf} {Σ} {wfΣ : wf Σ} {Γ0 Γ' Δ s} : + All_local_env + (lift_typing + (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + forall (Δ : PCUICEnvironment.context) (σ : nat -> term), + wf_local Σ Δ -> well_subst Σ Γ σ Δ -> Σ;;; Δ |- t.[σ] : T.[σ]) Σ) + (Γ0,,, Γ',,, Δ) -> + wf_local Σ Γ0 -> + subslet Σ Γ0 s Γ' -> + wf_local Σ (Γ0,,, subst_context s 0 Δ). +Proof. + intros HΓ HΓ0 sub. + rewrite subst_context_inst_context. + eapply (wf_local_app_inst _ (Γ0 ,,, Γ')); eauto. + * now eapply All_local_env_app_inv in HΓ as []. + * eapply (subslet_well_subst (Δ:=[])) in sub; + rewrite ?subst_context_nil in sub |- *. + + apply sub. + + pcuicfo. +Qed. + Theorem substitution_prop `{cf : checker_flags} : env_prop (fun Σ Γ0 t T => forall (Γ Γ' Δ : context) (s : list term) (sub : subslet Σ Γ s Γ') (eqΓ0 : Γ0 = Γ ,,, Γ' ,,, Δ), + wf_local Σ (Γ ,,, subst_context s 0 Δ) -> Σ ;;; Γ ,,, subst_context s 0 Δ |- subst s #|Δ| t : subst s #|Δ| T) - (fun Σ Γ0 _ => + (fun Σ Γ0 => forall (Γ Γ' Δ : context) (s : list term) (sub : subslet Σ Γ s Γ') (eqΓ0 : Γ0 = Γ ,,, Γ' ,,, Δ), wf_local Σ (Γ ,,, subst_context s 0 Δ)). Proof. - apply typing_ind_env; - intros Σ wfΣ Γ0 wfΓ0; intros; subst Γ0; simpl in *; try solve [econstructor; eauto]; - try specialize (X _ _ _ _ sub eq_refl). - - - - induction Δ. - + clear X. simpl in *. now apply All_local_env_app_inv in wfΓ0. - + rewrite subst_context_snoc. - depelim X; simpl; - econstructor; eauto. - * exists (tu.π1). rewrite Nat.add_0_r; now eapply t0. - * exists (tu.π1). rewrite Nat.add_0_r; now eapply t1. - * rewrite Nat.add_0_r; now eapply t0. - - - elim (leb_spec_Set); intros Hn. - + elim nth_error_spec. - * intros x Heq Hlt. - pose proof (subslet_length sub). - rewrite -> nth_error_app_context_ge in H by lia. - rewrite -> nth_error_app_context_lt in H by lia. - eapply subslet_nth_error in Heq; eauto. - destruct decl_body; - cbn -[skipn] in Heq. - - -- intuition. subst x. - eapply refine_type. - ++ eapply (weakening _ _ (subst_context s 0 Δ)) in b; eauto with wf. - rewrite subst_context_length in b. eapply b. - ++ rewrite -> commut_lift_subst_rec by lia. - rewrite <- (firstn_skipn (S (n - #|Δ|)) s) at 2. - rewrite -> subst_app_decomp. f_equal. - replace (S n) with ((S n - #|Δ|) + #|Δ|) by lia. - assert (eq:#|(map (lift0 #|skipn (S (n - #|Δ|)) s|) (firstn (S (n - #|Δ|)) s))| = S n - #|Δ|). - { rewrite map_length. rewrite -> firstn_length by lia. lia. } - rewrite <- eq. rewrite -> simpl_subst_rec; auto; try lia. - - -- eapply refine_type. - ++ eapply (weakening _ _ (subst_context s 0 Δ)) in Heq; eauto with wf. - rewrite subst_context_length in Heq. eapply Heq. - ++ rewrite -> commut_lift_subst_rec by lia. - rewrite <- (firstn_skipn (S (n - #|Δ|)) s) at 2. - rewrite -> subst_app_decomp. f_equal. - replace (S n) with ((S n - #|Δ|) + #|Δ|) by lia. - assert (eq:#|(map (lift0 #|skipn (S (n - #|Δ|)) s|) (firstn (S (n - #|Δ|)) s))| = S n - #|Δ|). - { rewrite map_length. rewrite -> firstn_length by lia. lia. } - rewrite <- eq. rewrite -> simpl_subst_rec; auto; try lia. - - * intros Hs. - pose proof (subslet_length sub). - rewrite H0 in Hs. - assert (S n = #|s| + (S (n - #|s|))) by lia. - rewrite H1. rewrite simpl_subst; auto; try lia. - constructor; auto. - rewrite -> nth_error_app_context_ge; try lia; rewrite -> subst_context_length. - 2: lia. - rewrite -> 2!nth_error_app_context_ge in H by lia. - rewrite <- H. f_equal. lia. - - + eapply subslet_nth_error_lt in sub; eauto. - rewrite H in sub. simpl in sub. - eapply refine_type. - * constructor; eauto. - * rewrite <- map_decl_type. - rewrite -> commut_lift_subst_rec by lia. - f_equal. lia. - - - econstructor; auto. - + eapply X1; eauto. - + specialize (X1 Γ Γ' Δ s sub eq_refl). - specialize (X3 Γ Γ' (Δ,, vass n t) s sub eq_refl). - now rewrite subst_context_snoc0 in X3. - - - econstructor; auto. 1: eapply X1; eauto. - specialize (X1 Γ Γ' Δ s sub eq_refl). - specialize (X3 Γ Γ' (Δ,, vass n t) s sub eq_refl). - now rewrite subst_context_snoc0 in X3. - - - specialize (X1 Γ Γ' Δ s sub eq_refl). - specialize (X3 Γ Γ' Δ s sub eq_refl). - specialize (X5 Γ Γ' (Δ,, vdef n b b_ty) s sub eq_refl). - rewrite subst_context_snoc0 in X5. - econstructor; eauto. - - - specialize (X3 _ _ _ s0 sub eq_refl). - eapply refine_type. 1: econstructor; eauto. - unfold subst1. rewrite -> distr_subst. simpl. reflexivity. - - - eapply refine_type. 1: constructor; eauto. - rewrite !map_cst_type. eapply subst_declared_constant in H as ->; eauto. - - - eapply refine_type. 1: econstructor; eauto. - eapply on_declared_inductive in isdecl as [on_mind on_ind]; auto. - apply onArity in on_ind as [s' Hindty]. - apply typecheck_closed in Hindty as [_ Hindty]; eauto. symmetry. - move/andb_and/proj1: Hindty. rewrite -(closedn_subst_instance_constr _ _ u) => Hty. - apply: (subst_closedn s #|Δ|); auto with wf. - eapply closed_upwards. 1: eauto. simpl; lia. - - - eapply refine_type. 1: econstructor; eauto. - symmetry. - destruct (on_declared_constructor wfΣ isdecl) as [? [cs [? onc]]]. - eapply on_constructor_closed in onc as clty; auto. - unfold type_of_constructor. - apply subst_closedn; eauto. eapply closed_upwards; eauto. lia. - - - rewrite subst_mkApps map_app map_skipn. - specialize (X2 Γ Γ' Δ s sub eq_refl). - specialize (X4 Γ Γ' Δ s sub eq_refl). - assert (Hclos: closed_ctx (ind_params mdecl)). { - destruct isdecl as [Hmdecl Hidecl]. - eapply on_declared_minductive in Hmdecl; eauto. - eapply onParams in Hmdecl. - eapply closed_wf_local in Hmdecl; eauto. } - assert (Hclos': closed (ind_type idecl)). { - eapply on_declared_inductive in isdecl; eauto. - destruct isdecl as [_ oind]. clear -oind wfΣ. - apply onArity in oind; destruct oind as [s HH]; cbn in *. - apply typecheck_closed in HH; eauto. - apply snd in HH. apply andb_and in HH; apply HH. } - simpl. econstructor. all: eauto. - + eapply subst_build_case_predicate_type in H0; tea. - * simpl in *. subst params. rewrite firstn_map. - etransitivity; [|eapply H0; eauto]. f_equal. - now erewrite subst_declared_inductive. - * now rewrite closedn_subst_instance_context. - + now rewrite !subst_mkApps in X4. - + simpl. - destruct (on_declared_inductive wfΣ isdecl) as [oind obod]. - pose obod.(onConstructors) as onc. - eapply (subst_build_branches_type s #|Δ|) in H3; eauto. - * subst params. rewrite firstn_map. exact H3. - * now rewrite closedn_subst_instance_context. - + solve_all. - destruct b0 as [s' [Hs IH]]; eexists; eauto. - - - specialize (X2 Γ Γ' Δ s sub eq_refl). - eapply refine_type. - + econstructor. - * eauto. - * rewrite subst_mkApps in X2. eauto. - * rewrite map_length; eauto. - + rewrite <- (Nat.add_0_l #|Δ|). - erewrite distr_subst_rec. simpl. - rewrite map_rev. subst ty. - f_equal. - eapply declared_projection_closed in isdecl; auto. - symmetry; apply subst_closedn; eauto. - rewrite List.rev_length H. rewrite closedn_subst_instance_constr. - eapply closed_upwards; eauto. lia. - - - rewrite -> (map_dtype _ (subst s (#|mfix| + #|Δ|))). - eapply type_Fix; auto. - * eapply fix_guard_subst ; eauto. - * now rewrite -> nth_error_map, H0. - * eapply All_map. - eapply (All_impl X0); simpl. - intros x [u [Hs Hs']]; exists u. - now specialize (Hs' _ _ _ _ sub eq_refl). - * eapply All_map. - eapply (All_impl X1); simpl. - intros x [Hb IH]. - rewrite subst_fix_context. - specialize (IH Γ Γ' (Δ ,,, (fix_context mfix)) _ sub). - rewrite app_context_assoc in IH. specialize (IH eq_refl). - rewrite subst_context_app Nat.add_0_r app_context_assoc in IH. - rewrite app_context_length fix_context_length in IH. - rewrite subst_context_length fix_context_length. - rewrite commut_lift_subst_rec; try lia. now rewrite (Nat.add_comm #|Δ|). - * move: H1. - rewrite /wf_fixpoint. - pose proof (substitution_check_one_fix s #|Δ| mfix). - destruct map_option_out eqn:Heq => //. - specialize (H1 _ eq_refl). - rewrite map_map_compose. now rewrite H1. - - - rewrite -> (map_dtype _ (subst s (#|mfix| + #|Δ|))). - eapply type_CoFix; auto. - * eapply cofix_guard_subst; eauto. - * now rewrite -> nth_error_map, H0. - * eapply All_map. - eapply (All_impl X0); simpl. - intros x [u [Hs Hs']]; exists u. - now specialize (Hs' _ _ _ _ sub eq_refl). - * eapply All_map. - eapply (All_impl X1); simpl. - intros x [Hb IH]. - rewrite subst_fix_context. - specialize (IH Γ Γ' (Δ ,,, (fix_context mfix)) _ sub). - rewrite app_context_assoc in IH. specialize (IH eq_refl). - rewrite subst_context_app Nat.add_0_r app_context_assoc in IH. - rewrite app_context_length fix_context_length in IH. - rewrite subst_context_length fix_context_length. - rewrite commut_lift_subst_rec; try lia. now rewrite (Nat.add_comm #|Δ|). - * move: H1. - rewrite /wf_cofixpoint. - pose proof (substitution_check_one_cofix s #|Δ| mfix). - destruct map_option_out eqn:Heq => //. - specialize (H1 _ eq_refl). - rewrite map_map_compose. now rewrite H1. - - - econstructor; eauto. - eapply substitution_cumul; eauto. + intros Σ wfΣ Γ t T HT. + pose proof (type_inst Σ wfΣ Γ t T HT) as [HΣ [HΓ HTy]]. + intuition auto. + 3:{ + subst Γ. + rewrite !subst_inst. eapply HTy => //. + eapply subslet_well_subst; eauto. } + 2:{ subst Γ. + eapply typing_wf_local in HT. + eapply wf_local_app_inv in HT as [HΓ0 _]. + eapply wf_local_app_inv in HΓ0 as [HΓ0 _]. + eapply All_local_env_inst; eauto. } + unshelve eapply on_wf_global_env_impl ; tea. + clear. intros * HΣ HP HQ. + apply lift_typing_impl. clear -HΣ HP. + intros. subst Γ. + rewrite !subst_inst. eapply X => //. + now unshelve eapply subslet_well_subst. Qed. Corollary substitution `{cf : checker_flags} (Σ : global_env_ext) Γ Γ' s Δ (t : term) T : @@ -2695,6 +1931,8 @@ Corollary substitution `{cf : checker_flags} (Σ : global_env_ext) Γ Γ' s Δ ( Proof. intros HΣ Hs Ht. eapply (env_prop_typing _ _ substitution_prop); trea. + eapply (env_prop_wf_local _ _ substitution_prop); trea. + now eapply typing_wf_local in Ht. Qed. Corollary substitution_wf_local `{cf : checker_flags} (Σ : global_env_ext) Γ Γ' s Δ : @@ -2742,79 +1980,3 @@ Proof. simpl in thm. specialize (thm Ht). now rewrite !subst_empty in thm. Qed. - -(* TODO Move to liftsubst *) - -Lemma subst_context_comm s s' Γ : - subst_context s 0 (subst_context s' 0 Γ) = - subst_context (map (subst s 0) s' ++ s) 0 Γ. -Proof. - intros. - rewrite !subst_context_alt !mapi_compose. - apply mapi_ext => i x. - destruct x as [na [b|] ty] => //. - - rewrite /subst_decl /map_decl /=; f_equal. - + rewrite !mapi_length. f_equal. rewrite {2}Nat.add_0_r. - rewrite subst_app_simpl. - rewrite distr_subst_rec. rewrite Nat.add_0_r; f_equal; try lia. - rewrite map_length. f_equal; lia. - + rewrite mapi_length. - rewrite subst_app_simpl. - rewrite {2}Nat.add_0_r. - rewrite distr_subst_rec. rewrite Nat.add_0_r; f_equal; try lia. - rewrite map_length. f_equal; lia. - - rewrite /subst_decl /map_decl /=; f_equal. - rewrite !mapi_length. rewrite {2}Nat.add_0_r. - rewrite subst_app_simpl. - rewrite distr_subst_rec. rewrite Nat.add_0_r; f_equal; try lia. - rewrite map_length. f_equal. lia. -Qed. - -Lemma subst_app_context s s' Γ : subst_context (s ++ s') 0 Γ = subst_context s 0 (subst_context s' #|s| Γ). -Proof. - induction Γ; simpl; auto. - rewrite !subst_context_snoc /= /subst_decl /map_decl /=. simpl. - rewrite IHΓ. f_equal. f_equal. - - destruct a as [na [b|] ty]; simpl; auto. - f_equal. rewrite subst_context_length Nat.add_0_r. - now rewrite subst_app_simpl. - - rewrite subst_context_length Nat.add_0_r. - now rewrite subst_app_simpl. -Qed. - -Lemma context_assumptions_subst s n Γ : - context_assumptions (subst_context s n Γ) = context_assumptions Γ. -Proof. apply context_assumptions_fold. Qed. -Hint Rewrite context_assumptions_subst : pcuic. - - -Lemma subst_app_simpl' (l l' : list term) (k : nat) (t : term) n : - n = #|l| -> - subst (l ++ l') k t = subst l k (subst l' (k + n) t). -Proof. intros ->; apply subst_app_simpl. Qed. - - -Lemma subst_app_context' (s s' : list term) (Γ : context) n : - n = #|s| -> - subst_context (s ++ s') 0 Γ = subst_context s 0 (subst_context s' n Γ). -Proof. - intros ->; apply subst_app_context. -Qed. - -Lemma map_subst_app_simpl l l' k (ts : list term) : - map (subst l k ∘ subst l' (k + #|l|)) ts = - map (subst (l ++ l') k) ts. -Proof. - eapply map_ext. intros. - now rewrite subst_app_simpl. -Qed. - -Lemma simpl_map_lift x n k : - map (lift0 n ∘ lift0 k) x = - map (lift k n ∘ lift0 n) x. -Proof. - apply map_ext => t. - rewrite simpl_lift => //; try lia. - rewrite simpl_lift; try lia. - now rewrite Nat.add_comm. -Qed. diff --git a/pcuic/theories/PCUICToTemplate.v b/pcuic/theories/PCUICToTemplate.v index add6facdd..3737407d6 100644 --- a/pcuic/theories/PCUICToTemplate.v +++ b/pcuic/theories/PCUICToTemplate.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Int63 FloatOps FloatAxioms. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases. Set Warnings "-notation-overridden". From MetaCoq.Template Require Import config utils AstUtils BasicAst Ast. Set Warnings "+notation-overridden". @@ -10,13 +10,23 @@ Definition uint63_from_model (i : uint63_model) : Int63.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 (uint63_from_model i) | primFloatModel f => Ast.tFloat (float64_from_model f) end. +Definition trans_predicate (t : PCUICAst.predicate Ast.term) : predicate Ast.term := + {| pparams := t.(PCUICAst.pparams); + puinst := t.(PCUICAst.puinst); + pcontext := forget_types t.(PCUICAst.pcontext); + preturn := t.(PCUICAst.preturn) |}. + +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 @@ -31,8 +41,9 @@ Fixpoint trans (t : PCUICAst.term) : Ast.term := | PCUICAst.tProd na A B => tProd na (trans A) (trans B) | PCUICAst.tLetIn na b t b' => tLetIn na (trans b) (trans t) (trans b') | PCUICAst.tCase ind p c brs => - let brs' := List.map (on_snd trans) brs in - tCase (ind, Relevant) (trans p) (trans c) brs' + let p' := PCUICAst.map_predicate id trans trans p in + let brs' := List.map (PCUICAst.map_branch trans) brs in + tCase ind (trans_predicate p') (trans c) (map trans_branch brs') | PCUICAst.tProj p c => tProj p (trans c) | PCUICAst.tFix mfix idx => let mfix' := List.map (map_def trans trans) mfix in @@ -43,47 +54,53 @@ Fixpoint trans (t : PCUICAst.term) : Ast.term := | PCUICAst.tPrim i => trans_prim i end. -Definition trans_decl (d : PCUICAst.context_decl) := - let 'PCUICAst.mkdecl na b t := d in +Definition trans_decl (d : PCUICAst.PCUICEnvironment.context_decl) := + let 'mkdecl na b t := d in {| decl_name := na; decl_body := option_map trans b; decl_type := trans t |}. Definition trans_local Γ := List.map trans_decl Γ. -Definition trans_ctor : (ident × PCUICAst.term) × nat -> (ident × term) × nat - := fun '(x, y, z) => (x, trans y, z). - -Definition trans_one_ind_body (d : PCUICAst.one_inductive_body) := - {| ind_name := d.(PCUICAst.ind_name); - ind_relevance := d.(PCUICAst.ind_relevance); - ind_type := trans d.(PCUICAst.ind_type); - ind_kelim := d.(PCUICAst.ind_kelim); - ind_ctors := List.map trans_ctor d.(PCUICAst.ind_ctors); - ind_projs := List.map (fun '(x, y) => (x, trans y)) d.(PCUICAst.ind_projs) |}. +Definition trans_constructor_body (d : PCUICEnvironment.constructor_body) := + {| cstr_name := d.(PCUICEnvironment.cstr_name); + cstr_args := trans_local d.(PCUICEnvironment.cstr_args); + cstr_indices := map trans d.(PCUICEnvironment.cstr_indices); + cstr_type := trans d.(PCUICEnvironment.cstr_type); + cstr_arity := d.(PCUICEnvironment.cstr_arity) |}. + +Definition trans_one_ind_body (d : PCUICEnvironment.one_inductive_body) := + {| ind_name := d.(PCUICEnvironment.ind_name); + ind_relevance := d.(PCUICEnvironment.ind_relevance); + ind_indices := trans_local d.(PCUICEnvironment.ind_indices); + ind_type := trans d.(PCUICEnvironment.ind_type); + ind_sort := d.(PCUICEnvironment.ind_sort); + ind_kelim := d.(PCUICEnvironment.ind_kelim); + ind_ctors := List.map trans_constructor_body d.(PCUICEnvironment.ind_ctors); + ind_projs := List.map (fun '(x, y) => (x, trans y)) d.(PCUICEnvironment.ind_projs) |}. Definition trans_constant_body bd := - {| cst_type := trans bd.(PCUICAst.cst_type); cst_body := option_map trans bd.(PCUICAst.cst_body); - cst_universes := bd.(PCUICAst.cst_universes) |}. + {| cst_type := trans bd.(PCUICEnvironment.cst_type); cst_body := option_map trans bd.(PCUICEnvironment.cst_body); + cst_universes := bd.(PCUICEnvironment.cst_universes) |}. Definition trans_minductive_body md := - {| ind_finite := md.(PCUICAst.ind_finite); - ind_npars := md.(PCUICAst.ind_npars); - ind_params := trans_local md.(PCUICAst.ind_params); - ind_bodies := map trans_one_ind_body md.(PCUICAst.ind_bodies); - ind_universes := md.(PCUICAst.ind_universes); - ind_variance := md.(PCUICAst.ind_variance) + {| ind_finite := md.(PCUICEnvironment.ind_finite); + ind_npars := md.(PCUICEnvironment.ind_npars); + ind_params := trans_local md.(PCUICEnvironment.ind_params); + ind_bodies := map trans_one_ind_body md.(PCUICEnvironment.ind_bodies); + ind_universes := md.(PCUICEnvironment.ind_universes); + ind_variance := md.(PCUICEnvironment.ind_variance) |}. -Definition trans_global_decl (d : PCUICAst.global_decl) := +Definition trans_global_decl (d : PCUICEnvironment.global_decl) := match d with - | PCUICAst.ConstantDecl bd => ConstantDecl (trans_constant_body bd) - | PCUICAst.InductiveDecl bd => InductiveDecl (trans_minductive_body bd) + | PCUICEnvironment.ConstantDecl bd => ConstantDecl (trans_constant_body bd) + | PCUICEnvironment.InductiveDecl bd => InductiveDecl (trans_minductive_body bd) end. -Definition trans_global_decls (d : PCUICAst.global_env) : global_env := +Definition trans_global_decls (d : PCUICEnvironment.global_env) : global_env := List.map (on_snd trans_global_decl) d. -Definition trans_global (Σ : PCUICAst.global_env_ext) : global_env_ext := +Definition trans_global (Σ : PCUICEnvironment.global_env_ext) : global_env_ext := (trans_global_decls (fst Σ), snd Σ). diff --git a/pcuic/theories/PCUICToTemplateCorrectness.v b/pcuic/theories/PCUICToTemplateCorrectness.v index cba3e00fe..2c6e0e077 100644 --- a/pcuic/theories/PCUICToTemplateCorrectness.v +++ b/pcuic/theories/PCUICToTemplateCorrectness.v @@ -25,6 +25,7 @@ Require Import Equations.Prop.DepElim. (** Source = PCUIC, Target = Coq *) Module S := PCUICAst. +Module SE := PCUICEnvironment. Module ST := PCUICTyping. Module T := Template.Ast. Module TT := Template.Typing. @@ -45,7 +46,7 @@ Proof. Qed. Lemma trans_lift (t : S.term) n k: - trans (SL.lift n k t) = TL.lift n k (trans t). + trans (S.lift n k t) = T.lift n k (trans t). Proof. revert k. induction t using PCUICInduction.term_forall_list_ind; simpl; intros; try congruence. - f_equal. rewrite !map_map_compose. solve_all. @@ -54,7 +55,7 @@ Proof. rewrite <- mapOne. rewrite <- TL.lift_mkApps. f_equal. - - f_equal; auto. red in X. solve_list. + - f_equal; auto. red in X. todo "case". solve_list. todo "case". - f_equal; auto; red in X; solve_list. - f_equal; auto; red in X; solve_list. - destruct p as [? []]; eauto. @@ -73,22 +74,22 @@ Proof. Defined. Lemma trans_global_ext_levels Σ: -ST.global_ext_levels Σ = TT.global_ext_levels (trans_global Σ). + S.global_ext_levels Σ = TT.global_ext_levels (trans_global Σ). Proof. - unfold TT.global_ext_levels, ST.global_ext_levels. + unfold TT.global_ext_levels, global_ext_levels. destruct Σ. cbn [trans_global fst snd]. f_equal. induction g. - reflexivity. - - unfold ST.global_levels in IHg. + - unfold S.global_levels in IHg. cbn. rewrite IHg. f_equal. destruct a. cbn. unfold TT.monomorphic_levels_decl, TT.monomorphic_udecl_decl, TT.on_udecl_decl. - unfold ST.monomorphic_levels_decl, ST.monomorphic_udecl_decl, ST.on_udecl_decl. + unfold S.monomorphic_levels_decl, S.monomorphic_udecl_decl, S.on_udecl_decl. destruct g0. + cbn. destruct c. @@ -99,10 +100,10 @@ Proof. Qed. Lemma trans_global_ext_constraints Σ : - ST.global_ext_constraints Σ = TT.global_ext_constraints (trans_global Σ). + S.global_ext_constraints Σ = TT.global_ext_constraints (trans_global Σ). Proof. destruct Σ. - unfold ST.global_ext_constraints, TT.global_ext_constraints. simpl. + unfold S.global_ext_constraints, TT.global_ext_constraints. simpl. f_equal. clear u. induction g. - reflexivity. @@ -111,7 +112,7 @@ Proof. Qed. Lemma trans_mem_level_set l Σ: - LevelSet.mem l (ST.global_ext_levels Σ) -> + LevelSet.mem l (S.global_ext_levels Σ) -> LevelSet.mem l (TT.global_ext_levels (trans_global Σ)). Proof. intros. @@ -120,7 +121,7 @@ Proof. Qed. Lemma trans_in_level_set l Σ: - LevelSet.In l (ST.global_ext_levels Σ) -> + LevelSet.In l (S.global_ext_levels Σ) -> LevelSet.In l (TT.global_ext_levels (trans_global Σ)). Proof. intros. @@ -129,7 +130,7 @@ Proof. Qed. Lemma trans_lookup Σ cst : - Ast.lookup_env (trans_global_decls Σ) cst = option_map trans_global_decl (S.lookup_env Σ cst). + Ast.Env.lookup_env (trans_global_decls Σ) cst = option_map trans_global_decl (SE.lookup_env Σ cst). Proof. cbn in *. induction Σ. @@ -141,18 +142,18 @@ Proof. Qed. Lemma trans_declared_constant Σ cst decl: - ST.declared_constant Σ cst decl -> + S.declared_constant Σ cst decl -> TT.declared_constant (trans_global_decls Σ) cst (trans_constant_body decl). Proof. unfold TT.declared_constant. rewrite trans_lookup. - unfold ST.declared_constant. + unfold S.declared_constant. intros ->. reflexivity. Qed. Lemma trans_constraintSet_in x Σ: - ConstraintSet.In x (ST.global_ext_constraints Σ) -> + ConstraintSet.In x (S.global_ext_constraints Σ) -> ConstraintSet.In x (TT.global_ext_constraints (trans_global Σ)). Proof. rewrite trans_global_ext_constraints. @@ -160,12 +161,12 @@ Proof. Qed. Lemma trans_consistent_instance_ext {cf} Σ decl u: - ST.consistent_instance_ext Σ decl u -> + S.consistent_instance_ext Σ decl u -> TT.consistent_instance_ext (trans_global Σ) decl u. Proof. intros H. - unfold consistent_instance_ext, ST.consistent_instance_ext in *. - unfold consistent_instance, ST.consistent_instance in *. + unfold consistent_instance_ext, S.consistent_instance_ext in *. + unfold consistent_instance, S.consistent_instance in *. destruct decl;trivial. destruct H as (?&?&?). repeat split;trivial. @@ -186,13 +187,13 @@ Proof. now apply trans_constraintSet_in. Qed. -Lemma trans_declared_inductive Σ mdecl ind idecl: - ST.declared_inductive Σ mdecl ind idecl -> - TT.declared_inductive (trans_global_decls Σ) (trans_minductive_body mdecl) ind (trans_one_ind_body idecl). +Lemma trans_declared_inductive Σ ind mdecl idecl: + S.declared_inductive Σ ind mdecl idecl -> + TT.declared_inductive (trans_global_decls Σ) ind (trans_minductive_body mdecl) (trans_one_ind_body idecl). Proof. intros []. split. - - unfold TT.declared_minductive, ST.declared_minductive in *. + - unfold TT.declared_minductive, S.declared_minductive in *. now rewrite trans_lookup H. - now apply map_nth_error. Qed. @@ -211,16 +212,16 @@ Proof. Qed. Lemma trans_decl_type decl: - trans (PCUICAst.decl_type decl) = + trans (decl_type decl) = decl_type (trans_decl decl). -Proof. +Proof. destruct decl. reflexivity. Qed. Lemma trans_subst xs k t: - trans (SL.subst xs k t) = - TL.subst (map trans xs) k (trans t). + trans (S.subst xs k t) = + T.subst (map trans xs) k (trans t). Proof. induction t in k |- * using PCUICInduction.term_forall_list_ind. all: cbn;try congruence. @@ -242,7 +243,8 @@ Proof. rewrite map_app. cbn. reflexivity. - - f_equal;trivial. + - todo "case". + (* f_equal;trivial. do 2 rewrite map_map. apply All_map_eq. induction X;trivial. @@ -251,7 +253,7 @@ Proof. unfold on_snd;cbn. rewrite p0. reflexivity. - + apply IHX. + + apply IHX. *) - f_equal. rewrite map_length. remember (#|m|+k) as l. @@ -279,19 +281,18 @@ Proof. - destruct p as [? []]; eauto. Qed. - Lemma trans_subst10 u B: - trans (SL.subst1 u 0 B) = - TL.subst10 (trans u) (trans B). + trans (S.subst1 u 0 B) = + T.subst10 (trans u) (trans B). Proof. - unfold SL.subst1. + unfold S.subst1. rewrite trans_subst. reflexivity. Qed. -Lemma trans_subst_instance_constr u t: - trans (PCUICUnivSubst.subst_instance_constr u t) = - Template.UnivSubst.subst_instance_constr u (trans t). +Lemma trans_subst_instance u t: + 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. @@ -300,24 +301,26 @@ Proof. apply X. - rewrite IHt1 IHt2. do 2 rewrite AstUtils.mkAppMkApps. - rewrite subst_instance_constr_mkApps. + rewrite subst_instance_mkApps. cbn. reflexivity. - - f_equal. - + apply IHt1. - + apply IHt2. - + do 2 rewrite map_map. - unfold tCaseBrsProp in X. + - red in X, X0. + f_equal; solve_all. + + todo "case". + (* + apply IHt1. *) + (*+ apply IHt2. *) + + rewrite !map_map. apply All_map_eq. - induction X. + induction X0. * constructor. * constructor;trivial. destruct x. cbn. unfold on_snd. cbn. cbn in p0. - rewrite p0. - reflexivity. + todo "case". + (* rewrite p0. + reflexivity. *) - f_equal. unfold tFixProp in X. induction X;trivial. @@ -340,14 +343,14 @@ Proof. Qed. Lemma trans_cst_type decl: - trans (PCUICAst.cst_type decl) = + trans (SE.cst_type decl) = cst_type (trans_constant_body decl). Proof. reflexivity. Qed. Lemma trans_ind_type idecl: - trans (PCUICAst.ind_type idecl) = + trans (SE.ind_type idecl) = ind_type (trans_one_ind_body idecl). Proof. reflexivity. @@ -357,7 +360,7 @@ 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) - (trans_ctor cdecl) + (trans_constructor_body cdecl) (ind,i) u. Proof. @@ -366,7 +369,7 @@ Proof. unfold TT.type_of_constructor. f_equal. - cbn [fst]. - rewrite ST.inds_spec. + rewrite PCUICCases.inds_spec. rewrite TT.inds_spec. rewrite map_rev. rewrite map_mapi. @@ -374,15 +377,13 @@ Proof. cbn. f_equal. remember 0 as k. - induction ind_bodies in k |- *. + induction ind_bodies0 in k |- *. + reflexivity. + cbn. f_equal. - apply IHind_bodies. - - rewrite trans_subst_instance_constr. + apply IHind_bodies0. + - rewrite trans_subst_instance. f_equal. - destruct cdecl as [[? ?] ?]. - reflexivity. Qed. Lemma trans_dtype decl: @@ -401,9 +402,9 @@ Proof. reflexivity. Qed. -Lemma trans_declared_projection Σ mdecl idecl p pdecl : - ST.declared_projection Σ.1 mdecl idecl p pdecl -> - TT.declared_projection (trans_global Σ).1 (trans_minductive_body mdecl) (trans_one_ind_body idecl) p (on_snd trans pdecl). +Lemma trans_declared_projection Σ p mdecl idecl pdecl : + S.declared_projection Σ.1 p mdecl idecl pdecl -> + TT.declared_projection (trans_global Σ).1 p (trans_minductive_body mdecl) (trans_one_ind_body idecl) (on_snd trans pdecl). Proof. intros (?&?&?). split;[|split]. @@ -431,7 +432,7 @@ Proof. repeat split;eassumption. Qed. -Lemma trans_instantiate_params params pars ty: +(* Lemma trans_instantiate_params params pars ty: option_map trans (ST.instantiate_params params pars ty) = @@ -466,12 +467,12 @@ Qed. Lemma trans_instantiate_params' u mdecl args npar x ty : ST.instantiate_params - (PCUICUnivSubst.subst_instance_context u (PCUICAst.ind_params mdecl)) + (PCUICUnivSubst.subst_instance u (PCUICAst.ind_params mdecl)) (firstn npar args) ty = Some x -> TT.instantiate_params - (subst_instance_context u + (subst_instance u (trans_local (PCUICAst.ind_params mdecl))) (firstn npar (map trans args)) (trans ty) = @@ -481,10 +482,10 @@ Proof. rewrite firstn_map. match goal with |- TT.instantiate_params ?A _ _ = _ => - replace A with (trans_local (PCUICUnivSubst.subst_instance_context u (PCUICAst.ind_params mdecl))) + replace A with (trans_local (PCUICUnivSubst.subst_instance u (PCUICAst.ind_params mdecl))) end. 2: { - unfold PCUICUnivSubst.subst_instance_context, trans_local. + unfold PCUICUnivSubst.subst_instance, trans_local. unfold PCUICAst.map_context. rewrite map_map. destruct mdecl. @@ -497,23 +498,23 @@ Proof. do 2 rewrite option_map_two. f_equal. + destruct decl_body;cbn;trivial. - now rewrite trans_subst_instance_constr. - + now rewrite trans_subst_instance_constr. + now rewrite trans_subst_instance. + + now rewrite trans_subst_instance. - apply IHind_params. } rewrite <- trans_instantiate_params. rewrite H. reflexivity. Qed. - +*) Lemma trans_destr_arity x: AstUtils.destArity [] (trans x) = option_map (fun '(xs,u) => (map trans_decl xs,u)) (PCUICAstUtils.destArity [] x). Proof. - remember (@nil PCUICAst.context_decl) as xs. + remember (@nil SE.context_decl) as xs. replace (@nil context_decl) with (map trans_decl xs) by (now subst). clear Heqxs. - induction x in xs |- *;cbn;trivial;unfold snoc, PCUICAst.snoc. + induction x in xs |- *;cbn;trivial;unfold snoc, SE.snoc. - rewrite <- IHx2. reflexivity. - rewrite <- IHx3. @@ -523,14 +524,14 @@ Proof. Qed. Lemma trans_mkProd_or_LetIn a t: - trans (PCUICAst.mkProd_or_LetIn a t) = + trans (SE.mkProd_or_LetIn a t) = mkProd_or_LetIn (trans_decl a) (trans t). Proof. destruct a as [? [] ?];cbn;trivial. Qed. Lemma trans_it_mkProd_or_LetIn xs t: - trans (PCUICAst.it_mkProd_or_LetIn xs t) = + trans (SE.it_mkProd_or_LetIn xs t) = it_mkProd_or_LetIn (map trans_decl xs) (trans t). Proof. induction xs in t |- *;simpl;trivial. @@ -546,15 +547,16 @@ Proof. simpl in *. congruence. Qed. -Lemma trans_iota_red pars c args brs : - trans (iota_red pars c args brs) = - TT.iota_red pars c (List.map trans args) (List.map (on_snd trans) brs). +(* todo*) +(* Lemma trans_iota_red pars c args brs : + trans (iota_red pars args brs) = + TT.iota_red pars c (List.map trans args) (List.map trans_branch brs]). Proof. unfold iota_red, TT.iota_red. rewrite trans_mkApps. f_equal. induction brs in c |- *; simpl; destruct c; trivial. now rewrite map_skipn. -Qed. +Qed. *) Lemma trans_isLambda t : T.isLambda (trans t) = S.isLambda t. @@ -630,17 +632,18 @@ Proof. induction t using term_forall_list_ind; simpl; try constructor; auto; solve_all. now eapply wf_mkApp. + 1-3:todo "case". destruct p as [? []]; constructor. Qed. Hint Resolve trans_wf : wf. Lemma trans_fix_context mfix: - map trans_decl (PCUICLiftSubst.fix_context mfix) = + map trans_decl (SE.fix_context mfix) = TT.fix_context (map (map_def trans trans) mfix). Proof. unfold trans_local. destruct mfix;trivial. - unfold TT.fix_context, PCUICLiftSubst.fix_context. + unfold TT.fix_context, SE.fix_context. rewrite map_rev map_mapi. cbn. f_equal. 2: { @@ -675,8 +678,8 @@ Proof. destruct nth_error eqn:Heq => //. simpl in H. noconf H. simpl. destruct c; noconf H => //. - - rewrite trans_mkApps; eauto with wf; simpl. - erewrite trans_iota_red; eauto. repeat constructor. + - todo "case". (* - rewrite trans_mkApps; eauto with wf; simpl. + erewrite trans_iota_red; eauto. repeat constructor. *) - simpl. rewrite !trans_mkApps /=. unfold is_constructor in H0. @@ -699,17 +702,20 @@ Proof. apply trans_unfold_cofix in H; eauto with wf. eapply TT.red_cofix_proj; eauto. - - rewrite trans_subst_instance_constr. econstructor. + - rewrite trans_subst_instance. econstructor. apply (trans_declared_constant _ c decl H). - destruct decl. now simpl in *; subst cst_body. + destruct decl. now simpl in *; subst cst_body0. - rewrite trans_mkApps; eauto with wf. simpl. constructor. now rewrite nth_error_map H. - constructor. solve_all. apply OnOne2_map. - solve_all. red. simpl in *. - intuition eauto. + solve_all. + + - todo "case". + - todo "case". + - todo "case". - eapply (red1_mkApps_l _ _ _ _ [_]); auto with wf. - eapply (red1_mkApps_r _ _ _ [_] [_]); auto with wf. @@ -737,9 +743,9 @@ Proof. now rewrite -trans_fix_context. Qed. -Lemma context_assumptions_map ctx : Ast.context_assumptions (map trans_decl ctx) = PCUICAst.context_assumptions ctx. +Lemma context_assumptions_map ctx : Ast.Env.context_assumptions (map trans_decl ctx) = SE.context_assumptions ctx. Proof. - induction ctx as [|[na [b|] ty] ctx]; simpl; auto. + induction ctx as [|[na [b|] ty] ctx]; simpl; auto; lia. Qed. Lemma trans_R_global_instance Σ Re Rle gref napp u u' : @@ -749,24 +755,22 @@ Proof. unfold PCUICEquality.R_global_instance, PCUICEquality.global_variance. unfold R_global_instance, global_variance. destruct gref; simpl; auto. - - unfold PCUICEquality.lookup_inductive, PCUICEquality.lookup_minductive. + - unfold S.lookup_inductive, S.lookup_minductive. unfold lookup_inductive, lookup_minductive. - rewrite trans_lookup. destruct PCUICAst.lookup_env => //; simpl. + rewrite trans_lookup. destruct SE.lookup_env => //; simpl. destruct g => /= //. rewrite nth_error_map. destruct nth_error => /= //. rewrite trans_destr_arity. destruct PCUICAstUtils.destArity as [[ctx ps]|] => /= //. now rewrite context_assumptions_map. - - unfold PCUICEquality.lookup_constructor, PCUICEquality.lookup_inductive, PCUICEquality.lookup_minductive. + - unfold S.lookup_constructor, S.lookup_inductive, S.lookup_minductive. unfold lookup_constructor, lookup_inductive, lookup_minductive. - rewrite trans_lookup. destruct PCUICAst.lookup_env => //; simpl. + rewrite trans_lookup. destruct SE.lookup_env => //; simpl. destruct g => /= //. rewrite nth_error_map. destruct nth_error => /= //. rewrite nth_error_map. destruct nth_error => /= //. - destruct p as [[id t] nargs]; simpl. - destruct Nat.leb => //. -Qed. +Qed. Lemma trans_eq_term_upto_univ {cf} : forall Σ Re Rle t u napp, @@ -787,6 +791,7 @@ Proof. all: try solve [ constructor; solve_all ]. all: try solve [ constructor; now eapply trans_R_global_instance ]. - eapply (eq_term_upto_univ_mkApps _ _ _ _ _ [_] _ [_]); simpl; eauto. + - todo "case". - destruct p as [? []]; constructor. Qed. @@ -810,8 +815,9 @@ Proof. apply trans_red1 in r; auto. Qed. -Lemma trans_build_case_predicate_type ind mdecl idecl npar args u ps pty: -ST.build_case_predicate_type ind mdecl idecl (firstn npar args) u ps = Some pty -> +(* Todo case *) +(*Lemma trans_build_case_predicate_type ind mdecl idecl npar args u ps pty: +S.build_case_predicate_type ind mdecl idecl (firstn npar args) u ps = Some pty -> TT.build_case_predicate_type ind (trans_minductive_body mdecl) (trans_one_ind_body idecl) (firstn npar (map trans args)) u ps = Some (trans pty). @@ -821,7 +827,7 @@ Proof. unfold TT.build_case_predicate_type. simpl in *. apply trans_instantiate_params' in H. - rewrite trans_subst_instance_constr in H. rewrite H. + rewrite trans_subst_instance in H. rewrite H. simpl. rewrite trans_destr_arity H0. simpl. f_equal. @@ -847,12 +853,12 @@ Proof. clear Heqxs. induction l in n, xs |- *;cbn;trivial. now destruct a as [? [] ?];rewrite <- IHl;cbn. -Qed. +Qed.*) Definition TTwf_local {cf} Σ Γ := TT.All_local_env (TT.lift_typing TT.typing Σ) Γ. Lemma trans_wf_local' {cf} : - forall (Σ : PCUICAst.global_env_ext) Γ (wfΓ : wf_local Σ Γ), + forall (Σ : SE.global_env_ext) Γ (wfΓ : wf_local Σ Γ), let P := (fun Σ0 Γ0 _ (t T : PCUICAst.term) _ => TT.typing (trans_global Σ0) (trans_local Γ0) (trans t) (trans T)) @@ -872,7 +878,7 @@ Qed. Lemma trans_wf_local_env {cf} Σ Γ : ST.All_local_env (ST.lift_typing - (fun (Σ : PCUICAst.global_env_ext) Γ b ty => + (fun (Σ : SE.global_env_ext) Γ b ty => ST.typing Σ Γ b ty × TT.typing (trans_global Σ) (trans_local Γ) (trans b) (trans ty)) Σ) Γ -> TTwf_local (trans_global Σ) (trans_local Γ). @@ -914,11 +920,11 @@ Qed. Lemma trans_mfix_All {cf} Σ Γ mfix: ST.All_local_env (ST.lift_typing - (fun (Σ : PCUICEnvironment.global_env_ext) - (Γ : PCUICEnvironment.context) (b ty : PCUICAst.term) => + (fun (Σ : SE.global_env_ext) + (Γ : SE.context) (b ty : PCUICAst.term) => ST.typing Σ Γ b ty × TT.typing (trans_global Σ) (trans_local Γ) (trans b) (trans ty)) Σ) - (PCUICAst.app_context Γ (PCUICLiftSubst.fix_context mfix)) -> + (SE.app_context Γ (SE.fix_context mfix)) -> TTwf_local (trans_global Σ) (trans_local Γ ,,, TT.fix_context (map (map_def trans trans) mfix)). Proof. @@ -926,10 +932,10 @@ Proof. rewrite <- trans_fix_context. match goal with |- TTwf_local _ ?A => - replace A with (trans_local (PCUICAst.app_context Γ (PCUICLiftSubst.fix_context mfix))) + replace A with (trans_local (SE.app_context Γ (SE.fix_context mfix))) end. 2: { - unfold trans_local, PCUICAst.app_context. + unfold trans_local, SE.app_context. now rewrite map_app. } @@ -946,31 +952,31 @@ Qed. Lemma trans_mfix_All2 {cf} Σ Γ mfix xfix: All (fun d : def PCUICAst.term => - (ST.typing Σ (PCUICAst.app_context Γ (PCUICLiftSubst.fix_context xfix)) + (ST.typing Σ (SE.app_context Γ (SE.fix_context xfix)) (dbody d) - (PCUICLiftSubst.lift0 #|PCUICLiftSubst.fix_context xfix| (dtype d))) + (S.lift0 #|SE.fix_context xfix| (dtype d))) × TT.typing (trans_global Σ) - (trans_local (PCUICAst.app_context Γ (PCUICLiftSubst.fix_context xfix))) + (trans_local (SE.app_context Γ (SE.fix_context xfix))) (trans (dbody d)) (trans - (PCUICLiftSubst.lift0 #|PCUICLiftSubst.fix_context xfix| + (S.lift0 #|SE.fix_context xfix| (dtype d)))) mfix -> All (fun d : def term => TT.typing (trans_global Σ) (trans_local Γ ,,, TT.fix_context (map (map_def trans trans) xfix)) - (dbody d) (TL.lift0 #|TT.fix_context (map (map_def trans trans) xfix)| (dtype d))) + (dbody d) (T.lift0 #|TT.fix_context (map (map_def trans trans) xfix)| (dtype d))) (map (map_def trans trans) mfix). Proof. induction 1. - constructor. - simpl; constructor. + destruct p as []. - unfold app_context, PCUICAst.app_context in *. + unfold app_context, SE.app_context in *. unfold trans_local in t0. rewrite map_app trans_fix_context in t0. rewrite trans_dbody trans_lift trans_dtype in t0. - replace(#|PCUICLiftSubst.fix_context xfix|) with + replace(#|SE.fix_context xfix|) with (#|TT.fix_context (map(map_def trans trans) xfix)|) in t0. 2:now rewrite TT.fix_context_length map_length fix_context_length. now destruct x. @@ -979,13 +985,13 @@ Qed. Lemma All_over_All {cf} Σ Γ wfΓ : ST.All_local_env_over ST.typing - (fun (Σ : PCUICAst.global_env_ext) (Γ : PCUICAst.context) + (fun (Σ : SE.global_env_ext) (Γ : SE.context) (_ : wf_local Σ Γ) (t T : PCUICAst.term) (_ : ST.typing Σ Γ t T) => TT.typing (trans_global Σ) (trans_local Γ) (trans t) (trans T)) Σ Γ wfΓ -> ST.All_local_env (ST.lift_typing - (fun (Σ0 : PCUICAst.global_env_ext) (Γ0 : PCUICEnvironment.context) + (fun (Σ0 : SE.global_env_ext) (Γ0 : SE.context) (b ty : PCUICAst.term) => ST.typing Σ0 Γ0 b ty × TT.typing (trans_global Σ0) (trans_local Γ0) (trans b) (trans ty)) Σ) Γ. @@ -1025,18 +1031,18 @@ Proof. Qed. Lemma trans_subst_context s k Γ : - trans_local (SL.subst_context s k Γ) = TL.subst_context (map trans s) k (trans_local Γ). + 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. - - rewrite SL.subst_context_snoc /=. rewrite [TL.subst_context _ _ _ ]subst_context_snoc. + - rewrite SE.subst_context_snoc /=. rewrite [T.Env.subst_context _ _ _ ]subst_context_snoc. f_equal; auto. rewrite IHΓ /snoc /subst_decl /map_decl /=; f_equal. now rewrite !trans_subst map_length. - - rewrite SL.subst_context_snoc /=. rewrite [TL.subst_context _ _ _ ]subst_context_snoc. + - rewrite SE.subst_context_snoc /=. rewrite [T.Env.subst_context _ _ _ ]subst_context_snoc. f_equal; auto. rewrite IHΓ /snoc /subst_decl /map_decl /=; f_equal. now rewrite !trans_subst map_length. Qed. -Lemma trans_smash_context Γ Δ : trans_local (smash_context Γ Δ) = TT.smash_context (trans_local Γ) (trans_local Δ). +Lemma trans_smash_context Γ Δ : trans_local (SE.smash_context Γ Δ) = T.Env.smash_context (trans_local Γ) (trans_local Δ). Proof. induction Δ in Γ |- *; simpl; auto. destruct a as [na [b|] ty] => /=. @@ -1100,26 +1106,27 @@ Proof. Qed. Lemma trans_inds ind u mdecl : - map trans (ST.inds (inductive_mind ind) u (PCUICAst.ind_bodies mdecl)) = + map trans (PCUICCases.inds (inductive_mind ind) u (SE.ind_bodies mdecl)) = TT.inds (inductive_mind ind) u (ind_bodies (trans_minductive_body mdecl)). Proof. - rewrite ST.inds_spec TT.inds_spec. + rewrite PCUICCases.inds_spec TT.inds_spec. rewrite map_rev map_mapi. simpl. f_equal. rewrite mapi_map. apply mapi_ext => n //. Qed. -Lemma trans_reln l p Γ : map trans (PCUICAst.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. now rewrite IHΓ. Qed. -Lemma trans_to_extended_list Γ n : map trans (PCUICAst.to_extended_list_k Γ n) = to_extended_list_k (trans_local Γ) n. +Lemma trans_to_extended_list Γ n : map trans (SE.to_extended_list_k Γ n) = to_extended_list_k (trans_local Γ) n. Proof. now rewrite /to_extended_list_k trans_reln. Qed. +(* Lemma trans_build_branches_type ind mdecl idecl npar args u p brtys : map_option_out (ST.build_branches_type ind mdecl idecl (firstn npar args) u p) = Some brtys -> @@ -1138,7 +1145,7 @@ Proof. apply trans_instantiate_params' in ipars. rewrite trans_subst in ipars. rewrite -trans_inds. - rewrite -trans_subst_instance_constr ipars. + rewrite -trans_subst_instance ipars. move: (trans_decompose_prod_assum [] t). destruct decompose_prod_assum => -> /=. move: (trans_decompose_app t0). @@ -1149,7 +1156,7 @@ Proof. rewrite trans_it_mkProd_or_LetIn trans_mkApps map_app /= trans_mkApps /= map_app. now rewrite trans_to_extended_list trans_lift map_length. Qed. - +*) Lemma strip_casts_trans t : AstUtils.strip_casts (trans t) = trans t. Proof. induction t using term_forall_list_ind; simpl; auto; @@ -1159,6 +1166,9 @@ Proof. - rewrite strip_casts_mkApp_wf; auto with wf. now rewrite IHt1 IHt2. + - todo "case". + - todo "case". + - todo "case". - now destruct p as [? []]. Qed. @@ -1172,7 +1182,7 @@ Proof. rewrite -(trans_smash_context []) /trans_local. rewrite -List.map_rev nth_error_map. destruct nth_error => /= //. - move: (trans_decompose_app (PCUICAst.decl_type c)). + move: (trans_decompose_app (decl_type c)). destruct decompose_app => /=. simpl. destruct c. simpl. intros ->. now rewrite -trans_destInd. @@ -1209,7 +1219,7 @@ Lemma trans_check_rec_kind Σ k f : Proof. unfold ST.check_recursivity_kind, TT.check_recursivity_kind. rewrite trans_lookup. - destruct S.lookup_env as [[]|] => //. + destruct SE.lookup_env as [[]|] => //. Qed. Lemma trans_wf_fixpoint Σ mfix : @@ -1378,7 +1388,7 @@ Lemma TT_typing_spine_app {cf:checker_flags} Σ Γ ty T' args na A B arg s : TT.typing_spine Σ Γ ty args T' -> TT.cumul Σ Γ T' (T.tProd na A B) -> TT.typing Σ Γ arg A -> - TT.typing_spine Σ Γ ty (args ++ [arg]) (TL.subst1 arg 0 B). + TT.typing_spine Σ Γ ty (args ++ [arg]) (T.subst1 arg 0 B). Proof. intros isty H; revert arg. remember (T.tProd na A B) as prod. @@ -1492,7 +1502,7 @@ Proof. now rewrite trans_subst in Hsp. Qed. -Theorem pcuic_to_template {cf} (Σ : S.global_env_ext) Γ t T : +Theorem pcuic_to_template {cf} (Σ : SE.global_env_ext) Γ t T : ST.wf Σ -> ST.typing Σ Γ t T -> TT.typing (trans_global Σ) (trans_local Γ) (trans t) (trans T). @@ -1504,7 +1514,7 @@ Proof. apply (typing_ind_env_app_size (fun Σ Γ t T => TT.typing (trans_global Σ) (trans_local Γ) (trans t) (trans T) )%type - (fun Σ Γ wfΓ => + (fun Σ Γ => TT.All_local_env (TT.lift_typing TT.typing (trans_global Σ)) (trans_local Γ)) );intros. - now eapply trans_wf_local_env, All_over_All. @@ -1552,12 +1562,12 @@ Proof. now simpl in X2. econstructor. simpl in X1. eapply X1. apply TT.cumul_refl'. assumption. constructor. - - rewrite trans_subst_instance_constr. + - rewrite trans_subst_instance. rewrite trans_cst_type. eapply TT.type_Const; eauto. + now apply trans_declared_constant. + now apply trans_consistent_instance_ext. - - rewrite trans_subst_instance_constr. + - rewrite trans_subst_instance. rewrite trans_ind_type. eapply TT.type_Ind; eauto. + now apply trans_declared_inductive. @@ -1569,7 +1579,8 @@ Proof. * now apply trans_declared_inductive. * now apply map_nth_error. + now apply trans_consistent_instance_ext. - - replace (trans (mkApps p (skipn npar args ++ [c]))) + - todo "case". + (* replace (trans (mkApps p (skipn npar args ++ [c]))) with (Ast.mkApps (trans p) (skipn npar (map trans args) ++ [trans c])). 2: { rewrite trans_mkApps. @@ -1591,9 +1602,9 @@ Proof. + now rewrite trans_mkApps in X4. + now apply trans_build_branches_type in H3. + eapply All2_map. solve_all. - destruct b0 as [s [Hs Hy]]. exists s; eauto. + destruct b0 as [s [Hs Hy]]. exists s; eauto.*) - rewrite trans_subst. - rewrite trans_subst_instance_constr. + rewrite trans_subst_instance. cbn. rewrite map_rev. change (trans ty) with ((on_snd trans pdecl).2). @@ -1613,6 +1624,8 @@ Proof. destruct decl. unfold map_def. reflexivity. + + rewrite /trans_local map_app in X. + now eapply TT.All_local_env_app_inv in X as []. + eapply All_map, (All_impl X0). intuition auto. destruct X2 as [s [? ?]]. exists s; intuition auto. @@ -1628,6 +1641,8 @@ Proof. destruct decl. unfold map_def. reflexivity. + + rewrite /trans_local map_app in X. + now eapply TT.All_local_env_app_inv in X as []. + fold trans. eapply All_map, (All_impl X0). intros x [s ?]; exists s; intuition auto. diff --git a/pcuic/theories/PCUICTypedAst.v b/pcuic/theories/PCUICTypedAst.v new file mode 100644 index 000000000..69cc750f1 --- /dev/null +++ b/pcuic/theories/PCUICTypedAst.v @@ -0,0 +1,107 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Morphisms. +From MetaCoq.Template Require Export utils Universes BasicAst Environment Reflect. +From MetaCoq.Template Require EnvironmentTyping. +From MetaCoq.PCUIC Require Export PCUICPrimitive. +From Equations Require Import Equations. +Require Vector Fin. +(* +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); + (* Context of binders of the branch, including lets. *) + bbody : term; (* The branch body *) }. + Derive NoConfusion for branch. +End Branch. +Arguments branch : clear implicits. + +(* Defined here since BasicAst does not have access to universe instances. + Parameterized by term types as they are not yet defined. *) +Record predicate {term} := mk_predicate { + pparams : list term; (* The parameters *) + puinst : Instance.t; (* The universe instance *) + pcontext : list (context_decl term); (* The predicate context, + initially built from params and puinst *) + preturn : term; (* The return type *) }. + Derive NoConfusion for predicate. +Arguments predicate : clear implicits. +Arguments mk_predicate {_}. + *) + +Inductive context (P : nat -> Type) : nat -> Type := +| tnil : context P 0 +| tcons {n} : P n -> context P n -> context P (S n). + +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) := + context (context_decl term). + +Definition shift n (f : nat -> Type) := + fun i => f (n + i). + +Variant FixCoFix := + | Fix | CoFix. + +(* Terms are well-scoped in a global environment *) + +Variant global_reference := + | ConstRef (kn : kername) + | IndRef (ind : inductive) + | ConstructRef (ind : inductive) (k : nat). + +Definition global_env (term : nat -> Type) := list (kername * term 0). + +Fixpoint lookup_env {term} (Σ : global_env term) (kn : kername) : option (term 0) := + match Σ with + | nil => None + | d :: tl => + if eq_kername kn d.1 then Some d.2 + else lookup_env tl kn + end. + +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). + +Definition declared_inductive Σ ind mdecl decl := + declared_minductive Σ (inductive_mind ind) mdecl /\ + List.nth_error mdecl.(ind_bodies) (inductive_ind ind) = Some decl. + +Definition declared_constructor Σ cstr mdecl idecl cdecl : Prop := + declared_inductive Σ (fst cstr) mdecl idecl /\ + List.nth_error idecl.(ind_ctors) (snd cstr) = Some cdecl. *) + +Inductive term {k : nat} : Type := +| tRel (f : Fin.t k) +| tVar (i : ident) (* For free variables (e.g. in a goal) *) +| tEvar (n : nat) (l : list term) +| tSort (u : Universe.t) +| tProd (na : aname) (A : term) (B : @term Σ (S k)) +| tLambda (na : aname) (A : term) (B : @term Σ (S k)) +| tLetIn (na : aname) (b B : term) (t : @term Σ (S k)) +| tApp (u v : term) +| tConst (kn : kername) (ui : Instance.t) + (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) + (pcontext : context_gen (shift k (@term Σ)) plen) + (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) +(** We use faithful models of primitive type values in PCUIC *) +| tPrim (prim : prim_val term). + +with branch {n : nat} := Type := +| vass (na : aname) (t : term k) + +with global_env : Type := +. diff --git a/pcuic/theories/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index e3bde6629..728e99505 100644 --- a/pcuic/theories/PCUICTyping.v +++ b/pcuic/theories/PCUICTyping.v @@ -1,9 +1,9 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils - PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICUtils - PCUICPosition. + PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICUtils PCUICPosition. From MetaCoq.PCUIC Require Export PCUICReduction PCUICCumulativity. +From MetaCoq.PCUIC Require Export PCUICCases. (* TODO: remove this export *) From MetaCoq Require Export LibHypsNaming. @@ -23,11 +23,8 @@ Implicit Types (cf : checker_flags) (Σ : global_env_ext). *) - -Hint Rewrite subst_context_length subst_instance_context_length - app_context_length map_context_length fix_context_length fix_subst_length cofix_subst_length - map_length app_length lift_context_length - @mapi_length @mapi_rec_length List.rev_length Nat.add_0_r : len. +Hint Rewrite subst_instance_length + fix_context_length fix_subst_length cofix_subst_length : len. Fixpoint isArity T := match T with @@ -37,47 +34,17 @@ Fixpoint isArity T := | _ => False end. - -Include PCUICLookup. - -(** Inductive substitution, to produce a constructors' type *) -Definition inds ind u (l : list one_inductive_body) := - let fix aux n := - match n with - | 0 => [] - | S n => tInd (mkInd ind n) u :: aux n - end - in aux (List.length l). - -Lemma inds_length ind u l : #|inds ind u l| = #|l|. -Proof. - unfold inds. induction l; simpl; congruence. -Qed. -Hint Rewrite inds_length : len. - -Lemma inds_spec ind u l : - inds ind u l = List.rev (mapi (fun i _ => tInd {| inductive_mind := ind; inductive_ind := i |} u) l). -Proof. - unfold inds, mapi. induction l using rev_ind. simpl. reflexivity. - now rewrite app_length /= Nat.add_1_r IHl mapi_rec_app /= rev_app_distr /= Nat.add_0_r. -Qed. - -Definition type_of_constructor mdecl (cdecl : ident * term * nat) (c : inductive * nat) (u : list Level.t) := +Definition type_of_constructor mdecl (cdecl : constructor_body) (c : inductive * nat) (u : list Level.t) := let mind := inductive_mind (fst c) in - subst0 (inds mind u mdecl.(ind_bodies)) (subst_instance_constr u (snd (fst cdecl))). + subst0 (inds mind u mdecl.(ind_bodies)) (subst_instance u (cstr_type cdecl)). Definition extends (Σ Σ' : global_env) := { Σ'' & Σ' = Σ'' ++ Σ }. (** ** Typing relation *) -Module PCUICEnvTyping := EnvTyping PCUICTerm PCUICEnvironment. Include PCUICEnvTyping. -Derive NoConfusion for All_local_env. -Derive NoConfusion for context_decl. -Derive NoConfusion for list. - (* AXIOM GUARD CONDITION *) Class GuardChecker := @@ -111,7 +78,7 @@ Class GuardChecker := fix_guard_subst_instance {cf:checker_flags} Σ Γ mfix u univs : consistent_instance_ext (Σ.1, univs) Σ.2 u -> fix_guard Σ Γ mfix -> - fix_guard (Σ.1, univs) (subst_instance_context u Γ) (map (map_def (subst_instance_constr u) (subst_instance_constr u)) + fix_guard (Σ.1, univs) (subst_instance u Γ) (map (map_def (subst_instance u) (subst_instance u)) mfix) ; fix_guard_extends Σ Γ mfix Σ' : @@ -144,7 +111,7 @@ Class GuardChecker := cofix_guard_subst_instance {cf:checker_flags} Σ Γ mfix u univs : consistent_instance_ext (Σ.1, univs) Σ.2 u -> cofix_guard Σ Γ mfix -> - cofix_guard (Σ.1, univs) (subst_instance_context u Γ) (map (map_def (subst_instance_constr u) (subst_instance_constr u)) + cofix_guard (Σ.1, univs) (subst_instance u Γ) (map (map_def (subst_instance u) (subst_instance u)) mfix) ; cofix_guard_extends Σ Γ mfix Σ' : @@ -154,96 +121,6 @@ Class GuardChecker := Axiom guard_checking : GuardChecker. Existing Instance guard_checking. - -(** Compute the type of a case from the predicate [p], actual parameters [pars] and - an inductive declaration. *) - -Fixpoint instantiate_params_subst params pars s ty := - match params with - | [] => match pars with - | [] => Some (s, ty) - | _ :: _ => None (* Too many arguments to substitute *) - end - | d :: params => - match d.(decl_body), ty with - | None, tProd _ _ B => - match pars with - | hd :: tl => instantiate_params_subst params tl (hd :: s) B - | [] => None (* Not enough arguments to substitute *) - end - | Some b, tLetIn _ _ _ b' => instantiate_params_subst params pars (subst0 s b :: s) b' - | _, _ => None (* Not enough products in the type *) - end - end. - -(* If [ty] is [Π params . B] *) -(* and [⊢ pars : params] *) -(* then [instantiate_params] is [B{pars}] *) - -Definition instantiate_params (params : context) (pars : list term) (ty : term) : option term := - match instantiate_params_subst (List.rev params) pars [] ty with - | Some (s, ty) => Some (subst0 s ty) - | None => None - end. - -Lemma instantiate_params_ params pars ty : - instantiate_params params pars ty - = option_map (fun '(s, ty) => subst0 s ty) - (instantiate_params_subst (List.rev params) pars [] ty). -Proof. - unfold instantiate_params. - repeat (destruct ?; cbnr). -Qed. - -(* [params], [p] and output are already instanciated by [u] *) -Definition build_branches_type ind mdecl idecl params u p : list (option (nat × term)) := - let inds := inds ind.(inductive_mind) u mdecl.(ind_bodies) in - let branch_type i '(id, t, ar) := - let ty := subst0 inds (subst_instance_constr u t) in - match instantiate_params (subst_instance_context u mdecl.(ind_params)) params ty with - | Some ty => - let '(sign, ccl) := decompose_prod_assum [] ty in - let nargs := List.length sign in - let allargs := snd (decompose_app ccl) in - let '(paramrels, args) := chop mdecl.(ind_npars) allargs in - let cstr := tConstruct ind i u in - let args := (args ++ [mkApps cstr (paramrels ++ to_extended_list sign)]) in - Some (ar, it_mkProd_or_LetIn sign (mkApps (lift0 nargs p) args)) - | None => None - end - in mapi branch_type idecl.(ind_ctors). - -Lemma build_branches_type_ ind mdecl idecl params u p : - build_branches_type ind mdecl idecl params u p - = let inds := inds ind.(inductive_mind) u mdecl.(ind_bodies) in - let branch_type i '(id, t, ar) := - let ty := subst0 inds (subst_instance_constr u t) in - option_map (fun ty => - let '(sign, ccl) := decompose_prod_assum [] ty in - let nargs := List.length sign in - let allargs := snd (decompose_app ccl) in - let '(paramrels, args) := chop mdecl.(ind_npars) allargs in - let cstr := tConstruct ind i u in - let args := (args ++ [mkApps cstr (paramrels ++ to_extended_list sign)]) in - (ar, it_mkProd_or_LetIn sign (mkApps (lift0 nargs p) args))) - (instantiate_params (subst_instance_context u mdecl.(ind_params)) - params ty) - in mapi branch_type idecl.(ind_ctors). -Proof. - apply mapi_ext. intros ? [[? ?] ?]; cbnr. - repeat (destruct ?; cbnr). -Qed. - -(* [params] and output already instanciated by [u] *) -Definition build_case_predicate_type ind mdecl idecl params u ps : option term := - X <- instantiate_params (subst_instance_context u (ind_params mdecl)) params - (subst_instance_constr u (ind_type idecl)) ;; - X <- destArity [] X ;; - let inddecl := - {| decl_name := mkBindAnn (nNamed idecl.(ind_name)) idecl.(ind_relevance); - decl_body := None; - decl_type := mkApps (tInd ind u) (map (lift0 #|X.1|) params ++ to_extended_list X.1) |} in - ret (it_mkProd_or_LetIn (X.1 ,, inddecl) (tSort ps)). Definition destInd (t : term) := match t with @@ -369,48 +246,57 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> forall decl, declared_constant Σ.1 cst decl -> consistent_instance_ext Σ decl.(cst_universes) u -> - Σ ;;; Γ |- (tConst cst u) : subst_instance_constr u decl.(cst_type) + Σ ;;; Γ |- (tConst cst u) : subst_instance u decl.(cst_type) | type_Ind ind u : wf_local Σ Γ -> forall mdecl idecl, - declared_inductive Σ.1 mdecl ind idecl -> + declared_inductive Σ.1 ind mdecl idecl -> consistent_instance_ext Σ mdecl.(ind_universes) u -> - Σ ;;; Γ |- (tInd ind u) : subst_instance_constr u idecl.(ind_type) + Σ ;;; Γ |- (tInd ind u) : subst_instance u idecl.(ind_type) | type_Construct ind i u : wf_local Σ Γ -> forall mdecl idecl cdecl, - declared_constructor Σ.1 mdecl idecl (ind, i) cdecl -> + declared_constructor Σ.1 (ind, i) mdecl idecl cdecl -> consistent_instance_ext Σ mdecl.(ind_universes) u -> Σ ;;; Γ |- (tConstruct ind i u) : type_of_constructor mdecl cdecl (ind, i) u -| type_Case indnpar u p c brs args : - let ind := indnpar.1 in - let npar := indnpar.2 in - forall mdecl idecl, - declared_inductive Σ.1 mdecl ind idecl -> - mdecl.(ind_npars) = npar -> - let params := List.firstn npar args in - forall ps pty, build_case_predicate_type ind mdecl idecl params u ps = Some pty -> - Σ ;;; Γ |- p : pty -> +| type_Case (ci : case_info) p c brs indices ps : + forall mdecl idecl (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl), + mdecl.(ind_npars) = ci.(ci_npar) -> + let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in + wf_predicate mdecl idecl p -> + consistent_instance_ext Σ (ind_universes mdecl) p.(puinst) -> + wf_local Σ (Γ ,,, p.(pcontext)) -> + conv_context Σ (Γ ,,, p.(pcontext)) (Γ ,,, predctx) -> + Σ ;;; Γ ,,, p.(pcontext) |- p.(preturn) : tSort ps -> + wf_local Σ (Γ ,,, predctx) -> is_allowed_elimination Σ ps idecl.(ind_kelim) -> - Σ ;;; Γ |- c : mkApps (tInd ind u) args -> + ctx_inst typing Σ Γ (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) -> isCoFinite mdecl.(ind_finite) = false -> - forall btys, map_option_out (build_branches_type ind mdecl idecl params u p) = Some btys -> - All2 (fun br bty => (br.1 = bty.1) * (Σ ;;; Γ |- br.2 : bty.2) * - (* This is a paranoid assumption *) - (∑ s, Σ ;;; Γ |- bty.2 : tSort s)) brs btys -> - Σ ;;; Γ |- tCase indnpar p c brs : mkApps p (skipn npar args ++ [c]) + let ptm := it_mkLambda_or_LetIn p.(pcontext) p.(preturn) in + wf_branches idecl brs -> + All2i (fun i cdecl br => + let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in + (wf_local Σ (Γ ,,, br.(bcontext)) × + wf_local Σ (Γ ,,, brctxty.1) × + conv_context Σ (Γ ,,, br.(bcontext)) (Γ ,,, brctxty.1)) × + ((Σ ;;; Γ ,,, br.(bcontext) |- br.(bbody) : brctxty.2) × + (Σ ;;; Γ ,,, br.(bcontext) |- brctxty.2 : tSort ps))) + 0 idecl.(ind_ctors) brs -> + Σ ;;; Γ |- tCase ci p c brs : mkApps ptm (indices ++ [c]) | type_Proj p c u : forall mdecl idecl pdecl, - declared_projection Σ.1 mdecl idecl p pdecl -> + declared_projection Σ.1 p mdecl idecl pdecl -> forall args, Σ ;;; Γ |- c : mkApps (tInd (fst (fst p)) u) args -> #|args| = ind_npars mdecl -> let ty := snd pdecl in - Σ ;;; Γ |- tProj p c : subst0 (c :: List.rev args) (subst_instance_constr u ty) + Σ ;;; Γ |- tProj p c : subst0 (c :: List.rev args) (subst_instance u ty) | type_Fix mfix n decl : fix_guard Σ Γ mfix -> @@ -438,7 +324,7 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> where " Σ ;;; Γ |- t : T " := (typing Σ Γ t T) and "'wf_local' Σ Γ " := (All_local_env (lift_typing typing Σ) Γ). -Lemma meta_conv {cf : checker_flags} Σ Γ t A B : +Lemma meta_conv {cf} {Σ Γ t A B} : Σ ;;; Γ |- t : A -> A = B -> Σ ;;; Γ |- t : B. @@ -446,6 +332,22 @@ Proof. intros h []; assumption. Qed. +Lemma meta_conv_term {cf} {Σ Γ t t' A} : + Σ ;;; Γ |- t : A -> + t = t' -> + Σ ;;; Γ |- t' : A. +Proof. + intros h []. assumption. +Qed. + +Lemma meta_conv_all {cf} {Σ Γ t A Γ' t' A'} : + Σ ;;; Γ |- t : A -> + Γ = Γ' -> t = t' -> A = A' -> + Σ ;;; Γ' |- t' : A'. +Proof. + intros h [] [] []; assumption. +Qed. + (** ** Typechecking of global environments *) Definition has_nparams npars ty := @@ -456,40 +358,57 @@ Definition unlift_opt_pred (P : global_env_ext -> context -> option term -> term fun Σ Γ t T => P Σ Γ (Some t) T. -Module PCUICTypingDef <: Typing PCUICTerm PCUICEnvironment PCUICEnvTyping. +Module PCUICTypingDef <: EnvironmentTyping.Typing PCUICTerm PCUICEnvironment PCUICEnvTyping PCUICConversionPar PCUICConversion. Definition typing := @typing. Definition wf_universe := @wf_universe. - Definition conv := @conv. - Definition cumul := @cumul. - Definition smash_context := smash_context. - Definition expand_lets := expand_lets. - Definition extended_subst := extended_subst. - Definition expand_lets_ctx := expand_lets_ctx. - Definition lift_context := lift_context. - Definition subst_context := subst_context. - Definition subst_telescope := subst_telescope. - Definition subst_instance_context := subst_instance_context. - Definition subst_instance_constr := subst_instance_constr. - Definition subst := subst. - Definition lift := lift. Definition inds := inds. - Definition noccur_between := noccur_between. - Definition closedn := closedn. Definition destArity := destArity []. End PCUICTypingDef. Module PCUICDeclarationTyping := - DeclarationTyping + EnvironmentTyping.DeclarationTyping PCUICTerm PCUICEnvironment PCUICEnvTyping + PCUICConversionPar + PCUICConversion PCUICTypingDef PCUICLookup. Include PCUICDeclarationTyping. Definition isWfArity {cf:checker_flags} Σ (Γ : context) T := (isType Σ Γ T × { ctx & { s & (destArity [] T = Some (ctx, s)) } }). + +Definition tybranches {cf} Σ Γ ci mdecl idecl p ps ptm n ctors brs := + All2i + (fun (i : nat) (cdecl : constructor_body) (br : branch term) => + let brctxty := case_branch_type ci mdecl idecl p br ptm i cdecl in + (wf_local Σ (Γ ,,, br.(bcontext)) × + wf_local Σ (Γ ,,, brctxty.1) × + conv_context Σ (Γ ,,, br.(bcontext)) (Γ ,,, brctxty.1)) × + (Σ;;; Γ,,, br.(bcontext) |- bbody br : brctxty.2 + × Σ;;; Γ,,, br.(bcontext) |- brctxty.2 : tSort ps)) n ctors brs. + +Definition branches_size {cf} {Σ Γ ci mdecl idecl p ps ptm brs} + (typing_size : forall Σ Γ t T, Σ ;;; Γ |- t : T -> size) + {n ctors} + (a : tybranches Σ Γ ci mdecl idecl p ps ptm n ctors brs) : size := + (all2i_size _ (fun i x y p => + Nat.max + (Nat.max (wf_local_size _ typing_size _ p.1.1) (wf_local_size _ typing_size _ p.1.2.1)) + (Nat.max (typing_size _ _ _ _ p.2.1) (typing_size _ _ _ _ p.2.2))) a). + +Section CtxInstSize. + Context {cf} (typing_size : forall {Σ Γ t T}, Σ ;;; Γ |- t : T -> size). + + Fixpoint ctx_inst_size {Σ Γ args Δ} (c : ctx_inst typing Σ Γ args Δ) : size := + match c with + | ctx_inst_nil => 0 + | ctx_inst_ass na t i inst Δ ty ctxi => (typing_size _ _ _ _ ty) + (ctx_inst_size ctxi) + | ctx_inst_def na b t inst Δ ctxi => S (ctx_inst_size ctxi) + end. +End CtxInstSize. Definition typing_size `{checker_flags} {Σ Γ t T} (d : Σ ;;; Γ |- t : T) : size. Proof. @@ -498,9 +417,9 @@ Proof. destruct 1 ; repeat match goal with | H : typing _ _ _ _ |- _ => apply typing_size in H - end; + end; match goal with - | H : All2 _ _ _ |- _ => idtac + | H : All2i _ _ _ _ |- _ => idtac | H : All_local_env _ _ |- _ => idtac | H : All _ _ |- _ => idtac | H : _ + _ |- _ => idtac @@ -514,10 +433,13 @@ Proof. - exact (S (S (wf_local_size _ typing_size _ a))). - exact (S (S (wf_local_size _ typing_size _ a))). - exact (S (S (wf_local_size _ typing_size _ a))). - - exact (S (Nat.max d2 (Nat.max d3 - (all2_size _ (fun x y p => Nat.max (typing_size Σ Γ (snd x) (snd y) (snd (fst p))) (typing_size _ _ _ _ (snd p).π2)) a)))). - - exact (S (Nat.max (Nat.max (wf_local_size _ typing_size _ a) (all_size _ (fun x p => typing_size Σ _ _ _ p.π2) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). - - exact (S (Nat.max (Nat.max (wf_local_size _ typing_size _ a) (all_size _ (fun x p => typing_size Σ _ _ _ p.π2) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). + - exact (S (Nat.max (Nat.max (wf_local_size _ typing_size _ a) (wf_local_size _ typing_size _ a1)) + (Nat.max (ctx_inst_size typing_size c1) + (Nat.max d1 (Nat.max d2 (branches_size typing_size a2)))))). + - exact (S (Nat.max (Nat.max (wf_local_size _ typing_size _ a) + (all_size _ (fun x p => typing_size Σ _ _ _ p.π2) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). + - exact (S (Nat.max (Nat.max (wf_local_size _ typing_size _ a) + (all_size _ (fun x p => typing_size Σ _ _ _ p.π2) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). Defined. Lemma typing_size_pos `{checker_flags} {Σ Γ t T} (d : Σ ;;; Γ |- t : T) : typing_size d > 0. @@ -580,11 +502,10 @@ Hint Extern 4 (wf_local _ ?Γ) => Hint Resolve typing_wf_local : wf. -Definition env_prop `{checker_flags} (P : forall Σ Γ t T, Type) (PΓ : forall Σ Γ, wf_local Σ Γ -> Type) := +Definition env_prop `{checker_flags} (P : forall Σ Γ t T, Type) (PΓ : forall Σ Γ, Type) := forall Σ (wfΣ : wf Σ.1) Γ t T (ty : Σ ;;; Γ |- t : T), Forall_decls_typing P Σ.1 * - PΓ Σ Γ (typing_wf_local ty) * - P Σ Γ t T. + (PΓ Σ Γ * P Σ Γ t T). Lemma env_prop_typing `{checker_flags} P PΓ : env_prop P PΓ -> forall Σ (wfΣ : wf Σ.1) (Γ : context) (t T : term), @@ -597,10 +518,10 @@ Proof. Defined. Lemma env_prop_wf_local `{checker_flags} P PΓ : env_prop P PΓ -> - forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), PΓ Σ Γ wfΓ. + forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), PΓ Σ Γ. Proof. intros. pose (type_Prop_wf _ _ wfΓ). - now destruct (X _ wfΣ _ _ _ t) as [[? ?] ?]. + now destruct (X _ wfΣ _ _ _ t) as [? [? ?]]. Qed. Lemma type_Prop `{checker_flags} Σ : Σ ;;; [] |- tSort Universe.lProp : tSort Universe.type1. @@ -642,7 +563,6 @@ Proof. induction d; simpl; change (fun (x : global_env_ext) (x0 : context) (x1 x2 : term) (x3 : x;;; x0 |- x1 : x2) => typing_size x3) with (@typing_size H); try lia. - - destruct indnpar as [ind' npar']; cbn in *; subst ind npar. lia. Qed. Lemma wf_local_inv `{checker_flags} {Σ Γ'} (w : wf_local Σ Γ') : @@ -697,23 +617,23 @@ Qed. Lemma typing_ind_env_app_size `{cf : checker_flags} : forall (P : global_env_ext -> context -> term -> term -> Type) (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T) - (PΓ : forall Σ Γ, wf_local Σ Γ -> Type), + (PΓ : global_env_ext -> context -> Type), (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), - All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ wfΓ) -> + All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl, nth_error Γ n = Some decl -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> wf_universe Σ u -> P Σ Γ (tSort u) (tSort (Universe.super u))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 s2 : Universe.t), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- t : tSort s1 -> P Σ Γ t (tSort s1) -> Σ ;;; Γ,, vass n t |- b : tSort s2 -> @@ -721,14 +641,14 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 : Universe.t) (bty : term), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- t : tSort s1 -> P Σ Γ t (tSort s1) -> Σ ;;; Γ,, vass n t |- b : bty -> P Σ (Γ,, vass n t) b bty -> P Σ Γ (tLambda n t b) (tProd n t bty)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (b b_ty b' : term) (s1 : Universe.t) (b'_ty : term), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- b_ty : tSort s1 -> P Σ Γ b_ty (tSort s1) -> Σ ;;; Γ |- b : b_ty -> @@ -737,9 +657,7 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : P Σ (Γ,, vdef n b b_ty) b' b'_ty -> P Σ Γ (tLetIn n b b_ty b') (tLetIn n b b_ty b'_ty)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t : term) na A B u s, - PΓ Σ Γ wfΓ -> - - + PΓ Σ Γ -> Σ ;;; Γ |- tProd na A B : tSort s -> P Σ Γ (tProd na A B) (tSort s) -> forall (Ht : Σ ;;; Γ |- t : tProd na A B), P Σ Γ t (tProd na A B) -> @@ -751,59 +669,73 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) cst u (decl : constant_body), Forall_decls_typing P Σ.1 -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> declared_constant Σ.1 cst decl -> consistent_instance_ext Σ decl.(cst_universes) u -> - P Σ Γ (tConst cst u) (subst_instance_constr u (cst_type decl))) -> + P Σ Γ (tConst cst u) (subst_instance u (cst_type decl))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u - mdecl idecl (isdecl : declared_inductive Σ.1 mdecl ind idecl), + mdecl idecl (isdecl : declared_inductive Σ.1 ind mdecl idecl), Forall_decls_typing P Σ.1 -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> consistent_instance_ext Σ mdecl.(ind_universes) u -> - P Σ Γ (tInd ind u) (subst_instance_constr u (ind_type idecl))) -> + P Σ Γ (tInd ind u) (subst_instance u (ind_type idecl))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) (i : nat) u - mdecl idecl cdecl (isdecl : declared_constructor Σ.1 mdecl idecl (ind, i) cdecl), + mdecl idecl cdecl (isdecl : declared_constructor Σ.1 (ind, i) mdecl idecl cdecl), Forall_decls_typing P Σ.1 -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> consistent_instance_ext Σ mdecl.(ind_universes) u -> P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u (npar : nat) - (p c : term) (brs : list (nat * term)) - (args : list term) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) - (isdecl : declared_inductive (fst Σ) mdecl ind idecl), - Forall_decls_typing P Σ.1 -> PΓ Σ Γ wfΓ -> - ind_npars mdecl = npar -> - let params := firstn npar args in - forall ps pty, build_case_predicate_type ind mdecl idecl params u ps = Some pty -> - Σ ;;; Γ |- p : pty -> - P Σ Γ p pty -> - is_allowed_elimination (global_ext_constraints Σ) ps idecl.(ind_kelim) -> - Σ ;;; Γ |- c : mkApps (tInd ind u) args -> - isCoFinite mdecl.(ind_finite) = false -> - P Σ Γ c (mkApps (tInd ind u) args) -> - forall btys, map_option_out (build_branches_type ind mdecl idecl params u p) = Some btys -> - All2 (fun br bty => (br.1 = bty.1) * - (Σ ;;; Γ |- br.2 : bty.2) * P Σ Γ br.2 bty.2 * - ∑ s, (Σ ;;; Γ |- bty.2 : tSort s) * P Σ Γ bty.2 (tSort s)) - brs btys -> - P Σ Γ (tCase (ind, npar) p c brs) (mkApps p (skipn npar args ++ [c]))) -> + (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 -> + PΓ Σ Γ -> + mdecl.(ind_npars) = ci.(ci_npar) -> + let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in + wf_predicate mdecl idecl p -> + consistent_instance_ext Σ (ind_universes mdecl) p.(puinst) -> + PΓ Σ (Γ ,,, p.(pcontext)) -> + conv_context Σ (Γ ,,, p.(pcontext)) (Γ ,,, predctx) -> + forall pret : Σ ;;; Γ ,,, p.(pcontext) |- p.(preturn) : tSort ps, + P Σ (Γ ,,, p.(pcontext)) p.(preturn) (tSort ps) -> + PΓ Σ (Γ ,,, predctx) -> + is_allowed_elimination Σ ps idecl.(ind_kelim) -> + ctx_inst typing Σ Γ (p.(pparams) ++ indices) + (List.rev (subst_instance p.(puinst) (mdecl.(ind_params) ,,, idecl.(ind_indices)))) -> + ctx_inst 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)) -> + isCoFinite mdecl.(ind_finite) = false -> + let ptm := it_mkLambda_or_LetIn p.(pcontext) p.(preturn) in + wf_branches idecl brs -> + All2i (fun i cdecl br => + let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in + (PΓ Σ (Γ ,,, br.(bcontext)) * + conv_context Σ (Γ ,,, br.(bcontext)) (Γ ,,, brctxty.1)) × + ((Σ ;;; Γ ,,, br.(bcontext) |- br.(bbody) : brctxty.2) * + PΓ Σ (Γ ,,, brctxty.1) * + (P Σ (Γ ,,, br.(bcontext)) br.(bbody) brctxty.2 * + ((Σ ;;; Γ ,,, br.(bcontext) |- brctxty.2 : tSort ps) * + P Σ (Γ ,,, br.(bcontext)) 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 pdecl (isdecl : declared_projection Σ.1 mdecl idecl p pdecl) args, - Forall_decls_typing P Σ.1 -> PΓ Σ Γ wfΓ -> + mdecl idecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl pdecl) args, + Forall_decls_typing P Σ.1 -> PΓ Σ Γ -> Σ ;;; Γ |- c : mkApps (tInd (fst (fst p)) u) args -> P Σ Γ c (mkApps (tInd (fst (fst p)) u) args) -> #|args| = ind_npars mdecl -> - let ty := snd pdecl in P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (subst_instance_constr u ty))) -> + let ty := snd pdecl in P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (subst_instance u ty))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (mfix : list (def term)) (n : nat) decl, let types := fix_context mfix in fix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> - PΓ Σ Γ wfΓ -> + PΓ Σ (Γ ,,, types) -> All (fun d => {s & (Σ ;;; Γ |- d.(dtype) : tSort s)%type * P Σ Γ d.(dtype) (tSort s)})%type mfix -> All (fun d => (Σ ;;; Γ ,,, types |- d.(dbody) : lift0 #|types| d.(dtype))%type * P Σ (Γ ,,, types) d.(dbody) (lift0 #|types| d.(dtype)))%type mfix -> @@ -814,7 +746,7 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : let types := fix_context mfix in cofix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> - PΓ Σ Γ wfΓ -> + PΓ Σ (Γ ,,, types) -> All (fun d => {s & (Σ ;;; Γ |- d.(dtype) : tSort s)%type * P Σ Γ d.(dtype) (tSort s)})%type mfix -> All (fun d => (Σ ;;; Γ ,,, types |- d.(dbody) : lift0 #|types| d.(dtype))%type * P Σ (Γ ,,, types) d.(dbody) (lift0 #|types| d.(dtype)))%type mfix -> @@ -822,7 +754,7 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : P Σ Γ (tCoFix mfix n) decl.(dtype)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- t : A -> P Σ Γ t A -> Σ ;;; Γ |- B : tSort s -> @@ -832,229 +764,294 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : env_prop P PΓ. Proof. - intros P Pdecl PΓ; unfold env_prop. - intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ t T H. - (* NOTE (Danil): while porting to 8.9, I had to split original "pose" into 2 pieces, - otherwise it takes forever to execure the "pose", for some reason *) - pose (@Fix_F ({ Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & - { t : term & { T : term & Σ ;;; Γ |- t : T }}}}})) as p0. - specialize (p0 (PCUICUtils.dlexprod (precompose lt (fun Σ => globenv_size (fst Σ))) - (fun Σ => precompose lt (fun x => typing_size (projT2 (projT2 (projT2 (projT2 x)))))))) as p. - set(foo := existT _ Σ (existT _ wfΣ (existT _ Γ (existT _ t (existT _ _ H)))) : { Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & { t : term & { T : term & Σ ;;; Γ |- t : T }}}}}). - change Σ with (projT1 foo). - change Γ with (projT1 (projT2 (projT2 foo))). - change t with (projT1 (projT2 (projT2 (projT2 foo)))). - change T with (projT1 (projT2 (projT2 (projT2 (projT2 foo))))). - change H with (projT2 (projT2 (projT2 (projT2 (projT2 foo))))). - revert foo. - match goal with - |- let foo := _ in @?P foo => specialize (p (fun x => P x)) - end. - forward p; [ | apply p; apply PCUICUtils.wf_dlexprod; intros; apply wf_precompose; apply lt_wf]. - clear p. - clear Σ wfΣ Γ t T H. - intros (Σ & wfΣ & Γ & t & t0 & H). simpl. - intros IH. simpl in IH. - split. split. - destruct Σ as [Σ φ]. destruct Σ. - constructor. - cbn in wfΣ; inversion_clear wfΣ. auto. - inv wfΣ. - rename X14 into Xg. - constructor; auto. unfold Forall_decls_typing in IH. - - simple refine (let IH' := IH ((Σ, udecl); (X13; []; (tSort Universe.lProp); _; _)) in _). - shelve. simpl. apply type_Prop. - forward IH'. constructor 1; cbn. lia. - apply IH'; auto. - - simpl. simpl in *. - destruct d; simpl. - + destruct c; simpl in *. - destruct cst_body; simpl in *. - simpl. - intros. red in Xg. simpl in Xg. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ [] (existT _ _ (existT _ _ Xg)))))). - simpl in IH. - forward IH. constructor 1. simpl; lia. - apply IH. - red. simpl. red in Xg; simpl in Xg. - destruct Xg as [s Hs]. red. simpl. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ [] (existT _ _ (existT _ _ Hs)))))). - simpl in IH. - forward IH. constructor 1. simpl; lia. exists s. eapply IH. - + red in Xg. - destruct Xg as [onI onP onnp]; constructor; eauto. - eapply Alli_impl; eauto. clear onI onP onnp; intros n x Xg. - refine {| ind_indices := Xg.(ind_indices); - ind_arity_eq := Xg.(ind_arity_eq); - ind_cshapes := Xg.(ind_cshapes) |}. - - ++ apply onArity in Xg. destruct Xg as [s Hs]. exists s; auto. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ [] (existT _ _ (existT _ _ Hs)))))). - simpl in IH. simpl. apply IH; constructor 1; simpl; lia. - ++ pose proof Xg.(onConstructors) as Xg'. - eapply All2_impl; eauto. intros. - destruct X14 as [cass chead tyeq onctyp oncargs oncind]. - unshelve econstructor; eauto. - destruct onctyp as [s Hs]. - simpl in Hs. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hs)))))). - simpl in IH. simpl. exists s. simpl. apply IH; constructor 1; simpl; auto with arith. - eapply sorts_local_ctx_impl; eauto. simpl. intros. red in X14. - destruct T. - specialize (IH ((Σ, udecl); (X13; _; _; _; X14))). - apply IH. simpl. constructor 1. simpl. auto with arith. - destruct X14 as [u Hu]. exists u. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hu)))))). - apply IH. simpl. constructor 1. simpl. auto with arith. - clear -X13 IH oncind. - revert oncind. - generalize (List.rev (lift_context #|cshape_args y| 0 (ind_indices Xg))). - generalize (cshape_indices y). induction 1; constructor; auto. - red in p0 |- *. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ p0)))))). - apply IH. simpl. constructor 1. simpl. auto with arith. - ++ intros Hprojs; pose proof (onProjections Xg Hprojs); auto. - ++ destruct Xg. simpl. unfold check_ind_sorts in *. - destruct Universe.is_prop; auto. - destruct Universe.is_sprop; auto. - split. apply ind_sorts0. destruct indices_matter; auto. - eapply type_local_ctx_impl. eapply ind_sorts0. - intros. red in X14. - destruct T. - specialize (IH ((Σ, udecl); (X13; _; _; _; X14))). - apply IH. simpl. constructor 1. simpl. auto with arith. - destruct X14 as [u Hu]. exists u. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hu)))))). - apply IH. simpl. constructor 1. simpl. auto with arith. - ++ apply onIndices. - ++ red in onP |- *. - eapply All_local_env_impl; eauto. - intros. destruct T; simpl in X14. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ X14)))))). - simpl in IH. apply IH. constructor 1. simpl. lia. - destruct X14 as [u Hu]. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hu)))))). - simpl in IH. simpl. exists u. apply IH. constructor 1. simpl. lia. - - - assert (forall Γ t T (Hty : Σ ;;; Γ |- t : T), - typing_size Hty < typing_size H -> - Forall_decls_typing P Σ.1 * P Σ Γ t T). - intros. - specialize (IH (existT _ Σ (existT _ wfΣ (existT _ _ (existT _ _ (existT _ _ Hty)))))). - simpl in IH. - forward IH. - constructor 2. simpl. apply H0. - split; apply IH. clear IH. - rename X13 into X14. - - assert (All_local_env_over typing Pdecl Σ Γ (typing_wf_local H)). - { clear -Pdecl wfΣ X14. - pose proof (typing_wf_local_size H). - set (foo := typing_wf_local H) in *. - clearbody foo. - revert foo H0. generalize Γ at 1 2 4. - induction foo; simpl in *; try destruct t2 as [u Hu]; simpl in *; constructor. - - simpl in *. apply IHfoo. lia. - - red. eapply (X14 _ _ _ Hu). lia. - - simpl in *. apply IHfoo. lia. - - red. apply (X14 _ _ _ t3). lia. - - red. apply (X14 _ _ _ Hu). lia. } - eapply XΓ; eauto. - - - assert (forall Γ t T (Hty : Σ ;;; Γ |- t : T), - typing_size Hty < typing_size H -> - Forall_decls_typing P Σ.1 * P Σ Γ t T). - intros. - specialize (IH (existT _ Σ (existT _ wfΣ (existT _ _ (existT _ _ (existT _ _ Hty)))))). - simpl in IH. - forward IH. - constructor 2. simpl. apply H0. - split; apply IH. clear IH. - rename X13 into X14. - - assert (Hdecls: typing_size H > 1 -> Forall_decls_typing P Σ.1). - { specialize (X14 _ _ _ (type_Prop _)). - simpl in X14. intros Hle. apply X14. lia. } - - assert (All_local_env_over typing Pdecl Σ Γ (typing_wf_local H)). - { clear -Pdecl wfΣ X14. - pose proof (typing_wf_local_size H). - set (foo := typing_wf_local H) in *. - clearbody foo. - revert foo H0. generalize Γ at 1 2 4. - induction foo; simpl in *; try destruct t2 as [u Hu]; simpl in *; constructor. - - simpl in *. apply IHfoo. lia. - - red. eapply (X14 _ _ _ Hu). lia. - - simpl in *. apply IHfoo. lia. - - red. apply (X14 _ _ _ t3). lia. - - red. apply (X14 _ _ _ Hu). lia. } - apply XΓ in X13. all:auto. - - destruct H; - try solve [ match reverse goal with - H : _ |- _ => eapply H - end; eauto; - unshelve eapply X14; simpl; auto with arith]. - - -- match reverse goal with - H : _ |- _ => eapply H - end; eauto; - unshelve eapply X14; simpl; eauto with arith wf. - - -- match reverse goal with - H : _ |- _ => eapply H - end; eauto. all:try unshelve eapply X14; simpl; auto; try lia. - Unshelve. 2:exact H0. - simpl. intros. - eapply X14. instantiate (1 := Ht'). - simpl. lia. + intros P Pdecl PΓ. + intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ t T H. + (* NOTE (Danil): while porting to 8.9, I had to split original "pose" into 2 pieces, + otherwise it takes forever to execure the "pose", for some reason *) + pose proof (@Fix_F { Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & + { t : term & { T : term & Σ ;;; Γ |- t : T }}}}}) as p0. + + specialize (p0 (PCUICUtils.dlexprod (precompose lt (fun Σ => globenv_size (fst Σ))) + (fun Σ => precompose lt (fun x => typing_size (projT2 (projT2 (projT2 (projT2 x)))))))) as p. + set(foo := existT _ Σ (existT _ wfΣ (existT _ Γ (existT _ t (existT _ _ H)))) : { Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & { t : term & { T : term & Σ ;;; Γ |- t : T }}}}}). + change Σ with (projT1 foo). + change Γ with (projT1 (projT2 (projT2 foo))). + change t with (projT1 (projT2 (projT2 (projT2 foo)))). + change T with (projT1 (projT2 (projT2 (projT2 (projT2 foo))))). + change H with (projT2 (projT2 (projT2 (projT2 (projT2 foo))))). + revert foo. + match goal with + |- let foo := _ in @?P foo => specialize (p (fun x => P x)) + end. + forward p; [ | apply p; apply PCUICUtils.wf_dlexprod; intros; apply wf_precompose; apply lt_wf]. + clear p. + clear Σ wfΣ Γ t T H. + intros (Σ & wfΣ & Γ & t & t0 & H). simpl. + intros IH. simpl in IH. + split. + - clear X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12. + destruct Σ as [Σ φ]. destruct Σ. + constructor. + cbn in wfΣ; inversion_clear wfΣ. auto. + rename X0 into Xg. + constructor; auto. unfold Forall_decls_typing in IH. + * simple refine (let IH' := IH ((Σ, udecl); (X; []; (tSort Universe.lProp); _; _)) in _). + shelve. simpl. apply type_Prop. + forward IH'. constructor 1; cbn. lia. + apply IH'; auto. + * simpl. simpl in *. + destruct d; simpl. + + destruct c; simpl in *. + destruct cst_body0; simpl in *. + simpl. + red in Xg; simpl in Xg. intros. red. simpl. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ [] (existT _ _ (existT _ _ Xg)))))). + simpl in IH. + forward IH. constructor 1. simpl; lia. + apply IH. + red. simpl. red in Xg; simpl in Xg. + destruct Xg as [s Hs]. red. simpl. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ [] (existT _ _ (existT _ _ Hs)))))). + simpl in IH. + forward IH. constructor 1. simpl; lia. exists s. eapply IH. + + red in Xg. + destruct Xg as [onI onP onnp]; constructor; eauto. + eapply Alli_impl; eauto. 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. destruct Xg as [s Hs]. exists s; auto. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ [] (existT _ _ (existT _ _ Hs)))))). + simpl in IH. simpl. apply IH; constructor 1; simpl; lia. + ++ pose proof Xg.(onConstructors) as Xg'. + eapply All2_impl; eauto. intros. + destruct X0 as [cass chead tyeq onctyp oncargs oncind]. + unshelve econstructor; eauto. + destruct onctyp as [s Hs]. + simpl in Hs. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ _ (existT _ _ (existT _ _ Hs)))))). + simpl in IH. simpl. exists s. simpl. apply IH; constructor 1; simpl; auto with arith. + eapply sorts_local_ctx_impl; eauto. simpl. intros. red in X0. + destruct T. + specialize (IH ((Σ, udecl); (X; _; _; _; X0))). + apply IH. simpl. constructor 1. simpl. auto with arith. + destruct X0 as [u Hu]. exists u. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ _ (existT _ _ (existT _ _ Hu)))))). + apply IH. simpl. constructor 1. simpl. auto with arith. + clear -X IH oncind. + revert oncind. + generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))). + generalize (cstr_indices x0). induction 1; constructor; auto. + simpl in t2 |- *. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ _ (existT _ _ (existT _ _ t2)))))). + apply IH. simpl. constructor 1. simpl. auto with arith. + ++ intros Hprojs; pose proof (onProjections Xg Hprojs); auto. + ++ destruct Xg. simpl. unfold check_ind_sorts in *. + destruct Universe.is_prop; auto. + destruct Universe.is_sprop; auto. + split. apply ind_sorts0. destruct indices_matter; auto. + eapply type_local_ctx_impl. eapply ind_sorts0. + intros. red in X0. + destruct T. + specialize (IH ((Σ, udecl); (X; _; _; _; X0))). + apply IH. simpl. constructor 1. simpl. auto with arith. + destruct X0 as [u Hu]. exists u. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ _ (existT _ _ (existT _ _ Hu)))))). + apply IH. simpl. constructor 1. simpl. auto with arith. + ++ apply (onIndices Xg). + ++ red in onP |- *. + eapply All_local_env_impl; eauto. + intros. destruct T; simpl in X0. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ _ (existT _ _ (existT _ _ X0)))))). + simpl in IH. apply IH. constructor 1. simpl. lia. + destruct X0 as [u Hu]. + specialize (IH (existT _ (Σ, udecl) (existT _ X (existT _ _ (existT _ _ (existT _ _ Hu)))))). + simpl in IH. simpl. exists u. apply IH. constructor 1. simpl. lia. + + - assert (forall Γ t T (Hty : Σ ;;; Γ |- t : T), + typing_size Hty < typing_size H -> + Forall_decls_typing P Σ.1 * P Σ Γ t T). + { intros. + specialize (IH (existT _ Σ (existT _ wfΣ (existT _ _ (existT _ _ (existT _ _ Hty)))))). + simpl in IH. + forward IH. + constructor 2. simpl. apply H0. + split; apply IH. } + rename X13 into X14. + + assert (Hdecls: typing_size H > 1 -> Forall_decls_typing P Σ.1). + { specialize (X14 _ _ _ (type_Prop _)). + simpl in X14. intros Hle. apply X14. lia. } + assert (Hwf : forall Γ' (Hwf : wf_local Σ Γ'), + wf_local_size _ (@typing_size _) _ Hwf < typing_size H -> + PΓ Σ Γ'). + { intros. eapply (XΓ _ _ _ Hwf); auto. + clear -Pdecl wfΣ X14 H0. + revert Hwf H0. + induction Hwf; simpl in *; try destruct t2 as [u Hu]; simpl in *; constructor. + - simpl in *. apply IHHwf. lia. + - red. apply (X14 _ _ _ Hu). lia. + - simpl in *. apply IHHwf. lia. + - red. apply (X14 _ _ _ t3). lia. + - red. simpl. apply (X14 _ _ _ Hu). lia. } + + assert (Htywf : forall Γ' t T (Hty : Σ ;;; Γ' |- t : T), + typing_size Hty <= typing_size H -> + PΓ Σ Γ'). + { intros. eapply (Hwf _ (typing_wf_local Hty)); auto. + pose proof (typing_wf_local_size Hty). lia. } - -- match reverse goal with - H : _ |- _ => eapply H - end; eauto. - simpl in Hdecls. apply Hdecls; lia. - - -- eapply X6; eauto. - apply Hdecls; simpl; lia. - - -- eapply X7; eauto. apply Hdecls; simpl; lia. - - -- destruct indnpar as [ind' npar']; - cbn in ind; cbn in npar; subst ind; subst npar. - eapply X8; eauto. - ++ eapply (X14 _ _ _ H); eauto. simpl; auto with arith. - ++ eapply (X14 _ _ _ H); eauto. simpl; auto with arith. - ++ simpl in *. - eapply (X14 _ _ _ H0); eauto. clear. lia. - ++ clear X13 Hdecls. revert a X14. simpl. clear. intros. - induction a; simpl in *. - ** constructor. - ** destruct r as [[? ?] ?]. constructor. - --- intuition eauto. - +++ eapply (X14 _ _ _ t); eauto. simpl; auto with arith. - lia. - +++ destruct s as [s Hs]. exists s; split; [auto|]. - eapply (X14 _ _ _ Hs); eauto. simpl; auto with arith. - lia. - --- apply IHa. auto. intros. - eapply (X14 _ _ _ Hty). lia. - - -- eapply X9; eauto. apply Hdecls; simpl. - pose proof (typing_size_pos H). lia. - eapply (X14 _ _ _ H). simpl. lia. - - -- clear X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X11 X12. - eapply X10; eauto; clear X10. simpl in *. - * assert(forall (t T : term) (Hty : Σ;;; Γ |- t : T), - typing_size Hty < - S (all_size (fun x : def term => - ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) + clear IH. + assert (pΓ : PΓ Σ Γ). + { apply (Htywf _ _ _ H). lia. } + split; auto. + set (wfΓ := typing_wf_local H); clearbody wfΓ. + + destruct H; simpl in pΓ; + try solve [ match reverse goal with + H : _ |- _ => eapply H + end; eauto; + unshelve eapply X14; simpl; auto with arith]. + + -- match reverse goal with + H : _ |- _ => eapply H + end; eauto; + unshelve eapply X14; simpl; eauto with arith wf. + + -- match reverse goal with + H : _ |- _ => eapply H + end; eauto. all:try unshelve eapply X14; simpl; auto; try lia. + Unshelve. 2:exact H0. + simpl. intros. + eapply X14. instantiate (1 := Ht'). + simpl. lia. + + -- match reverse goal with + H : _ |- _ => eapply H + end; eauto. + simpl in Hdecls. apply Hdecls; lia. + + -- eapply X6; eauto. + apply Hdecls; simpl; lia. + + -- eapply X7; eauto. apply Hdecls; simpl; lia. + + -- simpl in pΓ. + eapply (X8 Σ wfΣ Γ (typing_wf_local H0) ci); eauto. + ++ eapply (X14 _ _ _ H); eauto. rewrite /predctx. simpl. lia. + ++ eapply (Hwf _ a); simpl; lia. + ++ eapply (X14 _ _ _ H); eauto. rewrite /predctx; simpl; lia. + ++ eapply (Hwf _ a1). rewrite /predctx; simpl. lia. + ++ clear -c1 X14. + assert (forall (Γ' : context) (t T : term) (Hty : Σ;;; Γ' |- t : T), + typing_size Hty <= ctx_inst_size (@typing_size _) c1 -> + P Σ Γ' t T). + { intros. eapply (X14 _ _ _ Hty). simpl. lia. } + clear -X c1. + revert c1 X. + generalize (List.rev (subst_instance (puinst p) (ind_params mdecl ,,, ind_indices idecl))). + generalize (pparams p ++ indices). + intros l c ctxi IH; induction ctxi; constructor; eauto. + * eapply (IH _ _ _ t0); simpl; auto. lia. + * eapply IHctxi. intros. eapply (IH _ _ _ Hty). simpl. lia. + * eapply IHctxi. intros. eapply (IH _ _ _ Hty). simpl. lia. + + ++ eapply (X14 _ _ _ H0); simpl. lia. + ++ clear Hdecls. simpl in Hwf, Htywf, X14. + clear -Hwf Htywf X14. + subst ptm predctx; induction a2. + ** constructor. + ** destruct r0 as [[wfbctx [wfcbc convctx]] [t t0]]. constructor. + --- intros brctxty. + repeat split. + +++ apply (Hwf _ wfbctx). simpl. lia. + +++ exact convctx. + +++ exact t. + +++ eapply (Hwf _ wfcbc); eauto. simpl. lia. + +++ unshelve eapply (X14 _ _ _ t _); eauto. + simpl. lia. + +++ simpl; auto with arith. + +++ eapply (X14 _ _ _ t0); eauto. simpl; auto with arith. + lia. + --- apply IHa2; auto. intros. apply (X14 _ _ _ Hty). simpl. clear -H1; lia. + intros. + eapply (Hwf _ Hwf0). simpl. clear -H1; lia. + intros. + eapply (Htywf _ _ _ Hty). simpl; clear -H1. + set foo := Nat.max _ (wf_local_size _ _ _ wfcbc). clearbody foo. + lia. + + -- eapply X9; eauto. apply Hdecls; simpl. + pose proof (typing_size_pos H). lia. + eapply (X14 _ _ _ H). simpl. lia. + + -- clear X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X11 X12. + eapply X10; eauto; clear X10. simpl in *. + * assert(forall Γ0 (t T : term) (Hty : Σ;;; Γ0 |- t : T), + typing_size Hty < + S + (all_size _ (fun (x : def term) p => typing_size p) a1) -> + PΓ Σ Γ0). + {intros. eapply (Htywf _ _ _ Hty); eauto. lia. } + destruct mfix. now rewrite nth_error_nil in e. + depelim a1. + eapply (X _ _ _ t). simpl. lia. + * assert(forall (t T : term) (Hty : Σ;;; Γ |- t : T), + typing_size Hty < + S (all_size (fun x : def term => + ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) + (fun (x : def term) + (p : ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) => + typing_size p.π2) a0) -> + Forall_decls_typing P Σ.1 * P Σ Γ t T). + intros; eauto. eapply (X14 _ _ _ Hty); eauto. simpl. lia. + clear Hwf Htywf X14 a pΓ Hdecls. + clear -a0 X. + induction a0; constructor. + destruct p as [s Hs]. exists s; split; auto. + apply (X (dtype x) (tSort s) Hs). simpl. lia. + apply IHa0. intros. eapply (X _ _ Hty); eauto. + simpl. lia. + * simpl in X14. + assert(forall Γ0 : context, + wf_local Σ Γ0 -> + forall (t T : term) (Hty : Σ;;; Γ0 |- t : T), + typing_size Hty < + S + (all_size _ (fun (x : def term) p => typing_size p) a1) -> + Forall_decls_typing P Σ.1 * P Σ Γ0 t T). + {intros. eapply (X14 _ _ _ Hty); eauto. lia. } + clear X14 Hwf Htywf. + clear e decl i a0 Hdecls i0. + remember (fix_context mfix) as mfixcontext. clear Heqmfixcontext. + + induction a1; econstructor; eauto. + ++ split; auto. + eapply (X _ (typing_wf_local p) _ _ p). simpl. lia. + ++ eapply IHa1. intros. + eapply (X _ X0 _ _ Hty). simpl; lia. + + -- clear X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X12. + eapply X11; eauto; clear X11. simpl in *. + * assert(forall Γ0 (t T : term) (Hty : Σ;;; Γ0 |- t : T), + typing_size Hty < + S + (all_size _ (fun (x : def term) p => typing_size p) a1) -> + PΓ Σ Γ0). + {intros. eapply (Htywf _ _ _ Hty); eauto. lia. } + destruct mfix. now rewrite nth_error_nil in e. + depelim a1. + eapply (X _ _ _ t). simpl. lia. + * assert(forall (t T : term) (Hty : Σ;;; Γ |- t : T), + typing_size Hty < + S (all_size (fun x : def term => + ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) (fun (x : def term) (p : ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) => typing_size p.π2) a0) -> - Forall_decls_typing P Σ.1 * P Σ Γ t T). - intros; eauto. eapply (X14 _ _ _ Hty); eauto. lia. - clear X13 X14 a Hdecls. + Forall_decls_typing P Σ.1 * P Σ Γ t T). + intros; eauto. eapply (X14 _ _ _ Hty); eauto. simpl; lia. + clear Hwf Htywf X14 a pΓ Hdecls. clear -a0 X. induction a0; constructor. destruct p as [s Hs]. exists s; split; auto. @@ -1064,13 +1061,14 @@ Proof. * simpl in X14. assert(forall Γ0 : context, wf_local Σ Γ0 -> - forall (t T : term) (Hty : Σ;;; Γ0 |- t : T), + forall (t T : term) (Hty : Σ;;; Γ0 |- t : T), typing_size Hty < S - (all_size _ (fun (x : def term) p => typing_size p) a1) -> - Forall_decls_typing P Σ.1 * P Σ Γ0 t T). + (all_size (fun x : def term => (Σ;;; Γ ,,, fix_context mfix |- dbody x : lift0 #|fix_context mfix| (dtype x))%type) + (fun (x : def term) p => typing_size p) a1) -> + Forall_decls_typing P Σ.1 * P Σ Γ0 t T). {intros. eapply (X14 _ _ _ Hty); eauto. lia. } - clear X14 X13. + clear X14 Hwf Htywf. clear e decl i a0 Hdecls i0. remember (fix_context mfix) as mfixcontext. clear Heqmfixcontext. @@ -1078,67 +1076,29 @@ Proof. ++ split; auto. eapply (X _ (typing_wf_local p) _ _ p). simpl. lia. ++ eapply IHa1. intros. - eapply (X _ X0 _ _ Hty). simpl; lia. - - -- clear X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X12. - eapply X11; eauto; clear X11. simpl in *. - * assert(forall (t T : term) (Hty : Σ;;; Γ |- t : T), - typing_size Hty < - S (all_size (fun x : def term => - ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) - (fun (x : def term) - (p : ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) => - typing_size p.π2) a0) -> - Forall_decls_typing P Σ.1 * P Σ Γ t T). - intros; eauto. eapply (X14 _ _ _ Hty); eauto. lia. - clear X13 X14 a Hdecls. - clear -a0 X. - induction a0; constructor. - destruct p as [s Hs]. exists s; split; auto. - apply (X (dtype x) (tSort s) Hs). simpl. lia. - apply IHa0. intros. eapply (X _ _ Hty); eauto. - simpl. lia. - * simpl in X14. - assert(forall Γ0 : context, - wf_local Σ Γ0 -> - forall (t T : term) (Hty : Σ;;; Γ0 |- t : T), - typing_size Hty < - S - (all_size (fun x : def term => (Σ;;; Γ ,,, fix_context mfix |- dbody x : lift0 #|fix_context mfix| (dtype x))%type) - (fun (x : def term) p => typing_size p) a1) -> - Forall_decls_typing P Σ.1 * P Σ Γ0 t T). - {intros. eapply (X14 _ _ _ Hty); eauto. lia. } - clear X14 X13. - clear e decl i a0 Hdecls i0. - remember (fix_context mfix) as mfixcontext. clear Heqmfixcontext. - - induction a1; econstructor; eauto. - ++ split; auto. - eapply (X _ (typing_wf_local p) _ _ p). simpl. lia. - ++ eapply IHa1. intros. - eapply (X _ X0 _ _ Hty). simpl; lia. + eapply (X _ X0 _ _ Hty). simpl; lia. Qed. Lemma typing_ind_env `{cf : checker_flags} : forall (P : global_env_ext -> context -> term -> term -> Type) (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T) - (PΓ : forall Σ Γ, wf_local Σ Γ -> Type), + (PΓ : global_env_ext -> context -> Type), (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), - All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ wfΓ) -> + All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl, nth_error Γ n = Some decl -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> wf_universe Σ u -> P Σ Γ (tSort u) (tSort (Universe.super u))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 s2 : Universe.t), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- t : tSort s1 -> P Σ Γ t (tSort s1) -> Σ ;;; Γ,, vass n t |- b : tSort s2 -> @@ -1146,14 +1106,14 @@ Lemma typing_ind_env `{cf : checker_flags} : (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 : Universe.t) (bty : term), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- t : tSort s1 -> P Σ Γ t (tSort s1) -> Σ ;;; Γ,, vass n t |- b : bty -> P Σ (Γ,, vass n t) b bty -> P Σ Γ (tLambda n t b) (tProd n t bty)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (b b_ty b' : term) (s1 : Universe.t) (b'_ty : term), - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- b_ty : tSort s1 -> P Σ Γ b_ty (tSort s1) -> Σ ;;; Γ |- b : b_ty -> @@ -1162,7 +1122,7 @@ Lemma typing_ind_env `{cf : checker_flags} : P Σ (Γ,, vdef n b b_ty) b' b'_ty -> P Σ Γ (tLetIn n b b_ty b') (tLetIn n b b_ty b'_ty)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t : term) na A B u s, - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- tProd na A B : tSort s -> P Σ Γ (tProd na A B) (tSort s) -> Σ ;;; Γ |- t : tProd na A B -> P Σ Γ t (tProd na A B) -> Σ ;;; Γ |- u : A -> P Σ Γ u A -> @@ -1170,59 +1130,73 @@ Lemma typing_ind_env `{cf : checker_flags} : (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) cst u (decl : constant_body), Forall_decls_typing P Σ.1 -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> declared_constant Σ.1 cst decl -> consistent_instance_ext Σ decl.(cst_universes) u -> - P Σ Γ (tConst cst u) (subst_instance_constr u (cst_type decl))) -> + P Σ Γ (tConst cst u) (subst_instance u (cst_type decl))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u - mdecl idecl (isdecl : declared_inductive Σ.1 mdecl ind idecl), + mdecl idecl (isdecl : declared_inductive Σ.1 ind mdecl idecl), Forall_decls_typing P Σ.1 -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> consistent_instance_ext Σ mdecl.(ind_universes) u -> - P Σ Γ (tInd ind u) (subst_instance_constr u (ind_type idecl))) -> + P Σ Γ (tInd ind u) (subst_instance u (ind_type idecl))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) (i : nat) u - mdecl idecl cdecl (isdecl : declared_constructor Σ.1 mdecl idecl (ind, i) cdecl), + mdecl idecl cdecl (isdecl : declared_constructor Σ.1 (ind, i) mdecl idecl cdecl), Forall_decls_typing P Σ.1 -> - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> consistent_instance_ext Σ mdecl.(ind_universes) u -> P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) -> - - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u (npar : nat) - (p c : term) (brs : list (nat * term)) - (args : list term) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) - (isdecl : declared_inductive (fst Σ) mdecl ind idecl), - Forall_decls_typing P Σ.1 -> PΓ Σ Γ wfΓ -> - ind_npars mdecl = npar -> - let params := firstn npar args in - forall ps pty, build_case_predicate_type ind mdecl idecl params u ps = Some pty -> - Σ ;;; Γ |- p : pty -> - P Σ Γ p pty -> - is_allowed_elimination (global_ext_constraints Σ) ps idecl.(ind_kelim) -> - Σ ;;; Γ |- c : mkApps (tInd ind u) args -> - isCoFinite mdecl.(ind_finite) = false -> - P Σ Γ c (mkApps (tInd ind u) args) -> - forall btys, map_option_out (build_branches_type ind mdecl idecl params u p) = Some btys -> - All2 (fun br bty => (br.1 = bty.1) * - (Σ ;;; Γ |- br.2 : bty.2) * P Σ Γ br.2 bty.2 * - ∑ s, (Σ ;;; Γ |- bty.2 : tSort s) * P Σ Γ bty.2 (tSort s)) - brs btys -> - P Σ Γ (tCase (ind, npar) p c brs) (mkApps p (skipn npar args ++ [c]))) -> - + + (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 -> + PΓ Σ Γ -> + mdecl.(ind_npars) = ci.(ci_npar) -> + let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in + wf_predicate mdecl idecl p -> + consistent_instance_ext Σ (ind_universes mdecl) p.(puinst) -> + PΓ Σ (Γ ,,, p.(pcontext)) -> + conv_context Σ (Γ ,,, p.(pcontext)) (Γ ,,, predctx) -> + forall pret : Σ ;;; Γ ,,, p.(pcontext) |- p.(preturn) : tSort ps, + P Σ (Γ ,,, p.(pcontext)) p.(preturn) (tSort ps) -> + PΓ Σ (Γ ,,, predctx) -> + is_allowed_elimination Σ ps idecl.(ind_kelim) -> + ctx_inst typing Σ Γ (p.(pparams) ++ indices) + (List.rev (subst_instance p.(puinst) (mdecl.(ind_params) ,,, idecl.(ind_indices)))) -> + ctx_inst 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)) -> + isCoFinite mdecl.(ind_finite) = false -> + let ptm := it_mkLambda_or_LetIn p.(pcontext) p.(preturn) in + wf_branches idecl brs -> + All2i (fun i cdecl br => + let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in + (PΓ Σ (Γ ,,, br.(bcontext)) * + conv_context Σ (Γ ,,, br.(bcontext)) (Γ ,,, brctxty.1)) × + ((Σ ;;; Γ ,,, br.(bcontext) |- br.(bbody) : brctxty.2) * + PΓ Σ (Γ ,,, brctxty.1) * + (P Σ (Γ ,,, br.(bcontext)) br.(bbody) brctxty.2 * + ((Σ ;;; Γ ,,, br.(bcontext) |- brctxty.2 : tSort ps) * + P Σ (Γ ,,, br.(bcontext)) 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 pdecl (isdecl : declared_projection Σ.1 mdecl idecl p pdecl) args, - Forall_decls_typing P Σ.1 -> PΓ Σ Γ wfΓ -> + mdecl idecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl pdecl) args, + Forall_decls_typing P Σ.1 -> PΓ Σ Γ -> Σ ;;; Γ |- c : mkApps (tInd (fst (fst p)) u) args -> P Σ Γ c (mkApps (tInd (fst (fst p)) u) args) -> #|args| = ind_npars mdecl -> - let ty := snd pdecl in P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (subst_instance_constr u ty))) -> + let ty := snd pdecl in P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (subst_instance u ty))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (mfix : list (def term)) (n : nat) decl, let types := fix_context mfix in fix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> - PΓ Σ Γ wfΓ -> + PΓ Σ (Γ ,,, types) -> All (fun d => {s & (Σ ;;; Γ |- d.(dtype) : tSort s)%type * P Σ Γ d.(dtype) (tSort s)})%type mfix -> All (fun d => (Σ ;;; Γ ,,, types |- d.(dbody) : lift0 #|types| d.(dtype))%type * P Σ (Γ ,,, types) d.(dbody) (lift0 #|types| d.(dtype)))%type mfix -> @@ -1233,7 +1207,7 @@ Lemma typing_ind_env `{cf : checker_flags} : let types := fix_context mfix in cofix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> - PΓ Σ Γ wfΓ -> + PΓ Σ (Γ ,,, types) -> All (fun d => {s & (Σ ;;; Γ |- d.(dtype) : tSort s)%type * P Σ Γ d.(dtype) (tSort s)})%type mfix -> All (fun d => (Σ ;;; Γ ,,, types |- d.(dbody) : lift0 #|types| d.(dtype))%type * P Σ (Γ ,,, types) d.(dbody) (lift0 #|types| d.(dtype)))%type mfix -> @@ -1241,7 +1215,7 @@ Lemma typing_ind_env `{cf : checker_flags} : P Σ Γ (tCoFix mfix n) decl.(dtype)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, - PΓ Σ Γ wfΓ -> + PΓ Σ Γ -> Σ ;;; Γ |- t : A -> P Σ Γ t A -> Σ ;;; Γ |- B : tSort s -> @@ -1261,6 +1235,7 @@ Ltac my_rename_hyp h th := | (wf ?E) => fresh "wf" E | (wf (fst_ctx ?E)) => fresh "wf" E | (wf _) => fresh "wf" + | consistent_instance_ext _ _ ?cu => fresh "cu" cu | (typing _ _ ?t _) => fresh "type" t | (@cumul _ _ _ ?t _) => fresh "cumul" t | (conv _ _ ?t _) => fresh "conv" t @@ -1393,6 +1368,15 @@ Section All_local_env. now split; [eapply wf_local_local_rel|]. Qed. + Lemma wf_local_app_ind {Σ Γ1 Γ2} : + wf_local Σ Γ1 -> + (wf_local Σ Γ1 -> wf_local_rel Σ Γ1 Γ2) -> + wf_local Σ (Γ1 ,,, Γ2). + Proof. + intros wf IH. + apply wf_local_app; auto. + Qed. + Lemma All_local_env_map (P : context -> term -> option term -> Type) f l : (forall u, f (tSort u) = tSort u) -> All_local_env (fun Γ t T => P (map (map_decl f) Γ) (f t) (option_map f T)) l diff --git a/pcuic/theories/PCUICUnivSubst.v b/pcuic/theories/PCUICUnivSubst.v index 857c69f5e..62b5d4c57 100644 --- a/pcuic/theories/PCUICUnivSubst.v +++ b/pcuic/theories/PCUICUnivSubst.v @@ -1,134 +1,113 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICInduction PCUICLiftSubst. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction. -(** * Universe substitution +Instance subst_instance_list A `{UnivSubst A} : UnivSubst (list A) := + fun u => List.map (subst_instance u). - Substitution of universe levels for universe level variables, used to - implement universe polymorphism. *) +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) : + subst_instance u (x :: xs) = subst_instance u x :: subst_instance u xs. +Proof. reflexivity. Qed. -Instance subst_instance_constr : UnivSubst term := - fix subst_instance_constr u c {struct c} : term := - match c with - | tRel _ | tVar _ => c - | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) - | tSort s => tSort (subst_instance_univ u s) - | tConst c u' => tConst c (subst_instance_instance u u') - | tInd i u' => tInd i (subst_instance_instance u u') - | tConstruct ind k u' => tConstruct ind k (subst_instance_instance u u') - | tLambda na T M => tLambda na (subst_instance_constr u T) (subst_instance_constr u M) - | tApp f v => tApp (subst_instance_constr u f) (subst_instance_constr u v) - | tProd na A B => tProd na (subst_instance_constr u A) (subst_instance_constr u B) - | tLetIn na b ty b' => tLetIn na (subst_instance_constr u b) (subst_instance_constr u ty) - (subst_instance_constr u b') - | tCase ind p c brs => - let brs' := List.map (on_snd (subst_instance_constr u)) brs in - tCase ind (subst_instance_constr u p) (subst_instance_constr u c) brs' - | tProj p c => tProj p (subst_instance_constr u c) - | tFix mfix idx => - let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in - tCoFix mfix' idx - | tPrim _ => c - end. - -Instance subst_instance_decl : UnivSubst context_decl - := map_decl ∘ subst_instance_constr. - -Instance subst_instance_context : UnivSubst context - := map_context ∘ subst_instance_constr. - -Lemma lift_subst_instance_constr u c n k : - lift n k (subst_instance_constr u c) = subst_instance_constr u (lift n k c). +Lemma subst_instance_lift u c n k : + subst_instance u (lift n k c) = lift n k (subst_instance u c). 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; + autorewrite with map; try solve [f_equal; eauto; solve_all; eauto]. Qed. -Lemma subst_instance_constr_mkApps u f a : - subst_instance_constr u (mkApps f a) = - mkApps (subst_instance_constr u f) (map (subst_instance_constr u) a). +Lemma subst_instance_mkApps u f a : + subst_instance u (mkApps f a) = + mkApps (subst_instance u f) (map (subst_instance u) a). Proof. induction a in f |- *; auto. simpl map. simpl. now rewrite IHa. Qed. -Lemma subst_instance_constr_it_mkProd_or_LetIn u ctx t : - subst_instance_constr u (it_mkProd_or_LetIn ctx t) = - it_mkProd_or_LetIn (subst_instance_context u ctx) (subst_instance_constr u t). +Lemma subst_instance_it_mkProd_or_LetIn u ctx t : + subst_instance u (it_mkProd_or_LetIn ctx t) = + it_mkProd_or_LetIn (subst_instance u ctx) (subst_instance u t). Proof. + unfold subst_instance; cbn. induction ctx in u, t |- *; simpl; unfold mkProd_or_LetIn; try congruence. rewrite IHctx. f_equal; unfold mkProd_or_LetIn. destruct a as [na [b|] ty]; simpl; eauto. Qed. -Lemma subst_instance_context_length u ctx - : #|subst_instance_context u ctx| = #|ctx|. -Proof. unfold subst_instance_context, map_context. now rewrite map_length. Qed. +Lemma subst_instance_it_mkLambda_or_LetIn u ctx t : + subst_instance u (it_mkLambda_or_LetIn ctx t) = + it_mkLambda_or_LetIn (subst_instance u ctx) (subst_instance u t). +Proof. + unfold subst_instance; cbn. + induction ctx in u, t |- *; simpl; unfold mkProd_or_LetIn; try congruence. + rewrite IHctx. f_equal; unfold mkProd_or_LetIn. + destruct a as [na [b|] ty]; simpl; eauto. +Qed. -Lemma subst_subst_instance_constr u c N k : - subst (map (subst_instance_constr u) N) k (subst_instance_constr u c) - = subst_instance_constr u (subst N k c). +Lemma subst_instance_subst u c (s : list term) k : + subst_instance u (subst s k c) = subst (subst_instance u s) k (subst_instance u c). Proof. + unfold subst_instance, subst_instance_list; cbn. induction c in k |- * using term_forall_list_ind; simpl; auto; - rewrite ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + autorewrite with map; try solve [f_equal; eauto; solve_all; eauto]. - elim (Nat.leb k n). rewrite nth_error_map. - destruct (nth_error N (n - k)). simpl. - apply lift_subst_instance_constr. reflexivity. reflexivity. + elim (Nat.leb k n); auto. + rewrite nth_error_map. + destruct (nth_error s (n - k)). simpl. + now rewrite subst_instance_lift. reflexivity. Qed. -Lemma map_subst_instance_constr_to_extended_list_k u ctx k : - map (subst_instance_constr u) (to_extended_list_k ctx k) +Lemma map_subst_instance_to_extended_list_k u ctx k : + map (subst_instance u) (to_extended_list_k ctx k) = to_extended_list_k ctx k. Proof. pose proof (to_extended_list_k_spec ctx k). solve_all. now destruct H as [n [-> _]]. Qed. -(** Tests that the term is closed over [k] universe variables *) -Fixpoint closedu (k : nat) (t : term) : bool := - match t with - | tSort univ => closedu_universe k univ - | tInd _ u => closedu_instance k u - | tConstruct _ _ u => closedu_instance k u - | tConst _ u => closedu_instance k u - | tRel i => true - | tEvar ev args => forallb (closedu k) args - | tLambda _ T M | tProd _ T M => closedu k T && closedu k M - | tApp u v => closedu k u && closedu k v - | tLetIn na b t b' => closedu k b && closedu k t && closedu k b' - | tCase ind p c brs => - let brs' := forallb (test_snd (closedu k)) brs in - closedu k p && closedu k c && brs' - | tProj p c => closedu k c - | tFix mfix idx => - forallb (test_def (closedu k) (closedu k)) mfix - | tCoFix mfix idx => - forallb (test_def (closedu k) (closedu k)) mfix - | x => true - end. - -Lemma closedu_subst_instance_constr u t - : closedu 0 t -> subst_instance_constr u t = t. +Lemma closedu_subst_instance u t + : closedu 0 t -> subst_instance u t = t. Proof. + unfold subst_instance; cbn. induction t in |- * using term_forall_list_ind; simpl; auto; intros H'; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; - try f_equal; eauto with substu; unfold test_def in *; - try solve [f_equal; eauto; repeat (rtoProp; solve_all)]. + autorewrite with map; + try f_equal; eauto with substu; unfold test_predicate, test_branch, test_def in *; + try solve [f_equal; eauto; repeat (rtoProp; solve_all); eauto with substu]. Qed. -Lemma subst_instance_constr_closedu (u : Instance.t) (Hcl : closedu_instance 0 u) t : - closedu #|u| t -> closedu 0 (subst_instance_constr u t). +Lemma subst_instance_closedu (u : Instance.t) (Hcl : closedu_instance 0 u) t : + closedu #|u| t -> closedu 0 (subst_instance u t). Proof. induction t in |- * using term_forall_list_ind; simpl; auto; intros H'; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?forallb_map; + autorewrite with map; try f_equal; auto with substu; - unfold test_def, map_def in *; - try solve [f_equal; eauto; repeat (rtoProp; solve_all); intuition auto with substu]. + unfold test_def, test_predicate, test_branch in *; simpl; + f_equal; eauto; repeat (rtoProp; solve_all); intuition auto with substu. +Qed. + +Lemma rev_subst_instance {u Γ} : + List.rev (subst_instance u Γ) = subst_instance u (List.rev Γ). +Proof. + unfold subst_instance, subst_instance_context, map_context. + now rewrite map_rev. +Qed. + +Lemma subst_instance_extended_subst u Γ n : + map (subst_instance u) (extended_subst Γ n) = + extended_subst (subst_instance u Γ) n. +Proof. + induction Γ as [|[?[]?] ?] in n |- *; simpl; auto. + - autorewrite with len. + f_equal; auto. + rewrite subst_instance_subst, <-IHΓ. + rewrite <-subst_instance_lift; simpl. + f_equal. + - f_equal; auto. Qed. diff --git a/pcuic/theories/PCUICUnivSubstitution.v b/pcuic/theories/PCUICUnivSubstitution.v index a3e6e7679..5b3de6ae8 100644 --- a/pcuic/theories/PCUICUnivSubstitution.v +++ b/pcuic/theories/PCUICUnivSubstitution.v @@ -1,9 +1,10 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import CRelationClasses. +From Coq Require Import ssreflect CRelationClasses. From MetaCoq.Template Require Import utils config Universes uGraph. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction - PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICTyping PCUICWeakeningEnv - PCUICClosed PCUICPosition PCUICWeakening. + PCUICLiftSubst PCUICEquality PCUICUnivSubst + PCUICCases PCUICContextRelation PCUICTyping PCUICWeakeningEnv + PCUICClosed PCUICPosition. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. @@ -33,7 +34,7 @@ Lemma eq_val v v' Proof. intros []; cbnr. f_equal. assert (He : forall e : UnivExpr.t, val v e = val v' e). { - intros [[] b]; cbnr; rewrite ?H1, ?H2; reflexivity. }+ + intros [[] b]; cbnr; rewrite ?H1 ?H2; reflexivity. } rewrite !val_fold_right. induction ((List.rev (Universe.exprs t).2)); cbn; congruence. Qed. @@ -103,8 +104,8 @@ Class SubstUnivPreserving Re := Build_SubstUnivPreserving : Lemma subst_equal_inst_inst Re : SubstUnivPreserving Re -> forall u u1 u2, R_universe_instance Re u1 u2 -> - R_universe_instance Re (subst_instance_instance u1 u) - (subst_instance_instance u2 u). + R_universe_instance Re (subst_instance u1 u) + (subst_instance u2 u). Proof. intros hRe u. induction u; cbnr; try now constructor. intros u1 u2; unfold R_universe_instance; cbn; constructor. @@ -118,8 +119,8 @@ Lemma subst_equal_inst_global_inst Σ Re Rle gr napp : SubstUnivPreserving Re -> RelationClasses.subrelation Re Rle -> forall u u1 u2, R_universe_instance Re u1 u2 -> - R_global_instance Σ Re Rle gr napp (subst_instance_instance u1 u) - (subst_instance_instance u2 u). + R_global_instance Σ Re Rle gr napp (subst_instance u1 u) + (subst_instance u2 u). Proof. intros reflRe hRe subr u u1 u2 Ru1u2. unfold R_global_instance, R_opt_variance. @@ -134,14 +135,14 @@ Proof. now rewrite !subst_instance_univ_make in HH. Qed. -Lemma eq_term_upto_univ_subst_instance_constr Σ Re Rle napp : +Lemma eq_term_upto_univ_subst_instance Σ Re Rle napp : RelationClasses.Reflexive Re -> SubstUnivPreserving Re -> RelationClasses.subrelation Re Rle -> forall t u1 u2, R_universe_instance Re u1 u2 -> - eq_term_upto_univ_napp Σ Re Rle napp (subst_instance_constr u1 t) - (subst_instance_constr u2 t). + eq_term_upto_univ_napp Σ Re Rle napp (subst_instance u1 t) + (subst_instance u2 t). Proof. intros ref hRe subr t. induction t in napp, Re, Rle, ref, hRe, subr |- * using term_forall_list_ind; intros u1 u2 hu. @@ -149,6 +150,29 @@ Proof. all: try eapply All2_map, All_All2; tea; cbn; intros; rdest; eauto. all: try (eapply X0 || eapply IHt || eapply IHt1 || eapply IHt2 || eapply e || eapply e0); try typeclasses eauto; auto. all: eauto using subst_equal_inst_global_inst. + - rewrite /eq_predicate /=. intuition auto. + * solve_all. eapply All_All2; tea; cbn; intros; rdest; eauto. + eapply X; eauto. tc. + * eapply subst_equal_inst_inst => //. + * solve_all. eapply All2_fold_map. + clear -hu ref hRe subr a0. + unfold ondecl in a0. + induction a0; try constructor; auto. + destruct x as [na [b|] ty]; constructor; rewrite /map_decl /=; + simpl in p0; solve_all; intuition eauto. + + eapply b0; eauto; tc. + + eapply a; eauto; tc. + + eapply a; eauto; tc. + * eapply X => //. + - solve_all. eapply All2_fold_map. + clear -hu ref hRe subr a. + unfold ondecl in a. + induction a; try constructor; auto. + destruct x0 as [na [b'|] ty]; constructor; rewrite /map_decl /=; + simpl in p; solve_all; intuition eauto. + + eapply b; eauto; tc. + + eapply a0; eauto; tc. + + eapply a0; eauto; tc. Qed. Instance eq_universe_SubstUnivPreserving {cf:checker_flags} φ : @@ -162,7 +186,7 @@ Proof. destruct e as [[] b]; cbnr. case_eq (nth_error u1 n). - intros l1 X. eapply Forall2_nth_error_Some_l in hu. - 2: now rewrite nth_error_map, X. + 2: now rewrite -> nth_error_map, X. destruct hu as [l2 [H1 H2]]. rewrite nth_error_map in H1. destruct (nth_error u2 n) as [l2'|]; [|discriminate]. @@ -170,7 +194,7 @@ Proof. specialize (H2 v Hv). destruct l1, l2'; cbn in *; noconf H2; try lia. - intros X. eapply Forall2_nth_error_None_l in hu. - 2: now rewrite nth_error_map, X. + 2: now rewrite -> nth_error_map, X. rewrite nth_error_map in hu. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. @@ -199,7 +223,7 @@ Proof. destruct e as [[] b]; cbnr. case_eq (nth_error u1 n). - intros l1 X. eapply Forall2_nth_error_Some_l in hu. - 2: now rewrite nth_error_map, X. + 2: now rewrite -> nth_error_map, X. destruct hu as [l2 [H1 H2]]. rewrite nth_error_map in H1. destruct (nth_error u2 n) as [l2'|]; [|discriminate]. @@ -207,7 +231,7 @@ Proof. specialize (H2 v Hv). destruct l1, l2'; cbn in *; noconf H2; try lia. - intros X. eapply Forall2_nth_error_None_l in hu. - 2: now rewrite nth_error_map, X. + 2: now rewrite -> nth_error_map, X. rewrite nth_error_map in hu. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. @@ -234,43 +258,39 @@ Qed. Section CheckerFlags. -Global Instance subst_instance_list {A} `(UnivSubst A) : UnivSubst (list A) - := fun u => map (subst_instance u). - Global Instance subst_instance_def {A} `(UnivSubst A) : UnivSubst (def A) := fun u => map_def (subst_instance u) (subst_instance u). Global Instance subst_instance_prod {A B} `(UnivSubst A) `(UnivSubst B) : UnivSubst (A × B) - := fun u => on_pair (subst_instance u) (subst_instance u). + := fun u => map_pair (subst_instance u) (subst_instance u). Global Instance subst_instance_nat : UnivSubst nat := fun _ n => n. - - -Lemma subst_instance_instance_length u1 u2 : - #|subst_instance_instance u2 u1| = #|u1|. +Lemma subst_instance_instance_length (u1 : Instance.t) u2 : + #|subst_instance u2 u1| = #|u1|. Proof. - unfold subst_instance_instance. + unfold subst_instance. now rewrite map_length. Qed. +Hint Rewrite subst_instance_instance_length : len. Lemma subst_instance_level_two u1 u2 l : subst_instance_level u1 (subst_instance_level u2 l) - = subst_instance_level (subst_instance_instance u1 u2) l. + = subst_instance_level (subst_instance u1 u2) l. Proof. destruct l; cbn; try reflexivity. - unfold subst_instance_instance. + unfold subst_instance. rewrite <- (map_nth (subst_instance_level u1)); reflexivity. Qed. Lemma subst_instance_level_expr_two u1 u2 e : subst_instance_level_expr u1 (subst_instance_level_expr u2 e) - = subst_instance_level_expr (subst_instance_instance u1 u2) e. + = subst_instance_level_expr (subst_instance u1 u2) e. Proof. destruct e as [[] b]; cbnr. - unfold subst_instance_instance. erewrite nth_error_map. + unfold subst_instance. erewrite nth_error_map. destruct nth_error; cbnr. destruct t; cbnr. rewrite nth_nth_error. destruct nth_error; cbnr. @@ -278,7 +298,7 @@ Qed. Lemma subst_instance_univ_two u1 u2 s : subst_instance_univ u1 (subst_instance_univ u2 s) - = subst_instance_univ (subst_instance_instance u1 u2) s. + = subst_instance_univ (subst_instance u1 u2) s. Proof. unfold subst_instance_univ. destruct s; cbnr. f_equal. @@ -291,46 +311,48 @@ Proof. apply Universe.map_spec. eexists; split; tea; reflexivity. Qed. -Lemma subst_instance_instance_two u1 u2 u : - subst_instance_instance u1 (subst_instance_instance u2 u) - = subst_instance_instance (subst_instance_instance u1 u2) u. +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. - unfold subst_instance_instance. rewrite map_map. + rewrite /subst_instance /= /subst_instance_instance. + rewrite map_map. apply map_ext, subst_instance_level_two. Qed. -Lemma subst_instance_constr_two u1 u2 t : - subst_instance_constr u1 (subst_instance_constr u2 t) - = subst_instance_constr (subst_instance_instance u1 u2) t. +Lemma subst_instance_two u1 u2 (t : term) : + subst_instance u1 (subst_instance u2 t) + = subst_instance (subst_instance u1 u2) t. Proof. + rewrite /subst_instance /=. induction t using term_forall_list_ind; cbn; f_equal; - auto using subst_instance_instance_two. + auto using subst_instance_two_instance. - rewrite map_map. now apply All_map_eq. - apply subst_instance_univ_two. - - rewrite map_map. apply All_map_eq. - eapply All_impl; tea. - cbn. intros [? ?]; unfold on_snd; cbn; congruence. - - rewrite map_map. apply All_map_eq. - eapply All_impl; tea. - cbn. intros [? ? ?] [? ?]; cbn in *. unfold map_def; cbn; congruence. - - rewrite map_map. apply All_map_eq. - eapply All_impl; tea. - cbn. intros [? ? ?] [? ?]; cbn in *. unfold map_def; cbn; congruence. + - destruct X; red in X0. rewrite map_predicate_map_predicate. + apply map_predicate_eq_spec; solve_all. + now rewrite [subst_instance_instance _ _]subst_instance_two_instance. + - rewrite map_map. apply All_map_eq. red in X0. solve_all. + - rewrite map_map. apply All_map_eq. solve_all. + rewrite map_def_map_def; solve_all. + - rewrite map_map. apply All_map_eq. solve_all. + rewrite map_def_map_def; solve_all. Qed. -Lemma subst_instance_context_two u1 u2 Γ : - subst_instance_context u1 (subst_instance_context u2 Γ) - = subst_instance_context (subst_instance_instance u1 u2) Γ. +Lemma subst_instance_two_context u1 u2 (Γ : context) : + subst_instance u1 (subst_instance u2 Γ) + = subst_instance (subst_instance u1 u2) Γ. Proof. + rewrite /subst_instance /=. induction Γ; try reflexivity. simpl. rewrite IHΓ; f_equal. destruct a as [? [] ?]; unfold map_decl; cbn; - now rewrite !subst_instance_constr_two. + now rewrite !subst_instance_two. Qed. Lemma subst_instance_cstr_two u1 u2 c : subst_instance_cstr u1 (subst_instance_cstr u2 c) - = subst_instance_cstr (subst_instance_instance u1 u2) c. + = subst_instance_cstr (subst_instance u1 u2) c. Proof. destruct c as [[? ?] ?]; unfold subst_instance_cstr; cbn. now rewrite !subst_instance_level_two. @@ -381,7 +403,7 @@ Qed. Lemma subst_instance_cstrs_two u1 u2 ctrs : CS.Equal (subst_instance_cstrs u1 (subst_instance_cstrs u2 ctrs)) - (subst_instance_cstrs (subst_instance_instance u1 u2) ctrs). + (subst_instance_cstrs (subst_instance u1 u2) ctrs). Proof. intro c; split; intro Hc; apply In_subst_instance_cstrs. - apply In_subst_instance_cstrs in Hc; destruct Hc as [c' [eq Hc']]. @@ -660,7 +682,7 @@ Lemma consistent_ext_trans_polymorphic_case_aux {Σ φ1 φ2 φ' udecl inst inst' (subst_instance_cstrs inst' φ2) -> valid_constraints0 (global_ext_constraints (Σ, φ')) (subst_instance_cstrs - (subst_instance_instance inst' inst) udecl). + (subst_instance inst' inst) udecl). Proof. intros [HΣ Hφ] H3 H2. intros v Hv. rewrite <- subst_instance_cstrs_two. @@ -678,7 +700,7 @@ Lemma consistent_ext_trans_polymorphic_cases Σ φ φ' udecl inst inst' : consistent_instance_ext (Σ, φ) (Polymorphic_ctx udecl) inst -> consistent_instance_ext (Σ, φ') φ inst' -> consistent_instance_ext (Σ, φ') (Polymorphic_ctx udecl) - (subst_instance_instance inst' inst). + (subst_instance inst' inst). Proof. intros HΣφ Hφ [H [H0 H1]] H2. repeat split. @@ -723,18 +745,17 @@ Lemma consistent_ext_trans Σ φ φ' udecl inst inst' : sub_context_set (monomorphic_udecl φ) (global_ext_context_set (Σ, φ')) -> consistent_instance_ext (Σ, φ) udecl inst -> consistent_instance_ext (Σ, φ') φ inst' -> - consistent_instance_ext (Σ, φ') udecl (subst_instance_instance inst' inst). + consistent_instance_ext (Σ, φ') udecl (subst_instance inst' inst). Proof. intros HΣφ Hφ H1 H2. destruct udecl as [?|udecl]. - (* udecl monomorphic *) - cbn; now rewrite subst_instance_instance_length. + cbn; now len. - (* udecl polymorphic *) eapply consistent_ext_trans_polymorphic_cases; eassumption. Qed. Hint Resolve consistent_ext_trans : univ_subst. - Lemma consistent_instance_valid_constraints Σ φ u univs : wf_ext_wk (Σ, φ) -> CS.Subset (monomorphic_constraints φ) @@ -785,7 +806,7 @@ Global Instance leq_universe_subst_instance : SubstUnivPreserved leq_universe. Proof. intros φ φ' u HH t t' Htt'. unfold leq_universe in *; case_eq check_univs; - [intro Hcf; rewrite Hcf in *|trivial]. + [intro Hcf; rewrite Hcf in Htt'|trivial]. intros v Hv; cbn. rewrite !subst_instance_univ_val'; tas. apply Htt'. clear t t' Htt'. @@ -796,18 +817,18 @@ Global Instance eq_universe_subst_instance : SubstUnivPreserved eq_universe. Proof. intros φ φ' u HH t t' Htt'. unfold eq_universe in *; case_eq check_univs; - [intro Hcf; rewrite Hcf in *|trivial]. + [intro Hcf; rewrite Hcf in Htt'|trivial]. intros v Hv; cbn. rewrite !subst_instance_univ_val'; tas. apply Htt'. clear t t' Htt'. eapply satisfies_subst_instance; tea. Qed. -Lemma precompose_subst_instance_instance Rle u i i' : - precompose (R_universe_instance Rle) (subst_instance_instance u) i i' +Lemma precompose_subst_instance Rle u i i' : + precompose (R_universe_instance Rle) (subst_instance u) i i' <~> R_universe_instance (precompose Rle (subst_instance_univ u)) i i'. Proof. - unfold R_universe_instance, subst_instance_instance. + unfold R_universe_instance, subst_instance. replace (map Universe.make (map (subst_instance_level u) i)) with (map (subst_instance_univ u) (map Universe.make i)). 1: replace (map Universe.make (map (subst_instance_level u) i')) @@ -819,11 +840,11 @@ Proof. all: intro; apply subst_instance_univ_make. Qed. -Definition precompose_subst_instance_instance__1 Rle u i i' - := fst (precompose_subst_instance_instance Rle u i i'). +Definition precompose_subst_instance__1 Rle u i i' + := fst (precompose_subst_instance Rle u i i'). -Definition precompose_subst_instance_instance__2 Rle u i i' - := snd (precompose_subst_instance_instance 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 : subst_instance_level_expr u (UnivExpr.make l) = UnivExpr.make (subst_instance_level u l). @@ -836,16 +857,16 @@ Lemma subst_instance_make'_make u l : subst_instance u (Universe.make' (UnivExpr.make l)) = Universe.make' (UnivExpr.make (subst_instance_level u l)). Proof. - now rewrite subst_instance_univ_make', subst_instance_level_expr_make. + now rewrite subst_instance_univ_make' subst_instance_level_expr_make. Qed. Lemma precompose_subst_instance_global Σ Re Rle gr napp u i i' : - precompose (R_global_instance Σ Re Rle gr napp) (subst_instance_instance u) i i' + precompose (R_global_instance Σ Re Rle gr napp) (subst_instance u) i i' <~> R_global_instance Σ (precompose Re (subst_instance_univ u)) (precompose Rle (subst_instance_univ u)) gr napp i i'. Proof. - unfold R_global_instance, R_opt_variance, subst_instance_instance. - destruct global_variance as [v|]; eauto using precompose_subst_instance_instance. + unfold R_global_instance, R_opt_variance, subst_instance. + destruct global_variance as [v|]; eauto using precompose_subst_instance. induction i in i', v |- *; destruct i', v; simpl; try split; auto. - destruct (IHi i' []). intros; auto. - destruct (IHi i' []). intros; auto. @@ -865,9 +886,9 @@ Definition precompose_subst_instance_global__1 Σ Re Rle gr napp u i i' Definition precompose_subst_instance_global__2 Σ Re Rle gr napp u i i' := snd (precompose_subst_instance_global Σ Re Rle gr napp u i i'). -Global Instance eq_term_upto_univ_subst_instance Σ - (Re Rle : ConstraintSet.t -> Universe.t -> Universe.t -> Prop) napp - {he: SubstUnivPreserved Re} {hle: SubstUnivPreserved Rle} +Global Instance eq_term_upto_univ_subst_preserved Σ + (Re Rle : ConstraintSet.t -> Universe.t -> Universe.t -> Prop) napp + {he: SubstUnivPreserved Re} {hle: SubstUnivPreserved Rle} : SubstUnivPreserved (fun φ => eq_term_upto_univ_napp Σ (Re φ) (Rle φ) napp). Proof. intros φ φ' u HH t t'. @@ -876,7 +897,7 @@ Proof. clear HH. induction t in napp, t', Rle, hle |- * using term_forall_list_ind; inversion 1; subst; cbn; constructor; - eauto using precompose_subst_instance_instance__2, R_universe_instance_impl'. + eauto using precompose_subst_instance__2, R_universe_instance_impl'. all: try (apply All2_map; eapply All2_impl'; tea; eapply All_impl; eauto; cbn; intros; aa). - inv X. @@ -885,6 +906,20 @@ Proof. - inv X. eapply precompose_subst_instance_global__2. eapply R_global_instance_impl_same_napp; eauto. + - destruct X2 as [? [? [? ?]]]. + repeat split; simpl; eauto; solve_all. + * eapply precompose_subst_instance. + eapply R_universe_instance_impl; eauto. + * eapply All2_fold_map. + clear -he hle a0 a2 e. + eapply All2_fold_impl_onctx; tea; solve_all. + eapply compare_decl_map. + eapply compare_decl_impl_ondecl; tea; intuition auto. + - clear -he hle a a0. + eapply All2_fold_map. + eapply All2_fold_impl_onctx; tea; solve_all. + eapply compare_decl_map. + eapply compare_decl_impl_ondecl; tea; intuition auto. Qed. Lemma leq_term_subst_instance Σ : SubstUnivPreserved (leq_term Σ). @@ -971,41 +1006,64 @@ Proof. apply sup_subst_instance_univ0. Qed. -Lemma iota_red_subst_instance pars c args brs u : - subst_instance_constr u (iota_red pars c args brs) - = iota_red pars c (subst_instance u args) (subst_instance u brs). +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. + - rewrite [subst_instance_constr _ _]subst_instance_subst -IHΓ. f_equal. + now rewrite subst_instance_lift. + - rewrite !(lift_extended_subst _ 1). + rewrite map_map_compose. + setoid_rewrite subst_instance_lift. + now rewrite -map_map_compose IHΓ. +Qed. +Hint Rewrite subst_instance_extended_subst : substu. + +Lemma expand_lets_subst_instance u Γ t : + subst_instance u (expand_lets Γ t) = + expand_lets (subst_instance u Γ) (subst_instance u t). +Proof. + rewrite /expand_lets /expand_lets_k. + rewrite subst_instance_subst subst_instance_lift. + now rewrite subst_instance_extended_subst /=; len. +Qed. +Hint Rewrite expand_lets_subst_instance : substu. + +Lemma iota_red_subst_instance pars args br u : + subst_instance u (iota_red pars args br) + = iota_red pars (map (subst_instance u) args) (map_branch (subst_instance u) br). Proof. - unfold iota_red. rewrite !subst_instance_constr_mkApps. - f_equal; simpl; eauto using map_skipn. - rewrite nth_map; simpl; auto. + unfold iota_red. + rewrite subst_instance_subst -map_skipn -map_rev. + f_equal. now rewrite expand_lets_subst_instance. Qed. -Lemma fix_subst_subst_instance u mfix : - map (subst_instance_constr u) (fix_subst mfix) - = fix_subst (subst_instance u mfix). +Lemma fix_subst_instance_subst u mfix : + subst_instance u (fix_subst mfix) = fix_subst (subst_instance u mfix). Proof. + rewrite /subst_instance /subst_instance_list. unfold fix_subst. rewrite map_length. generalize #|mfix|. induction n. 1: reflexivity. simpl. rewrite IHn; reflexivity. Qed. - -Lemma cofix_subst_subst_instance u mfix : - map (subst_instance_constr u) (cofix_subst mfix) - = cofix_subst (subst_instance u mfix). +Lemma cofix_subst_instance_subst u mfix : + subst_instance u (cofix_subst mfix) = cofix_subst (subst_instance u mfix). Proof. + rewrite /subst_instance /subst_instance_list. unfold cofix_subst. rewrite map_length. generalize #|mfix|. induction n. 1: reflexivity. simpl. rewrite IHn; reflexivity. Qed. - Lemma isConstruct_app_subst_instance u t : - isConstruct_app (subst_instance_constr u t) = isConstruct_app t. + isConstruct_app (subst_instance u t) = isConstruct_app t. Proof. unfold isConstruct_app. - assert (HH: (decompose_app (subst_instance_constr u t)).1 - = subst_instance_constr u (decompose_app t).1). { + assert (HH: (decompose_app (subst_instance u t)).1 + = subst_instance u (decompose_app t).1). { unfold decompose_app. generalize (@nil term) at 1. generalize (@nil term). induction t; cbn; try reflexivity. intros l l'. erewrite IHt1; reflexivity. } @@ -1013,94 +1071,405 @@ Proof. Qed. Lemma fix_context_subst_instance u mfix : - subst_instance_context u (fix_context mfix) + subst_instance u (fix_context mfix) = fix_context (subst_instance u mfix). Proof. - unfold subst_instance_context, map_context, fix_context. + rewrite /subst_instance /= /subst_instance /subst_instance_context /map_context /fix_context. rewrite map_rev. f_equal. - rewrite map_mapi, mapi_map. eapply mapi_ext. + rewrite map_mapi mapi_map. eapply mapi_ext. intros n x. unfold map_decl, vass; cbn. f_equal. - symmetry; apply lift_subst_instance_constr. + apply subst_instance_lift. +Qed. + +Lemma subst_instance_app {A} {au : UnivSubst A} u (L1 L2 : list A) : + subst_instance u (L1 ++ L2) + = subst_instance u L1 ++ subst_instance u L2. +Proof. + rewrite /subst_instance /= /subst_instance_list /=. + now rewrite map_app. +Qed. + +Lemma subst_instance_app_ctx u (L1 L2 : context) : + subst_instance u (L1 ,,, L2) + = subst_instance u L1 ,,, subst_instance u L2. +Proof. + rewrite /app_context. now apply subst_instance_app. +Qed. + +Global Instance subst_instance_predicate : UnivSubst (predicate term) + := fun u => map_predicate (subst_instance u) (subst_instance u) + (subst_instance u). + +Definition map_constructor_body' f c := + {| cstr_name := cstr_name c; + cstr_args := map_context f (cstr_args c); + cstr_indices := map f (cstr_indices c); + cstr_type := f (cstr_type c); + cstr_arity := cstr_arity 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); + ind_indices := map_context f oib.(ind_indices); + ind_sort := fu oib.(ind_sort); + ind_type := f oib.(ind_type); + ind_kelim := oib.(ind_kelim); + ind_ctors := map (map_constructor_body' f) oib.(ind_ctors); + ind_projs := map (on_snd f) oib.(ind_projs); + ind_relevance := oib.(ind_relevance) |}. + +Global Instance subst_instance_inductive_body : UnivSubst one_inductive_body + := fun u => map_one_inductive_body' (subst_instance u) (subst_instance u). + +Definition map_mutual_inductive_body' fu f mib := + {| ind_finite := mib.(ind_finite); + ind_npars := mib.(ind_npars); + ind_params := map_context f mib.(ind_params); + ind_bodies := map (map_one_inductive_body' fu f) mib.(ind_bodies); + ind_universes := mib.(ind_universes); + ind_variance := mib.(ind_variance) |}. + +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 : + cstr_args (subst_instance u cdecl) = + subst_instance u (cstr_args cdecl). +Proof. reflexivity. Qed. + +Lemma map_fold_context_k f g Γ : + map_context g (fold_context_k f Γ) = fold_context_k (fun i => g ∘ (f i)) Γ. +Proof. + rewrite !fold_context_k_alt. + rewrite /map_context map_mapi. + apply mapi_ext => i x. + now rewrite !compose_map_decl. +Qed. + +Lemma fold_map_context f g Γ : + fold_context_k f (map_context g Γ) = fold_context_k (fun i => f i ∘ g) Γ. +Proof. + rewrite !fold_context_k_alt. + rewrite /map_context mapi_map. + apply mapi_ext => i x. len. + now rewrite !compose_map_decl. +Qed. + +Lemma subst_instance_subst_context u 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. + rewrite /subst_context fold_map_context. + apply fold_context_k_ext => i t. + now rewrite -subst_instance_subst. +Qed. + +Lemma subst_instance_subst_telescope u 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 /= + /map_context map_mapi mapi_map. + apply mapi_ext => i t. + rewrite !compose_map_decl; apply map_decl_ext => t'. + now rewrite -subst_instance_subst. +Qed. + +Lemma subst_instance_lift_context u 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. + rewrite /lift_context fold_map_context. + apply fold_context_k_ext => i t. + now rewrite subst_instance_lift. +Qed. + +Lemma subst_instance_inds u0 ind u bodies : + subst_instance u0 (inds ind u bodies) + = inds ind (subst_instance u0 u) bodies. +Proof. + unfold inds. + induction #|bodies|; cbnr. + f_equal. apply IHn. +Qed. + +Hint Rewrite subst_instance_subst_context subst_instance_lift_context + subst_instance_lift subst_instance_mkApps + subst_instance_subst + subst_instance_it_mkProd_or_LetIn + subst_instance_it_mkLambda_or_LetIn + subst_instance_inds + : substu. +Ltac substu := autorewrite with substu. + +Lemma subst_instance_case_branch_context_gen ind mdecl u 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. + cbn -[fold_context_k]. + substu => /=; len. + rewrite [subst_instance _ _]map_rev subst_instance_two_context. + rewrite /expand_lets_ctx /expand_lets_k_ctx. len. + now rewrite subst_instance_two_context. +Qed. + +Lemma map_map2 {A B C D} (f : A -> B) (g : C -> D -> A) (l : list C) (l' : list D) : + map f (map2 g l l') = + map2 (fun (x : C) (y : D) => f (g x y)) l l'. +Proof. + induction l in l' |- *; destruct l'; simpl; auto. + * cbn. now f_equal. +Qed. + +Lemma map2_map_r {A B C D} (f : B -> C) (g : A -> C -> D) (l : list A) (l' : list B) : + map2 g l (map f l') = + map2 (fun x y => g x (f y)) l l'. +Proof. + induction l in l' |- *; destruct l'; simpl; auto. + * cbn. now f_equal. +Qed. + +Lemma map2_set_binder_name_map bctx 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_context_app u L1 L2 : - subst_instance_context u (L1,,,L2) - = subst_instance_context u L1 ,,, subst_instance_context u L2. +Lemma subst_instance_to_extended_list u l + : map (subst_instance u) (to_extended_list l) + = to_extended_list (subst_instance u l). Proof. - unfold subst_instance_context, map_context; now rewrite map_app. + - unfold to_extended_list, to_extended_list_k. + change [] with (map (subst_instance u) (@nil term)) at 2. + unf_term. generalize (@nil term), 0. induction l as [|[aa [ab|] ac] bb]. + + reflexivity. + + intros l n; cbn. now rewrite IHbb. + + intros l n; cbn. now rewrite IHbb. Qed. +Lemma to_extended_list_subst_instance u l + : to_extended_list (subst_instance u l) = to_extended_list l. +Proof. + - unfold to_extended_list, to_extended_list_k. + unf_term. generalize (@nil term), 0. induction l as [|[aa [ab|] ac] bb]. + + reflexivity. + + intros l n; cbn. now rewrite IHbb. + + intros l n; cbn. now rewrite IHbb. +Qed. + +Lemma subst_instance_expand_lets_ctx u Γ Δ : + 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. +Qed. +Hint Rewrite subst_instance_expand_lets_ctx : substu. + +Lemma forget_types_subst_instance l ctx : + forget_types (subst_instance l ctx) = forget_types ctx. +Proof. + now rewrite /forget_types map_map_compose /=. +Qed. + +Lemma subst_instance_case_predicate_context {ind mdecl idecl u 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. simpl. + unfold id. unfold case_predicate_context_gen. + rewrite {1}/subst_instance {1}/subst_instance_context /=. + rewrite -map2_set_binder_name_map //. f_equal. + { now rewrite forget_types_subst_instance. } + simpl. unfold pre_case_predicate_context_gen. f_equal. + - rewrite /map_decl /=. f_equal. substu. + rewrite !map_app !map_map_compose; do 2 f_equal. + * len. now setoid_rewrite subst_instance_lift. + * now rewrite subst_instance_to_extended_list to_extended_list_subst_instance. + - substu. rewrite [map_context _ _]subst_instance_subst_context + [subst_instance _ _]map_rev. + f_equal. substu. f_equal; rewrite subst_instance_two_context //. +Qed. + +Lemma subst_instance_case_branch_type {Σ} {wfΣ : wf Σ} u (ci : case_info) mdecl idecl p br i cdecl : + let ptm := + it_mkLambda_or_LetIn (pcontext p) (preturn p) + in + let p' := subst_instance u p in + let ptm' := + it_mkLambda_or_LetIn + (pcontext p') + (preturn p') in + case_branch_type ci mdecl idecl + (subst_instance u p) + (map_branch (subst_instance u) br) + ptm' i cdecl = + map_pair (subst_instance u) (subst_instance u) + (case_branch_type ci mdecl idecl p br ptm i cdecl). +Proof. + intros ptm p' ptm'. + rewrite /case_branch_type /case_branch_type_gen /map_pair /=. + rewrite subst_instance_case_branch_context_gen //. + f_equal; substu. + { now rewrite forget_types_subst_instance. } + f_equal. + rewrite map_app. f_equal. + + rewrite !map_map_compose. apply map_ext => x. + substu. + rewrite [subst_instance u (List.rev _)]map_rev. f_equal. + rewrite /expand_lets_k. len. + rewrite ?subst_instance_two ?subst_instance_two_context //. + + simpl. f_equal. + substu. rewrite map_app /= //. + rewrite subst_instance_to_extended_list to_extended_list_subst_instance. + do 2 f_equal. + rewrite !map_map_compose. now setoid_rewrite <-subst_instance_lift. +Qed. + +Lemma subst_instance_wf_predicate u mdecl idecl p : + wf_predicate mdecl idecl p -> + wf_predicate mdecl idecl (subst_instance u p). +Proof. + intros []. split. + - now len. + - simpl. rewrite forget_types_subst_instance. assumption. +Qed. + +Lemma subst_instance_wf_branch u cdecl br : + wf_branch cdecl br -> + wf_branch cdecl (map_branch (subst_instance u) br). +Proof. + unfold wf_branch, wf_branch_gen. + now simpl; rewrite forget_types_subst_instance. +Qed. + +Lemma subst_instance_wf_branches cdecl u brs : + wf_branches cdecl brs -> + wf_branches cdecl (map (map_branch (subst_instance u)) brs). +Proof. + unfold wf_branches, wf_branches_gen. + intros h. solve_all. eapply Forall2_map_right. + eapply Forall2_impl; tea. eauto using subst_instance_wf_branch. +Qed. +Hint Resolve subst_instance_wf_predicate + 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) = + set_pparams (subst_instance u p) (map (subst_instance u) params). +Proof. reflexivity. Qed. + +Lemma subst_instance_predicate_set_pcontext u 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) = + set_preturn (subst_instance u p) (subst_instance u pret). +Proof. reflexivity. Qed. + Lemma red1_subst_instance Σ Γ u s t : red1 Σ Γ s t -> - red1 Σ (subst_instance_context u Γ) - (subst_instance_constr u s) (subst_instance_constr u t). + red1 Σ (subst_instance u Γ) + (subst_instance u s) (subst_instance u t). Proof. intros X0. pose proof I as X. intros. induction X0 using red1_ind_all. all: try (cbn; econstructor; eauto; fail). - - cbn. rewrite <- subst_subst_instance_constr. econstructor. - - cbn. rewrite <- subst_subst_instance_constr. econstructor. - - cbn. rewrite <- lift_subst_instance_constr. econstructor. - unfold subst_instance_context. + - cbn. rewrite subst_instance_subst. econstructor. + - cbn. rewrite subst_instance_subst. econstructor. + - cbn. rewrite subst_instance_lift. econstructor. + unfold subst_instance. unfold option_map in *. destruct (nth_error Γ) eqn:E; inversion H. - unfold map_context. rewrite nth_error_map, E. cbn. + unfold map_context. rewrite nth_error_map E. cbn. rewrite map_decl_body. destruct c. cbn in H1. subst. reflexivity. - - cbn. rewrite subst_instance_constr_mkApps. cbn. - rewrite iota_red_subst_instance. econstructor. - - cbn. rewrite !subst_instance_constr_mkApps. cbn. + - cbn. rewrite subst_instance_mkApps. cbn. + rewrite iota_red_subst_instance. + change (bcontext br) with (bcontext (map_branch (subst_instance u) br)). + eapply red_iota; eauto with pcuic. + * rewrite nth_error_map H //. + * simpl. now len. + - cbn. rewrite !subst_instance_mkApps. cbn. econstructor. + unfold unfold_fix in *. destruct (nth_error mfix idx) eqn:E. * inversion H. - rewrite nth_error_map, E. cbn. + rewrite nth_error_map E. cbn. destruct d. cbn in *. cbn in *; try congruence. repeat f_equal. - all: rewrite <- subst_subst_instance_constr; - rewrite fix_subst_subst_instance; reflexivity. + now rewrite subst_instance_subst fix_subst_instance_subst. * inversion H. + unfold is_constructor in *. destruct (nth_error args narg) eqn:E; inversion H0; clear H0. - rewrite nth_error_map, E. cbn. + rewrite nth_error_map E. cbn. eapply isConstruct_app_subst_instance. - - cbn. rewrite !subst_instance_constr_mkApps. + - cbn. rewrite !subst_instance_mkApps. unfold unfold_cofix in *. destruct (nth_error mfix idx) eqn:E. + inversion H. - econstructor. fold subst_instance_constr. + econstructor. fold subst_instance. unfold unfold_cofix. - rewrite nth_error_map, E. cbn. - rewrite <- subst_subst_instance_constr. - now rewrite cofix_subst_subst_instance. - + econstructor. fold subst_instance_constr. + rewrite nth_error_map E. cbn. + rewrite subst_instance_subst. + now rewrite cofix_subst_instance_subst. + + econstructor. fold subst_instance. inversion H. - cbn. unfold unfold_cofix in *. destruct nth_error eqn:E; inversion H. - rewrite !subst_instance_constr_mkApps. - econstructor. fold subst_instance_constr. + rewrite !subst_instance_mkApps. + econstructor. fold subst_instance. unfold unfold_cofix. rewrite nth_error_map. destruct nth_error; cbn. - 1: rewrite <- subst_subst_instance_constr, cofix_subst_subst_instance. + 1: rewrite subst_instance_subst cofix_subst_instance_subst. all: now inversion E. - - cbn. rewrite subst_instance_constr_two. econstructor; eauto. - - cbn. rewrite !subst_instance_constr_mkApps. - econstructor. now rewrite nth_error_map, H. - - cbn. econstructor; eauto. + - cbn. rewrite subst_instance_two. econstructor; eauto. + - cbn. rewrite !subst_instance_mkApps. + econstructor. now rewrite nth_error_map H. + - cbn. + rewrite [map_predicate _ _ _ (set_pparams _ _)]subst_instance_predicate_set_pparams. + econstructor; eauto. eapply OnOne2_map. eapply OnOne2_impl. 1: eassumption. (* Used to be pcuicfo *) - simpl in *; intuition; simpl in *. unfold on_Trel. - simpl. split; auto. - - cbn; econstructor; - eapply OnOne2_map; eapply OnOne2_impl; [ eassumption | pcuicfo]. + simpl in *; intuition; simpl in *. + - cbn. + rewrite [map_predicate _ _ _ (set_pcontext _ _)]subst_instance_predicate_set_pcontext. + eapply case_red_pcontext; eauto with pcuic. simpl. + eapply OnOne2_local_env_map_context. + eapply OnOne2_local_env_impl; tea. intros ? ? ? ?. + eapply on_one_decl_map, on_one_decl_impl; tea; cbn. + now intros ?; rewrite subst_instance_app. + - cbn. + rewrite [map_predicate _ _ _ (set_preturn _ _)]subst_instance_predicate_set_preturn. + eapply case_red_return; eauto with pcuic. + now rewrite subst_instance_app in IHX0. + - cbn. econstructor; eauto with pcuic. + * eapply OnOne2_map. eapply OnOne2_impl; [eassumption | pcuicfo]; + unfold on_Trel; simpl; intuition eauto. + + left. rewrite -b. now rewrite subst_instance_app in b0. + + right. rewrite -b0. split => //. + eapply OnOne2_local_env_map_context. + eapply OnOne2_local_env_impl; tea. intros ? ? ? ?. + eapply on_one_decl_map, on_one_decl_impl; tea; cbn. + now intros ?; rewrite subst_instance_app. - cbn; econstructor; eapply OnOne2_map; eapply OnOne2_impl; [ eassumption | ]. + intros. destruct X1. now red. + - cbn. eapply fix_red_ty. + eapply OnOne2_map; eapply OnOne2_impl; [ eassumption | ]. intros. destruct X1. destruct p. inversion e. destruct x, y; cbn in *; subst. red. split; cbn; eauto. - cbn. eapply fix_red_body. - eapply OnOne2_map; eapply OnOne2_impl; [ eassumption | ]. + eapply OnOne2_map; eapply OnOne2_impl; [ eassumption | ]. intros. destruct X1. destruct p. inversion e. destruct x, y; cbn in *; subst. - red. split; cbn; eauto. - rewrite <- (fix_context_subst_instance u mfix0). - unfold subst_instance_context, map_context in *. rewrite map_app in *. - eassumption. + red; split; cbn; eauto. + rewrite subst_instance_app in r0. + now rewrite -(fix_context_subst_instance u mfix0). - cbn; econstructor; eapply OnOne2_map; eapply OnOne2_impl; [ eassumption | ]. intros. destruct X1. destruct p. inversion e. destruct x, y; cbn in *; subst. @@ -1109,102 +1478,30 @@ Proof. eapply OnOne2_map; eapply OnOne2_impl; [ eassumption | ]. intros. destruct X1. destruct p. inversion e. destruct x, y; cbn in *; subst. red. split; cbn; eauto. - rewrite <- (fix_context_subst_instance u mfix0). - unfold subst_instance_context, map_context in *. rewrite map_app in *. - eassumption. + rewrite subst_instance_app in r0. + now rewrite <- (fix_context_subst_instance u mfix0). Grab Existential Variables. all:repeat econstructor. Qed. -Fixpoint subst_instance_stack l π := - match π with - | ε => ε - | App u π => - App (subst_instance_constr l u) (subst_instance_stack l π) - | Fix mfix idx args π => - let mfix' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix in - Fix mfix' idx (map (subst_instance_constr l) args) (subst_instance_stack l π) - | Fix_mfix_ty na bo ra mfix1 mfix2 idx π => - let mfix1' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix1 in - let mfix2' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix2 in - Fix_mfix_ty na (subst_instance_constr l bo) ra mfix1' mfix2' idx (subst_instance_stack l π) - | Fix_mfix_bd na ty ra mfix1 mfix2 idx π => - let mfix1' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix1 in - let mfix2' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix2 in - Fix_mfix_bd na (subst_instance_constr l ty) ra mfix1' mfix2' idx (subst_instance_stack l π) - | CoFix mfix idx args π => - let mfix' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix in - CoFix mfix' idx (map (subst_instance_constr l) args) (subst_instance_stack l π) - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx π => - let mfix1' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix1 in - let mfix2' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix2 in - CoFix_mfix_ty na (subst_instance_constr l bo) ra mfix1' mfix2' idx (subst_instance_stack l π) - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx π => - let mfix1' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix1 in - let mfix2' := List.map (map_def (subst_instance_constr l) (subst_instance_constr l)) mfix2 in - CoFix_mfix_bd na (subst_instance_constr l ty) ra mfix1' mfix2' idx (subst_instance_stack l π) - | Case_p indn c brs π => - let brs' := List.map (on_snd (subst_instance_constr l)) brs in - Case_p indn (subst_instance_constr l c) brs' (subst_instance_stack l π) - | Case indn pred brs π => - let brs' := List.map (on_snd (subst_instance_constr l)) brs in - Case indn (subst_instance_constr l pred) brs' (subst_instance_stack l π) - | Case_brs indn pred c m brs1 brs2 π => - let brs1' := List.map (on_snd (subst_instance_constr l)) brs1 in - let brs2' := List.map (on_snd (subst_instance_constr l)) brs2 in - Case_brs indn (subst_instance_constr l pred) (subst_instance_constr l c) m brs1' brs2' (subst_instance_stack l π) - | Proj p π => - Proj p (subst_instance_stack l π) - | Prod_l na B π => - Prod_l na (subst_instance_constr l B) (subst_instance_stack l π) - | Prod_r na A π => - Prod_r na (subst_instance_constr l A) (subst_instance_stack l π) - | Lambda_ty na b π => - Lambda_ty na (subst_instance_constr l b) (subst_instance_stack l π) - | Lambda_tm na A π => - Lambda_tm na (subst_instance_constr l A) (subst_instance_stack l π) - | LetIn_bd na B u π => - LetIn_bd na (subst_instance_constr l B) (subst_instance_constr l u) (subst_instance_stack l π) - | LetIn_ty na b u π => - LetIn_ty na (subst_instance_constr l b) (subst_instance_constr l u) (subst_instance_stack l π) - | LetIn_in na b B π => - LetIn_in na (subst_instance_constr l b) (subst_instance_constr l B) (subst_instance_stack l π) - | coApp u π => - coApp (subst_instance_constr l u) (subst_instance_stack l π) - end. - -Lemma subst_instance_constr_zipc : - forall l t π, - subst_instance_constr l (zipc t π) = - zipc (subst_instance_constr l t) (subst_instance_stack l π). -Proof. - intros l t π. - induction π in l, t |- *. - all: try reflexivity. - all: try solve [ - simpl ; rewrite IHπ ; cbn ; reflexivity - ]. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite subst_instance_constr_mkApps. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite subst_instance_constr_mkApps. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. cbn. reflexivity. +Lemma conv_subst_instance (Σ : global_env_ext) Γ u A B univs : +valid_constraints (global_ext_constraints (Σ.1, univs)) + (subst_instance_cstrs u Σ) -> + Σ ;;; Γ |- A = B -> + (Σ.1,univs) ;;; subst_instance u Γ |- subst_instance u A = subst_instance u B. +Proof. + intros HH X0. induction X0. + - econstructor. + eapply eq_term_subst_instance; tea. + - econstructor 2. 1: eapply red1_subst_instance; cbn; eauto. eauto. + - econstructor 3. 1: eauto. eapply red1_subst_instance; cbn; eauto. Qed. Lemma cumul_subst_instance (Σ : global_env_ext) Γ u A B univs : valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) -> Σ ;;; Γ |- A <= B -> - (Σ.1,univs) ;;; subst_instance_context u Γ - |- subst_instance_constr u A <= subst_instance_constr u B. + (Σ.1,univs) ;;; subst_instance u Γ + |- subst_instance u A <= subst_instance u B. Proof. intros HH X0. induction X0. - econstructor. @@ -1213,6 +1510,48 @@ Proof. - econstructor 3. 1: eauto. eapply red1_subst_instance; cbn; eauto. Qed. +Lemma conv_decls_subst_instance (Σ : global_env_ext) {Γ Γ'} u univs d d' : + valid_constraints (global_ext_constraints (Σ.1, univs)) + (subst_instance_cstrs u Σ) -> + conv_decls Σ Γ Γ' d d' -> + conv_decls (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ') + (subst_instance u d) (subst_instance u d'). +Proof. + intros valid Hd; depelim Hd; constructor; tas; + eapply conv_subst_instance; tea. +Qed. + +Lemma cumul_decls_subst_instance (Σ : global_env_ext) {Γ Γ'} u univs d d' : + valid_constraints (global_ext_constraints (Σ.1, univs)) + (subst_instance_cstrs u Σ) -> + cumul_decls Σ Γ Γ' d d' -> + cumul_decls (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ') + (subst_instance u d) (subst_instance u d'). +Proof. + intros valid Hd; depelim Hd; constructor; tas; + (eapply conv_subst_instance || eapply cumul_subst_instance); tea. +Qed. + +Lemma conv_ctx_subst_instance (Σ : global_env_ext) {Γ Γ'} u univs : + valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) -> + conv_context Σ Γ Γ' -> + conv_context (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ'). +Proof. + intros valid. + intros; eapply All2_fold_map, All2_fold_impl; tea => ? ? d d'. + now eapply conv_decls_subst_instance. +Qed. + +Lemma cumul_ctx_subst_instance (Σ : global_env_ext) {Γ Γ'} u univs : + valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) -> + cumul_context Σ Γ Γ' -> + cumul_context (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ'). +Proof. + intros valid. + intros; eapply All2_fold_map, All2_fold_impl; tea => ? ? d d'. + now eapply cumul_decls_subst_instance. +Qed. + Lemma is_allowed_elimination_subst_instance (Σ : global_env_ext) univs inst u al : valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs inst Σ) -> @@ -1230,78 +1569,69 @@ Qed. Global Instance eq_decl_subst_instance le Σ : SubstUnivPreserved (eq_decl le Σ). Proof. - intros φ1 φ2 u HH [? [?|] ?] [? [?|] ?] [[Hann H1] H2]; split; cbn in *; auto. - all: try split; try eapply compare_term_subst_instance; tea. - eapply eq_term_subst_instance; tea. + intros φ1 φ2 u HH ? ? [] => /=; destruct le; constructor; auto; + (eapply eq_term_subst_instance || eapply leq_term_subst_instance); tea. Qed. Global Instance eq_context_subst_instance le Σ : SubstUnivPreserved (eq_context le Σ). Proof. - intros φ φ' u HH Γ Γ' X. eapply All2_map, All2_impl; tea. - eapply eq_decl_subst_instance; eassumption. + intros φ φ' u HH Γ Γ' X. eapply All2_fold_map, All2_fold_impl; tea. + intros. eapply eq_decl_subst_instance; eassumption. Qed. Lemma subst_instance_destArity Γ A u : - destArity (subst_instance_context u Γ) (subst_instance_constr u A) + destArity (subst_instance u Γ) (subst_instance u A) = match destArity Γ A with - | Some (ctx, s) => Some (subst_instance_context u ctx, subst_instance_univ u s) + | Some (ctx, s) => Some (subst_instance u ctx, subst_instance_univ u s) | None => None end. Proof. induction A in Γ |- *; simpl; try reflexivity. - - change (subst_instance_context u Γ,, vass na (subst_instance_constr u A1)) - with (subst_instance_context u (Γ ,, vass na A1)). + - change (subst_instance u Γ,, vass na (subst_instance_constr u A1)) + with (subst_instance u (Γ ,, vass na A1)). now rewrite IHA2. - - change (subst_instance_context u Γ ,, + - change (subst_instance u Γ ,, vdef na (subst_instance_constr u A1) (subst_instance_constr u A2)) - with (subst_instance_context u (Γ ,, vdef na A1 A2)). + with (subst_instance u (Γ ,, vdef na A1 A2)). now rewrite IHA3. Qed. - +(* Lemma subst_instance_instantiate_params_subst u0 params pars s ty : - option_map (on_pair (map (subst_instance_constr u0)) (subst_instance_constr u0)) + option_map (on_pair (map (subst_instance u0)) (subst_instance u0)) (instantiate_params_subst params pars s ty) - = instantiate_params_subst (subst_instance_context u0 params) - (map (subst_instance_constr u0) pars) - (map (subst_instance_constr u0) s) - (subst_instance_constr u0 ty). + = instantiate_params_subst (subst_instance u0 params) + (map (subst_instance u0) pars) + (map (subst_instance u0) s) + (subst_instance u0 ty). Proof. induction params in pars, s, ty |- *; cbn. - destruct pars; cbnr. - destruct ?; cbnr; destruct ?; cbnr. + rewrite IHparams; cbn. repeat f_equal. - symmetry; apply subst_subst_instance_constr. + symmetry; apply subst_instance_subst. + destruct ?; cbnr. now rewrite IHparams. Qed. Lemma subst_instance_instantiate_params u0 params pars ty : - option_map (subst_instance_constr u0) + option_map (subst_instance u0) (instantiate_params params pars ty) - = instantiate_params (subst_instance_context u0 params) - (map (subst_instance_constr u0) pars) - (subst_instance_constr u0 ty). + = instantiate_params (subst_instance u0 params) + (map (subst_instance u0) pars) + (subst_instance u0 ty). Proof. unfold instantiate_params. - change (@nil term) with (map (subst_instance_constr u0) []) at 2. - rewrite rev_subst_instance_context. + change (@nil term) with (map (subst_instance u0) []) at 2. + rewrite rev_subst_instance. rewrite <- subst_instance_instantiate_params_subst. destruct ?; cbnr. destruct p; cbn. - now rewrite subst_subst_instance_constr. -Qed. - -Lemma subst_instance_inds u0 ind u bodies : - subst_instance u0 (inds ind u bodies) - = inds ind (subst_instance u0 u) bodies. -Proof. - unfold inds. - induction #|bodies|; cbnr. - f_equal. apply IHn. + now rewrite subst_instance_subst. Qed. +*) Lemma subst_instance_decompose_prod_assum u Γ t : subst_instance u (decompose_prod_assum Γ t) - = decompose_prod_assum (subst_instance_context u Γ) (subst_instance_constr u t). + = decompose_prod_assum (subst_instance u Γ) (subst_instance u t). Proof. induction t in Γ |- *; cbnr. - apply IHt2. @@ -1322,31 +1652,19 @@ Proof. unfold decompose_app. now rewrite (subst_instance_decompose_app_rec u []). Qed. -Lemma subst_instance_to_extended_list u l - : map (subst_instance_constr u) (to_extended_list l) - = to_extended_list (subst_instance_context u l). -Proof. - - unfold to_extended_list, to_extended_list_k. - change [] with (map (subst_instance_constr u) []) at 2. - unf_term. generalize (@nil term), 0. induction l as [|[aa [ab|] ac] bb]. - + reflexivity. - + intros l n; cbn. now rewrite IHbb. - + intros l n; cbn. now rewrite IHbb. -Qed. - -Lemma subst_instance_build_branches_type u0 ind mdecl idecl pars u p : - map (option_map (on_snd (subst_instance_constr u0))) +(* Lemma subst_instance_build_branches_type u0 ind mdecl idecl pars u p : + map (option_map (on_snd (subst_instance u0))) (build_branches_type ind mdecl idecl pars u p) - = build_branches_type ind mdecl idecl (map (subst_instance_constr u0) pars) - (subst_instance_instance u0 u) (subst_instance_constr u0 p). + = build_branches_type ind mdecl idecl (map (subst_instance u0) pars) + (subst_instance u0 u) (subst_instance u0 p). Proof. rewrite !build_branches_type_. rewrite map_mapi. eapply mapi_ext. intros n [[id t] k]; cbn. - rewrite <- subst_instance_context_two. - rewrite <- subst_instance_constr_two. + rewrite <- subst_instance_two. + rewrite <- subst_instance_two. rewrite <- subst_instance_inds. - rewrite subst_subst_instance_constr. + rewrite subst_instance_subst. rewrite <- subst_instance_instantiate_params. rewrite !option_map_two. apply option_map_ext. intros x. rewrite <- (subst_instance_decompose_prod_assum u0 [] x). @@ -1357,35 +1675,23 @@ Proof. case_eq (chop (ind_npars mdecl) l); intros l0 l1 H. eapply chop_map in H; rewrite H; clear H. unfold on_snd; cbn. f_equal. - rewrite subst_instance_constr_it_mkProd_or_LetIn. f_equal. - rewrite subst_instance_constr_mkApps; f_equal. - - rewrite subst_instance_context_length. - symmetry; apply lift_subst_instance_constr. + rewrite subst_instance_it_mkProd_or_LetIn. f_equal. + rewrite subst_instance_mkApps; f_equal. + - rewrite subst_instance_length. + symmetry; apply subst_instance_lift. - rewrite map_app; f_equal; cbn. - rewrite subst_instance_constr_mkApps, map_app; cbn; repeat f_equal. + rewrite subst_instance_mkApps, map_app; cbn; repeat f_equal. apply subst_instance_to_extended_list. -Qed. - -Lemma subst_instance_subst_context u s k Γ : - subst_instance_context u (subst_context s k Γ) = - subst_context (map (subst_instance_constr u) s) k (subst_instance_context u Γ). -Proof. - unfold subst_instance_context, map_context. - rewrite !subst_context_alt. - rewrite map_mapi, mapi_map. apply mapi_rec_ext. - intros. unfold subst_decl; rewrite !PCUICAstUtils.compose_map_decl. - apply PCUICAstUtils.map_decl_ext; intros decl. - rewrite map_length. now rewrite subst_subst_instance_constr. -Qed. +Qed. *) -Lemma subst_instance_context_smash u Γ Δ : - subst_instance_context u (smash_context Δ Γ) = - smash_context (subst_instance_context u Δ) (subst_instance_context u Γ). +Lemma subst_instance_smash u Γ Δ : + subst_instance u (smash_context Δ Γ) = + smash_context (subst_instance u Δ) (subst_instance u Γ). Proof. induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto. - rewrite IHΓ. f_equal. now rewrite subst_instance_subst_context. - - rewrite IHΓ, subst_instance_context_app; trivial. + - rewrite IHΓ subst_instance_app; trivial. Qed. Lemma destInd_subst_instance u t : @@ -1395,21 +1701,18 @@ Proof. f_equal. Qed. -Lemma subst_instance_context_assumptions u ctx : - context_assumptions (subst_instance_context u ctx) - = context_assumptions ctx. +Lemma subst_instance_assumptions u ctx : + context_assumptions (subst_instance u ctx) = context_assumptions ctx. Proof. induction ctx; cbnr. destruct (decl_body a); cbn; now rewrite IHctx. Qed. - -Hint Rewrite subst_instance_context_assumptions : len. - +Hint Rewrite subst_instance_assumptions : len. Lemma subst_instance_check_one_fix u mfix : map (fun x : def term => - check_one_fix (map_def (subst_instance_constr u) (subst_instance_constr u) x)) mfix = + check_one_fix (map_def (subst_instance u) (subst_instance u) x)) mfix = map check_one_fix mfix. Proof. apply map_ext. intros [na ty def rarg]; simpl. @@ -1420,8 +1723,8 @@ Proof. destruct (decompose_prod_assum [] ty) eqn:decty. rewrite app_context_nil_l in decomp. injection decomp. intros -> ->. clear decomp. - simpl. rewrite !app_context_nil_l, <- (subst_instance_context_smash u _ []). - unfold subst_instance_context, map_context. + simpl. rewrite !app_context_nil_l -(subst_instance_smash u _ []). + unfold subst_instance, map_context. rewrite <- map_rev. rewrite nth_error_map. destruct nth_error as [d|] eqn:Hnth; simpl; auto. rewrite <- subst_instance_decompose_app. @@ -1434,7 +1737,7 @@ Qed. Lemma subst_instance_check_one_cofix u mfix : map (fun x : def term => - check_one_cofix (map_def (subst_instance_constr u) (subst_instance_constr u) x)) mfix = + check_one_cofix (map_def (subst_instance u) (subst_instance u) x)) mfix = map check_one_cofix mfix. Proof. apply map_ext. intros [na ty def rarg]; simpl. @@ -1459,17 +1762,17 @@ Lemma All_local_env_over_subst_instance Σ Γ (wfΓ : wf_local Σ Γ) : sub_context_set (monomorphic_udecl Σ0.2) (global_ext_context_set (Σ0.1, univs)) -> consistent_instance_ext (Σ0.1, univs) Σ0.2 u -> - (Σ0.1, univs) ;;; subst_instance_context u Γ0 - |- subst_instance_constr u t : subst_instance_constr u T) + (Σ0.1, univs) ;;; subst_instance u Γ0 + |- subst_instance u t : subst_instance u T) Σ Γ wfΓ -> forall u univs, wf_ext_wk Σ -> sub_context_set (monomorphic_udecl Σ.2) (global_ext_context_set (Σ.1, univs)) -> consistent_instance_ext (Σ.1, univs) Σ.2 u -> - wf_local (Σ.1, univs) (subst_instance_context u Γ). + wf_local (Σ.1, univs) (subst_instance u Γ). Proof. - induction 1; simpl; constructor; cbn in *; auto. + induction 1; simpl; rewrite /subst_instance /=; constructor; cbn in *; auto. all: destruct tu; eexists; cbn in *; eauto. Qed. @@ -1543,17 +1846,18 @@ Lemma typing_subst_instance : sub_context_set (monomorphic_udecl Σ.2) (global_ext_context_set (Σ.1, univs)) -> consistent_instance_ext (Σ.1, univs) Σ.2 u -> - (Σ.1,univs) ;;; subst_instance_context u Γ - |- subst_instance_constr u t : subst_instance_constr u T) - (fun Σ Γ wfΓ => forall u univs, + (Σ.1,univs) ;;; subst_instance u Γ + |- subst_instance u t : subst_instance u T) + (fun Σ Γ => forall u univs, wf_ext_wk Σ -> sub_context_set (monomorphic_udecl Σ.2) (global_ext_context_set (Σ.1, univs)) -> consistent_instance_ext (Σ.1, univs) Σ.2 u -> - wf_local(Σ.1,univs) (subst_instance_context u Γ)). + wf_local(Σ.1,univs) (subst_instance u Γ)). Proof. apply typing_ind_env; intros Σ wfΣ Γ wfΓ; cbn -[Universe.make] in *. - - induction 1. + - rewrite /subst_instance /=. + induction 1. + constructor. + simpl. constructor; auto. exists (subst_instance_univ u tu.π1). eapply p; auto. @@ -1561,10 +1865,10 @@ Proof. ++ exists (subst_instance_univ u tu.π1). eapply p0; auto. ++ apply p; auto. - - intros n decl eq X u univs wfΣ' H Hsub. rewrite <- lift_subst_instance_constr. + - intros n decl eq X u univs wfΣ' H Hsub. rewrite subst_instance_lift. rewrite map_decl_type. econstructor; aa. - unfold subst_instance_context, map_context. - now rewrite nth_error_map, eq. + unfold subst_instance, map_context. + now rewrite nth_error_map eq. - intros l X Hl u univs wfΣ' HSub H. rewrite subst_instance_univ_super. + econstructor. @@ -1581,89 +1885,111 @@ Proof. - intros n b b_ty b' s1 b'_ty X X0 X1 X2 X3 X4 X5 u univs wfΣ' HSub H. econstructor; eauto. eapply X5; aa. - intros t0 na A B s u X X0 X1 X2 X3 X4 X5 u0 univs wfΣ' HSub H. - rewrite <- subst_subst_instance_constr. cbn. econstructor. + rewrite subst_instance_subst. cbn. econstructor. + eapply X1; eauto. + eapply X3; eauto. + eapply X5; eauto. - - intros. rewrite subst_instance_constr_two. econstructor; [aa|aa|]. + - intros. rewrite subst_instance_two. econstructor; [aa|aa|]. clear X X0; cbn in *. eapply consistent_ext_trans; eauto. - - intros. rewrite subst_instance_constr_two. econstructor; [aa|aa|]. + - intros. rewrite subst_instance_two. econstructor; [aa|aa|]. clear X X0; cbn in *. eapply consistent_ext_trans; eauto. - intros. eapply meta_conv. 1: econstructor; aa. clear. unfold type_of_constructor; cbn. - rewrite <- subst_subst_instance_constr. f_equal. + rewrite subst_instance_subst. f_equal. + unfold inds. induction #|ind_bodies mdecl|. 1: reflexivity. cbn. now rewrite IHn. - + symmetry; apply subst_instance_constr_two. - - - intros ind u npar p c brs args mdecl idecl isdecl X X0 H ps pty H0 X1 - X2 H1 X3 notCoFinite X4 btys H2 X5 u0 univs X6 HSub H4. - rewrite subst_instance_constr_mkApps in *. - rewrite map_app. cbn. rewrite map_skipn. - eapply type_Case with (u1:=subst_instance_instance u0 u) - (ps0 :=subst_instance_univ u0 ps) - (btys0:=map (on_snd (subst_instance_constr u0)) btys); - eauto. - + clear -H0. rewrite firstn_map. unfold build_case_predicate_type. simpl. - rewrite <- subst_instance_constr_two, <- subst_instance_context_two. - set (param' := subst_instance_context u (ind_params mdecl)) in *. - set (type' := subst_instance_constr u (ind_type idecl)) in *. - rewrite <- subst_instance_instantiate_params. - destruct (instantiate_params param' (firstn npar args) type'); - [|discriminate]. - simpl. rewrite (subst_instance_destArity []). - destruct (destArity [] t) as [[ctx s']|]; [|discriminate]. - apply some_inj in H0; subst; simpl in *. f_equal. - rewrite subst_instance_constr_it_mkProd_or_LetIn. f_equal; cbn. - unf_term. f_equal. rewrite subst_instance_constr_mkApps; cbn. - f_equal. rewrite map_app. f_equal. - * rewrite !map_map, subst_instance_context_length; apply map_ext. clear. - intro. now apply lift_subst_instance_constr. - * symmetry; apply subst_instance_to_extended_list. - + destruct HSub. + + symmetry; apply subst_instance_two. + + - intros ci p c brs args u mdecl idecl isdecl hΣ hΓ indnp wfp cup + wfpctx convpctx pty Hpty Hcpc kelim + Hctxi IHctxi Hc IHc notCoFinite wfbrs hbrs i univs wfext Hsub cu. + rewrite subst_instance_mkApps subst_instance_it_mkLambda_or_LetIn map_app. + cbn. + change (subst_instance i (preturn p)) with (preturn (subst_instance i p)). + change (subst_instance i (pcontext p)) with (pcontext (subst_instance i p)). + change (map_predicate _ _ _ _) with (subst_instance i p). + eapply type_Case with (p0:=subst_instance i p) + (ps:=subst_instance_univ i u); eauto with pcuic. + + simpl. eapply consistent_ext_trans; tea. + + now rewrite -subst_instance_app_ctx. + + rewrite - !subst_instance_app_ctx. + rewrite -subst_instance_case_predicate_context - !subst_instance_app_ctx. + eapply conv_ctx_subst_instance; tea. + destruct Hsub; aa. + + clear -wfext Hsub cu Hpty. + specialize (Hpty i univs). + now rewrite subst_instance_app in Hpty. + + clear -wfext Hsub cu Hcpc. + specialize (Hcpc i univs). + rewrite subst_instance_app in Hcpc. + now rewrite subst_instance_case_predicate_context in Hcpc. + + destruct Hsub. cbn in *. eapply is_allowed_elimination_subst_instance; aa. - + eapply X4 in H4; tea. - rewrite subst_instance_constr_mkApps in H4; eassumption. - + cbn. rewrite firstn_map. rewrite <- subst_instance_build_branches_type. - now rewrite map_option_out_map_option_map, H2. - + eapply All2_map with (f := (on_snd (subst_instance_constr u0))) - (g:= (on_snd (subst_instance_constr u0))). - eapply All2_impl. 1: eassumption. - intros. - simpl in X7. destruct X7 as [[[? ?] ?] ?]. intuition eauto. - * cbn. eauto. - * cbn. - destruct x, y; cbn in *; subst. - destruct s as [s [Hs IH]]. eexists; eauto. - + + move: IHctxi. simpl. + rewrite -subst_instance_app. + rewrite -subst_instance_two_context. + rewrite -[List.rev (subst_instance i _)]map_rev. + clear -wfext Hsub cu. induction 1; cbn; constructor; simpl; eauto. + all:now rewrite -(subst_instance_subst_telescope i [_]). + + eapply IHc in cu => //. + now rewrite subst_instance_mkApps map_app in cu. + + rewrite -{1}(map_id (ind_ctors idecl)). + eapply All2i_map. eapply All2i_impl; eauto. + cbn -[case_branch_type case_branch_context subst_instance]. + intros k cdecl br [[hctx ihctx] [[hbod hcbctx] [ihbod [hbty ihbty]]]]. + repeat split. + * rewrite -[_ ++ _](subst_instance_app). + now apply hctx. + * specialize (hcbctx i univs wfext Hsub cu). + rewrite subst_instance_app_ctx subst_instance_case_branch_context_gen in hcbctx. + now rewrite case_branch_type_fst forget_types_subst_instance. + * rewrite -[_ ++ _](subst_instance_app). + eapply (conv_ctx_subst_instance Σ i univs) in ihctx; tea. + 2:{ destruct Hsub; aa. } + rewrite case_branch_type_fst. + rewrite !subst_instance_app subst_instance_case_branch_context_gen in ihctx. + rewrite forget_types_subst_instance; cbn -[subst_instance]. + now rewrite subst_instance_app. + * specialize (ihbod i univs wfext Hsub cu). + rewrite subst_instance_case_branch_type. + cbn. rewrite -[_ ++ _]subst_instance_app_ctx. + eapply ihbod. + * specialize (ihbty i univs wfext Hsub cu). + rewrite subst_instance_case_branch_type. + cbn. rewrite -[_ ++ _]subst_instance_app_ctx. + eapply ihbty. - intros p c u mdecl idecl pdecl isdecl args X X0 X1 X2 H u0 univs wfΣ' HSub H0. - rewrite <- subst_subst_instance_constr. cbn. - rewrite !subst_instance_constr_two. - rewrite map_rev. econstructor; eauto. 2:now rewrite map_length. - eapply X2 in H0; tas. rewrite subst_instance_constr_mkApps in H0. + rewrite subst_instance_subst. cbn. + rewrite !subst_instance_two. + rewrite {4}/subst_instance /subst_instance_list /=. + rewrite map_rev. + econstructor; eauto. 2:now rewrite map_length. + eapply X2 in H0; tas. rewrite subst_instance_mkApps in H0. eassumption. - intros mfix n decl H H0 H1 X X0 wffix u univs wfΣ' HSub. - erewrite map_dtype. econstructor. + rewrite (map_dtype _ (subst_instance u)). econstructor. + now eapply fix_guard_subst_instance. - + rewrite nth_error_map, H0. reflexivity. - + eapply H1; eauto. + + rewrite nth_error_map H0. reflexivity. + + specialize (H1 u univs wfΣ' HSub H2). + rewrite subst_instance_app in H1. + now eapply wf_local_app_inv in H1 as []. + apply All_map, (All_impl X); simpl; intuition auto. destruct X1 as [s Hs]. exists (subst_instance_univ u s). now apply Hs. + eapply All_map, All_impl; tea. intros x [X1 X3]. - specialize (X3 u univs wfΣ' HSub H2). erewrite map_dbody in X3. - rewrite <- lift_subst_instance_constr in X3. - rewrite fix_context_length, map_length in *. - erewrite map_dtype with (d := x) in X3. - unfold subst_instance_context, map_context in *. - rewrite map_app in *. - rewrite <- (fix_context_subst_instance u mfix). + specialize (X3 u univs wfΣ' HSub 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). len. eapply X3. + red; rewrite <- wffix. unfold wf_fixpoint. @@ -1671,22 +1997,24 @@ Proof. now rewrite subst_instance_check_one_fix. - intros mfix n decl guard H X X0 X1 wfcofix u univs wfΣ' HSub H1. - erewrite map_dtype. econstructor; tas. + rewrite (map_dtype _ (subst_instance u)). econstructor; tas. + now eapply cofix_guard_subst_instance. - + rewrite nth_error_map, H. reflexivity. - + apply X; eauto. + + rewrite nth_error_map H. reflexivity. + + specialize (X u univs wfΣ' HSub H1). + rewrite subst_instance_app in X. + now eapply wf_local_app_inv in X as []. + apply All_map, (All_impl X0); simpl; intuition auto. destruct X2 as [s Hs]. exists (subst_instance_univ u s). now apply Hs. + eapply All_map, All_impl; tea. intros x [X1' X3]. - * specialize (X3 u univs wfΣ' HSub H1). erewrite map_dbody in X3. - rewrite <- lift_subst_instance_constr in X3. - rewrite fix_context_length, map_length in *. - unfold subst_instance_context, map_context in *. - rewrite map_app in *. + * specialize (X3 u univs wfΣ' HSub H1). + 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 subst_instance_app in X3. rewrite <- (fix_context_subst_instance u mfix). - rewrite <- map_dtype. eapply X3. + rewrite <- map_dtype. len. eapply X3. + red; rewrite <- wfcofix. unfold wf_cofixpoint. rewrite map_map_compose. @@ -1704,8 +2032,8 @@ Lemma typing_subst_instance' Σ φ Γ t T u univs : (Σ, univs) ;;; Γ |- t : T -> sub_context_set (monomorphic_udecl univs) (global_ext_context_set (Σ, φ)) -> consistent_instance_ext (Σ, φ) univs u -> - (Σ, φ) ;;; subst_instance_context u Γ - |- subst_instance_constr u t : subst_instance_constr u T. + (Σ, φ) ;;; subst_instance u Γ + |- subst_instance u t : subst_instance u T. Proof. intros X X0 X1. eapply (typing_subst_instance (Σ, univs)); tas. apply X. @@ -1716,7 +2044,7 @@ Lemma typing_subst_instance_wf_local Σ φ Γ u univs : wf_local (Σ, univs) Γ -> sub_context_set (monomorphic_udecl univs) (global_ext_context_set (Σ, φ)) -> consistent_instance_ext (Σ, φ) univs u -> - wf_local (Σ, φ) (subst_instance_context u Γ). + wf_local (Σ, φ) (subst_instance u Γ). Proof. intros X X0 X1. eapply (env_prop_wf_local _ _ typing_subst_instance (Σ, univs)); tas. 1: apply X. @@ -1755,8 +2083,8 @@ Lemma typing_subst_instance'' Σ φ Γ t T u univs : (Σ, univs) ;;; Γ |- t : T -> sub_context_set (monomorphic_udecl univs) (global_context_set Σ) -> consistent_instance_ext (Σ, φ) univs u -> - (Σ, φ) ;;; subst_instance_context u Γ - |- subst_instance_constr u t : subst_instance_constr u T. + (Σ, φ) ;;; subst_instance u Γ + |- subst_instance u t : subst_instance u T. Proof. intros X X0 X1. eapply (typing_subst_instance (Σ, univs)); tas. 1: apply X. @@ -1768,8 +2096,8 @@ Lemma typing_subst_instance_ctx (Σ : global_env_ext) Γ t T ctx u : on_udecl_prop Σ (Polymorphic_ctx ctx) -> (Σ.1, Polymorphic_ctx ctx) ;;; Γ |- t : T -> consistent_instance_ext Σ (Polymorphic_ctx ctx) u -> - Σ ;;; subst_instance_context u Γ - |- subst_instance_constr u t : subst_instance_constr u T. + Σ ;;; subst_instance u Γ + |- subst_instance u t : subst_instance u T. Proof. destruct Σ as [Σ φ]. intros X X0 X1. eapply typing_subst_instance''; tea. @@ -1784,8 +2112,8 @@ Lemma typing_subst_instance_decl Σ Γ t T c decl u : lookup_env Σ.1 c = Some decl -> (Σ.1, universes_decl_of_decl decl) ;;; Γ |- t : T -> consistent_instance_ext Σ (universes_decl_of_decl decl) u -> - Σ ;;; subst_instance_context u Γ - |- subst_instance_constr u t : subst_instance_constr u T. + Σ ;;; subst_instance u Γ + |- subst_instance u t : subst_instance u T. Proof. destruct Σ as [Σ φ]. intros X X0 X1 X2. eapply typing_subst_instance''; tea. @@ -1799,7 +2127,7 @@ Lemma isType_subst_instance_decl Σ Γ T c decl u : lookup_env Σ.1 c = Some decl -> isType (Σ.1, universes_decl_of_decl decl) Γ T -> consistent_instance_ext Σ (universes_decl_of_decl decl) u -> - isType Σ (subst_instance_context u Γ) (subst_instance_constr u T). + isType Σ (subst_instance u Γ) (subst_instance u T). Proof. intros wfΣ look [s Hs] cu. exists (subst_instance u s). @@ -1813,7 +2141,7 @@ Lemma wf_local_subst_instance Σ Γ ext u : wf_global_ext Σ.1 ext -> consistent_instance_ext Σ ext u -> wf_local (Σ.1, ext) Γ -> - wf_local Σ (subst_instance_context u Γ). + wf_local Σ (subst_instance u Γ). Proof. destruct Σ as [Σ φ]. intros X X0 X1. simpl in *. induction X1; cbn; constructor; auto. @@ -1830,7 +2158,7 @@ Lemma wf_local_subst_instance_decl Σ Γ c decl u : lookup_env Σ.1 c = Some decl -> wf_local (Σ.1, universes_decl_of_decl decl) Γ -> consistent_instance_ext Σ (universes_decl_of_decl decl) u -> - wf_local Σ (subst_instance_context u Γ). + wf_local Σ (subst_instance u Γ). Proof. destruct Σ as [Σ φ]. intros X X0 X1 X2. induction X1; cbn; constructor; auto. @@ -1858,9 +2186,9 @@ Section SubstIdentity. simpl. intros [= Hl]. f_equal. now rewrite mapi_rec_Sk. Qed. - Lemma subst_instance_instance_id Σ u mdecl : + Lemma subst_instance_id_mdecl Σ u mdecl : consistent_instance_ext Σ (ind_universes mdecl) u -> - subst_instance_instance u (PCUICLookup.abstract_instance (ind_universes mdecl)) = u. + subst_instance u (PCUICLookup.abstract_instance (ind_universes mdecl)) = u. Proof. intros cu. red in cu. red in cu. @@ -1989,7 +2317,7 @@ Section SubstIdentity. Lemma consistent_instance_ext_subst_abs Σ decl u : wf_ext_wk Σ -> consistent_instance_ext Σ decl u -> - subst_instance_instance (PCUICLookup.abstract_instance Σ.2) u = u. + subst_instance (PCUICLookup.abstract_instance Σ.2) u = u. Proof. intros [wfΣ onu] cu. destruct decl. @@ -2053,54 +2381,145 @@ Section SubstIdentity. now rewrite in_global_ext_subst_abs_level. Qed. + Lemma consistent_instance_ext_subst_abs_inds Σ decl ind u bodies : + wf_ext_wk Σ -> + consistent_instance_ext Σ decl u -> + subst_instance (PCUICLookup.abstract_instance Σ.2) (inds ind u bodies) = + (inds ind u bodies). + Proof. + intros wf cu. + unfold inds. generalize #|bodies|. + induction n; simpl; auto. rewrite IHn; f_equal. + now rewrite [subst_instance_instance _ _](consistent_instance_ext_subst_abs _ _ _ wf cu). + Qed. + + Lemma wf_universe_type1 Σ : wf_universe Σ Universe.type1. + Proof. + simpl. + intros l hin%UnivExprSet.singleton_spec. + subst l. simpl. + apply LS.union_spec. right; apply global_levels_Set. + Qed. + + Lemma wf_universe_super {Σ u} : wf_universe Σ u -> wf_universe Σ (Universe.super u). + Proof. + destruct u; cbn. + 1-2:intros _ l hin%UnivExprSet.singleton_spec; subst l; apply wf_universe_type1; + now apply UnivExprSet.singleton_spec. + intros Hl. + 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) : + #|l| = #|l0| -> + l ++ l' = l0 ++ l0' -> + l = l0 /\ l' = l0'. + Proof. + induction l in l', l0, l0' |- *; destruct l0; simpl in * => //; auto. + intros [= eq] [= -> eql]. + now destruct (IHl _ _ _ eq eql). + Qed. + Lemma subst_abstract_instance_id : env_prop (fun Σ Γ t T => wf_ext_wk Σ -> let u := PCUICLookup.abstract_instance (snd Σ) in - subst_instance_constr u t = t) - (fun Σ Γ wfΓ => + subst_instance u t = t × subst_instance u T = T) + (fun Σ Γ => wf_ext_wk Σ -> let u := PCUICLookup.abstract_instance (snd Σ) in - subst_instance_context u Γ = Γ). + subst_instance u Γ = Γ). Proof. - eapply typing_ind_env; intros; simpl in *; auto; try ((subst u || subst u0); f_equal; eauto; try congruence). - - - induction X; simpl; auto; unfold snoc. + eapply typing_ind_env; intros; simpl in *; auto; try ((subst u || subst u0); split; [f_equal|]; intuition eauto). + 1:{ induction X; simpl; auto; unfold snoc. * f_equal; auto. - unfold map_decl. simpl. unfold vass. f_equal. auto. - * unfold map_decl. simpl. unfold vdef. repeat 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. - - eapply consistent_instance_ext_subst_abs; eauto. - - - eapply consistent_instance_ext_subst_abs; eauto. - - - eapply consistent_instance_ext_subst_abs; eauto. - - - solve_all. + - rewrite consistent_instance_ext_subst_abs_univ //. + now apply wf_universe_super. + + - rewrite product_subst_instance. f_equal; + intuition eauto; now noconf b0; noconf b1. + + - intuition auto. noconf a; noconf b; noconf b0. + rewrite subst_instance_subst /= /subst1. + repeat (f_equal; simpl; auto). + + - rewrite /type_of_constructor subst_instance_subst subst_instance_two. + erewrite consistent_instance_ext_subst_abs; eauto. f_equal. + eapply consistent_instance_ext_subst_abs_inds; eauto. + + - solve_all; simpl in *. + * rewrite subst_instance_mkApps /= /subst_instance /= in b0. + eapply mkApps_nApp_inj in b0 as [Hi Hpars] => //. + now noconf Hi. + * rewrite subst_instance_mkApps /= /subst_instance /= in b0. + eapply mkApps_nApp_inj in b0 as [Hi Hpars] => //. + rewrite map_app in Hpars. + eapply app_inj in Hpars as [Hpars hinds]. 2:now len. + rewrite -{2}(map_id (pparams p)) in Hpars. + now apply map_eq_inj in Hpars. + * rewrite subst_instance_app in H. + now eapply app_inj in H as [Hpars hΓ]; len. - solve_all. - destruct a as [s [dty eqdty]]. - solve_all. + rewrite subst_instance_app in H4. + now eapply app_inj in H4 as [Hpars hΓ]; len. + + - rewrite subst_instance_mkApps. f_equal. + * rewrite /ptm. + rewrite subst_instance_it_mkLambda_or_LetIn. + rewrite subst_instance_app in H. + eapply app_inj in H as []; [|now len]. + rewrite H. now f_equal. + * rewrite map_app. + rewrite subst_instance_mkApps /= /subst_instance /= in b0. + eapply mkApps_nApp_inj in b0 as [Hi Hpars] => //. + rewrite map_app in Hpars. + eapply app_inj in Hpars as [Hpars hinds]. 2:now len. + now rewrite hinds /= a0. + - rewrite subst_instance_subst /=. + rewrite /subst_instance /=. + rewrite subst_instance_mkApps in b. + eapply mkApps_nApp_inj in b as [Hi Hpars] => //. + f_equal. + * rewrite a; f_equal. + rewrite /subst_instance_list. now rewrite map_rev Hpars. + * rewrite [subst_instance_constr _ _]subst_instance_two. + noconf Hi. now rewrite [subst_instance _ u]H. + - solve_all. destruct a as [s [? ?]]; solve_all. + - clear X0. eapply nth_error_all in X as [s [Hs [IHs _]]]; eauto. - solve_all. destruct a as [s [? ?]]. solve_all. + - clear X0. eapply nth_error_all in X as [s [Hs [IHs _]]]; eauto. Qed. Lemma typed_subst_abstract_instance Σ Γ t T : wf_ext_wk Σ -> Σ ;;; Γ |- t : T -> let u := PCUICLookup.abstract_instance Σ.2 in - subst_instance_constr u t = t. + subst_instance u t = t. Proof. - intros [wfΣ onu] H. eapply (env_prop_typing _ _ subst_abstract_instance_id) in H; eauto. + intros [wfΣ onu] H. eapply (env_prop_typing _ _ subst_abstract_instance_id) in H as [H H']; eauto. split; auto. Qed. - Lemma subst_instance_context_id Σ Γ : + Lemma subst_instance_id Σ Γ : wf_ext_wk Σ -> wf_local Σ Γ -> let u := PCUICLookup.abstract_instance Σ.2 in - subst_instance_context u Γ = Γ. + subst_instance u Γ = Γ. Proof. intros. eapply (env_prop_wf_local _ _ subst_abstract_instance_id) in X0; eauto. apply X. @@ -2108,19 +2527,18 @@ Section SubstIdentity. Lemma subst_instance_ind_sort_id Σ mdecl ind idecl : wf Σ -> - declared_inductive Σ mdecl ind idecl -> - forall (oib : on_ind_body (lift_typing typing) (Σ, ind_universes mdecl) - (inductive_mind ind) mdecl (inductive_ind ind) idecl), + declared_inductive Σ ind mdecl idecl -> let u := PCUICLookup.abstract_instance (ind_universes mdecl) in - subst_instance_univ u (ind_sort oib) = ind_sort oib. + subst_instance_univ u (ind_sort idecl) = ind_sort idecl. Proof. - intros wfΣ decli oib u. + intros wfΣ decli u. + pose proof (on_declared_inductive decli) as [onmind oib]. pose proof (onArity oib) as ona. rewrite (oib.(ind_arity_eq)) in ona. red in ona. destruct ona. eapply typed_subst_abstract_instance in t. 2:split; simpl; auto. - - rewrite !subst_instance_constr_it_mkProd_or_LetIn in t. + - rewrite !subst_instance_it_mkProd_or_LetIn in t. eapply (f_equal (destArity [])) in t. rewrite !destArity_it_mkProd_or_LetIn in t. simpl in t. noconf t. simpl in H; noconf H. apply H0. @@ -2131,12 +2549,12 @@ Section SubstIdentity. Lemma subst_instance_ind_type_id Σ mdecl ind idecl : wf Σ -> - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> let u := PCUICLookup.abstract_instance (ind_universes mdecl) in - subst_instance_constr u (ind_type idecl) = ind_type idecl. + subst_instance u (ind_type idecl) = ind_type idecl. Proof. intros wfΣ decli u. - pose proof (on_declared_inductive wfΣ decli) as [_ oib]. + pose proof (on_declared_inductive decli) as [_ oib]. pose proof (onArity oib) as ona. rewrite (oib.(ind_arity_eq)) in ona |- *. red in ona. destruct ona. @@ -2149,7 +2567,7 @@ Section SubstIdentity. Lemma isType_subst_instance_id Σ Γ T : wf_ext_wk Σ -> let u := PCUICLookup.abstract_instance Σ.2 in - isType Σ Γ T -> subst_instance_constr u T = T. + isType Σ Γ T -> subst_instance u T = T. Proof. intros wf_ext u isT. destruct isT. eapply typed_subst_abstract_instance in t; auto. diff --git a/pcuic/theories/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index dd01730c4..4a13502a4 100644 --- a/pcuic/theories/PCUICValidity.v +++ b/pcuic/theories/PCUICValidity.v @@ -2,20 +2,22 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst - PCUICLiftSubst PCUICTyping PCUICWeakeningEnv PCUICWeakening PCUICInversion + PCUICLiftSubst PCUICTyping PCUICSigmaCalculus + PCUICClosed PCUICWeakeningEnv PCUICWeakening PCUICInversion PCUICSubstitution PCUICReduction PCUICCumulativity PCUICGeneration - PCUICUnivSubst PCUICParallelReductionConfluence + PCUICUnivSubst PCUICUnivSubstitution PCUICConfluence PCUICUnivSubstitution PCUICConversion PCUICContexts PCUICArities PCUICSpine PCUICInductives - PCUICContexts PCUICWfUniverses - PCUICSigmaCalculus PCUICClosed. - + PCUICContexts PCUICWfUniverses. + From Equations Require Import Equations. Require Import Equations.Prop.DepElim. Require Import ssreflect ssrbool. Derive Signature for typing cumul. +Implicit Types (cf : checker_flags) (Σ : global_env_ext). + Arguments Nat.sub : simpl never. Section Validity. @@ -79,7 +81,7 @@ Section Validity. lookup_env Σ.1 c = Some decl -> isType (Σ.1, universes_decl_of_decl decl) Γ T -> consistent_instance_ext Σ (universes_decl_of_decl decl) u -> - isType Σ (subst_instance_context u Γ) (subst_instance_constr u T). + isType Σ (subst_instance u Γ) (subst_instance u T). Proof. destruct Σ as [Σ φ]. intros X X0 [s Hs] X1. exists (subst_instance_univ u s). @@ -91,11 +93,11 @@ Section Validity. lookup_env Σ.1 c = Some decl -> isWfArity (Σ.1, universes_decl_of_decl decl) Γ T -> consistent_instance_ext Σ (universes_decl_of_decl decl) u -> - isWfArity Σ (subst_instance_context u Γ) (subst_instance_constr u T). + isWfArity Σ (subst_instance u Γ) (subst_instance u T). Proof. destruct Σ as [Σ φ]. intros X X0 [isTy [ctx [s eq]]] X1. split. eapply isType_subst_instance_decl; eauto. - exists (subst_instance_context u ctx), (subst_instance_univ u s). + exists (subst_instance u ctx), (subst_instance_univ u s). rewrite (subst_instance_destArity []) eq. intuition auto. Qed. @@ -110,28 +112,172 @@ Section Validity. eapply (weaken_ctx (Γ:=[])); eauto. Qed. - Theorem validity : + Lemma nth_error_All_local_env {P : context -> term -> option term -> Type} {Γ n d} : + nth_error Γ n = Some d -> + All_local_env P Γ -> + on_local_decl P (skipn (S n) Γ) d. + Proof. + intros heq hΓ. + epose proof (nth_error_Some_length heq). + eapply (nth_error_All_local_env) in H; tea. + now rewrite heq in H. + Qed. + + Notation type_ctx := (type_local_ctx (lift_typing typing)). + Lemma type_ctx_wf_univ Σ Γ Δ s : type_ctx Σ Γ Δ s -> wf_universe Σ s. + Proof. + induction Δ as [|[na [b|] ty]]; simpl; auto with pcuic. + Qed. + Hint Resolve type_ctx_wf_univ : pcuic. + + Definition case_predicate_binder idecl ci p := + {| decl_name := {| + binder_name := nNamed (ind_name idecl); + binder_relevance := ind_relevance idecl |}; + decl_body := None; + decl_type := mkApps (tInd ci (puinst p)) + (map (lift0 #|ind_indices idecl|) (pparams p) ++ + to_extended_list (ind_indices idecl)) |}. + + Lemma All2_fold_All2 (P : context_decl -> context_decl -> Type) Γ Δ : + All2_fold (fun _ _ => P) Γ Δ <~> + All2 P Γ Δ. + Proof. + split; induction 1; constructor; auto. + 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'''} : + All2 R l l''' -> + All2 Q l' l'' -> + #|l| = #|l'| -> + (forall x y z w, R x w -> Q y z -> P (f x y) z) -> + All2 P (map2 f l l') l''. + Proof. + intros hb ha hlen hPQ. + induction ha in l, l''', hlen, hb |- *; simpl; try constructor; auto. + - destruct l => //. simpl. constructor. + - destruct l => //. + noconf hlen. depelim hb. + specialize (IHha _ _ hb H). + 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''} : + 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''} : + All3 P l l' l'' -> + (forall x y z, P x y z -> Q x y z) -> + All3 Q l l' l''. + Proof. + induction 1; constructor; auto. + 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 l1 ++ map2 f l0' l1'. + Proof. + induction l0 in l0', l1, l1' |- *; simpl; auto. + - destruct l1 => //. + - destruct l1 => /= // [=] hl hl'. + now rewrite IHl0. + Qed. + + Notation liat := ltac:(lia) (only parsing). + + 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 Σ Σ) + (map2 set_binder_name nas Δ) Δ. + Proof. + induction Δ in nas |- * using PCUICInduction.ctx_length_rev_ind; simpl; intros hlen. + - depelim hlen. simpl. reflexivity. + - destruct nas as [|nas na] using rev_case => //; + pose proof (All2_length hlen) as hlen';len in hlen'; simpl in hlen'; try lia. + eapply All2_app_inv_l in hlen as (l1'&l2'&heq&alnas&allna). + depelim allna. depelim allna. + rewrite map2_app => /= //; try lia. unfold aname. lia. + eapply app_inj_tail in heq as [<- <-]. + simpl. eapply PCUICContextRelation.All2_fold_app; auto. + pose proof (All2_length alnas). + rewrite map2_length => //. + constructor. constructor. + 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 -> + PCUICEquality.eq_term Σ Σ (it_mkProd_or_LetIn (map2 set_binder_name nas Δ) T) (it_mkProd_or_LetIn Δ U) . + Proof. + intros a; unshelve eapply eq_binder_annots_eq_ctx in a; tea. + eapply All2_fold_All2 in a. + induction a in T, U |- *. + - auto. + - rewrite /= /mkProd_or_LetIn. + destruct r => /=; intros; eapply IHa; + constructor; auto. + Qed. + + 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 Γ -> + All2 + (fun (x : binder_annot name) (y : context_decl) => + eq_binder_annot x (decl_name y)) l + (subst_context s k + (subst_instance i + (expand_lets_ctx Δ Γ))). + Proof. + intros. eapply All2_map_right in X. + depind X. + * destruct Γ => //. constructor. + * destruct Γ => //. + rewrite /expand_lets_ctx /expand_lets_k_ctx /= + !lift_context_snoc; simpl. + rewrite subst_context_snoc /= lift_context_length /= + subst_instance_cons subst_context_snoc subst_instance_length + subst_context_length lift_context_length. + constructor. simpl. simpl in H. now noconf H. + eapply IHX. simpl in H. now noconf H. + Qed. + + 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)) + (pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p)). + Proof. + move=> [] hlen /Forall2_All2. rewrite /pre_case_predicate_context_gen. + intros a; depind a. rewrite H. + constructor. simpl. now simpl in r. + clear -a. + now eapply All2_eq_binder_subst_context_inst. + Qed. + + Theorem validity_env : env_prop (fun Σ Γ t T => isType Σ Γ T) - (fun Σ Γ wfΓ => - All_local_env_over typing - (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ) - (t T : term) (_ : Σ;;; Γ |- t : T) => isType Σ Γ T) Σ Γ - wfΓ). + (fun Σ Γ => wf_local Σ Γ × All_local_env + (fun Γ t T => match T with Some T => isType Σ Γ T | None => isType Σ Γ t end) Γ). Proof. apply typing_ind_env; intros; rename_all_hyps. - - auto. + - split => //. induction X; constructor; auto. - - destruct (nth_error_All_local_env_over heq_nth_error X) as [HΓ' Hd]. + - destruct X as [_ X]. + have hd := (nth_error_All_local_env heq_nth_error X). destruct decl as [na [b|] ty]; cbn -[skipn] in *. - + destruct Hd as [Hd _]. - eapply isType_lift; eauto. clear HΓ'. + + eapply isType_lift; eauto. now apply nth_error_Some_length in heq_nth_error. - + destruct lookup_wf_local_decl; cbn -[skipn] in *. - destruct o. simpl in Hd. - eapply isType_lift; eauto. + + eapply isType_lift; eauto. now apply nth_error_Some_length in heq_nth_error. - exists x0. auto. - (* Universe *) exists (Universe.super (Universe.super u)). @@ -164,7 +310,7 @@ Section Validity. move: (typing_wf_universe wf Hu') => wfu'. eapply (substitution0 _ _ na _ _ _ (tSort u')); eauto. apply inversion_Prod in Hu' as [na' [s1 [s2 Hs]]]; tas. intuition. - eapply (weakening_cumul Σ Γ [] [vass na A]) in b; pcuic. + eapply (weakening_cumul Σ Γ [] [vass na A]) in b0; pcuic. simpl in b. eapply type_Cumul; eauto. econstructor; eauto. @@ -177,21 +323,21 @@ Section Validity. eapply isType_weakening; eauto. eapply (isType_subst_instance_decl (Γ:=[])); eauto. simpl. eapply weaken_env_prop_isType. - * have ond := on_declared_constant _ _ _ wf H. + * have ond := on_declared_constant wf H. do 2 red in ond. simpl in ond. simpl in ond. eapply isType_weakening; eauto. eapply (isType_subst_instance_decl (Γ:=[])); eauto. - (* Inductive type *) - destruct (on_declared_inductive wf isdecl); pcuic. + destruct (on_declared_inductive isdecl); pcuic. destruct isdecl. apply onArity in o0. eapply isType_weakening; eauto. eapply (isType_subst_instance_decl (Γ:=[])); eauto. - (* Constructor type *) - destruct (on_declared_constructor wf isdecl) as [[oni oib] [cs [declc onc]]]. + destruct (on_declared_constructor isdecl) as [[oni oib] [cs [declc onc]]]. unfold type_of_constructor. have ctype := on_ctype onc. destruct ctype as [s' Hs]. @@ -200,58 +346,58 @@ Section Validity. 2:(destruct isdecl as [[] ?]; eauto). simpl in Hs. eapply (weaken_ctx (Γ:=[]) Γ); eauto. - eapply (substitution _ [] _ (inds _ _ _) [] _ (tSort _)); eauto. + eapply (PCUICSubstitution.substitution _ [] _ (inds _ _ _) [] _ (tSort _)); eauto. eapply subslet_inds; eauto. destruct isdecl; eauto. now rewrite app_context_nil_l. - (* Case predicate application *) - eapply (isType_mkApps_Ind wf isdecl) in X4 as [parsubst [argsubst Hind]]; auto. - destruct (on_declared_inductive wf isdecl) as [onmind oib]. simpl in Hind. - destruct Hind as [[sparsubst sargsubst] cu]. - subst npar. - eapply (build_case_predicate_type_spec _ _ _ _ _ _ _ _ oib) in heq_build_case_predicate_type as - [pars [cs eqty]]. - exists ps. + assert (cu : consistent_instance_ext Σ (ind_universes mdecl) (puinst p)). + { eapply (isType_mkApps_Ind_inv wf isdecl) in X8 as [parsubst [argsubst Hind]]; + repeat intuition auto. } + unshelve epose proof (ctx_inst_spine_subst _ X5); tea. + eapply weaken_wf_local; tea. + now apply (on_minductive_wf_params_indices_inst isdecl _ cu). + eapply spine_subst_smash in X7; tea. + destruct (on_declared_inductive isdecl) as [onmind oib]. + rewrite /ptm. exists ps. red. eapply type_mkApps; eauto. + eapply type_it_mkLambda_or_LetIn; tea. + eapply typing_spine_strengthen; tea. + 2:{ etransitivity. eapply conv_cumul. + eapply PCUICContextRelation.All2_fold_app_inv in X2 as []. + eapply conv_it_mkProd_or_LetIn. tea. tea. reflexivity. + now rewrite (case_predicate_context_length H0). + rewrite /predctx /= /case_predicate_context /case_predicate_context_gen. + constructor. + eapply PCUICEquality.eq_term_leq_term. + eapply eq_term_set_binder_name. 2:reflexivity. + now eapply wf_pre_case_predicate_context_gen. } + rewrite /pre_case_predicate_context_gen. + set (iass := {| decl_name := _ |}). eapply wf_arity_spine_typing_spine; auto. + rewrite subst_instance_app_ctx in X7. + eapply spine_subst_smash_app_inv in X7 as [sppars spidx]. + 2:{ rewrite (wf_predicate_length_pars H0). len. + now rewrite onmind.(onNpars). } split; auto. - rewrite eqty. - assert(wf_universe Σ ps). - { rewrite eqty in X2. eapply isType_wf_universes in X2. - rewrite wf_universes_it_mkProd_or_LetIn in X2. - move/andP: X2 => [_ /andP[_ H]]; pcuic. - now apply/wf_universe_reflect. auto. } - clear typep eqty X2. - eapply arity_spine_it_mkProd_or_LetIn; auto. - pose proof (context_subst_fun cs sparsubst). subst pars. - eapply sargsubst. - simpl. constructor; first last. - constructor; auto. - rewrite subst_mkApps. - simpl. - rewrite map_app. subst params. - rewrite map_map_compose. rewrite map_subst_lift_id_eq. - rewrite (subslet_length sargsubst). now autorewrite with len. - unfold to_extended_list. - eapply spine_subst_subst_to_extended_list_k in sargsubst. - rewrite to_extended_list_k_subst - PCUICSubstitution.map_subst_instance_constr_to_extended_list_k in sargsubst. - rewrite sargsubst firstn_skipn. eauto. + * eapply isType_case_predicate => //; pcuic. + * eapply arity_spine_case_predicate => //; pcuic. - (* Proj *) pose proof isdecl as isdecl'. eapply declared_projection_type in isdecl'; eauto. subst ty. - destruct isdecl' as [s Hs]. - unshelve eapply isType_mkApps_Ind in X2 as [parsubst [argsubst [[sppar sparg] cu]]]; eauto. - eapply isdecl.p1. + destruct isdecl' as [s Hs]. red in Hs. + unshelve eapply isType_mkApps_Ind_inv in X2 as [parsubst [argsubst [[sppar sparg] cu]]]; eauto. + 2:eapply isdecl.p1. eapply (typing_subst_instance_decl _ _ _ _ _ _ _ wf isdecl.p1.p1) in Hs; eauto. simpl in Hs. exists (subst_instance_univ u s). unfold PCUICTypingDef.typing in *. eapply (weaken_ctx Γ) in Hs; eauto. rewrite -heq_length in sppar. rewrite firstn_all in sppar. - rewrite subst_instance_context_smash in Hs. simpl in Hs. + rewrite subst_instance_cons in Hs. + rewrite subst_instance_smash in Hs. simpl in Hs. eapply spine_subst_smash in sppar => //. eapply (substitution _ Γ _ _ [_] _ _ wf sppar) in Hs. simpl in Hs. @@ -259,10 +405,10 @@ Section Validity. simpl in Hs. rewrite (subst_app_simpl [_]) /= //. constructor. constructor. simpl. rewrite subst_empty. - rewrite subst_instance_constr_mkApps subst_mkApps /=. - rewrite (subst_instance_instance_id Σ); auto. + rewrite subst_instance_mkApps subst_mkApps /=. + rewrite [subst_instance_instance _ _](subst_instance_id_mdecl Σ u _ cu); auto. rewrite subst_instance_to_extended_list. - rewrite subst_instance_context_smash. + rewrite subst_instance_smash. rewrite (spine_subst_subst_to_extended_list_k sppar). assumption. @@ -279,13 +425,17 @@ Section Validity. End Validity. -Lemma validity_term {cf:checker_flags} {Σ Γ t T} : - wf Σ.1 -> Σ ;;; Γ |- t : T -> isType Σ Γ T. +Corollary validity {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ t T} : + Σ ;;; Γ |- t : T -> isType Σ Γ T. Proof. - intros. eapply validity; try eassumption. + intros. eapply validity_env; try eassumption. Defined. -(* This corollary relies strongly on validity. +(* To deprecate *) +Notation validity_term wf Ht := (validity (wfΣ:=wf) Ht). + +(* 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. *) @@ -296,11 +446,11 @@ Lemma inversion_mkApps : ∑ A, Σ ;;; Γ |- t : A × typing_spine Σ Γ A l T. Proof. intros cf Σ Γ f u T wfΣ; induction u in f, T |- *. simpl. intros. - { exists T. intuition pcuic. constructor. eapply validity; auto with pcuic. + { exists T. intuition pcuic. constructor. eapply validity_env; auto with pcuic. eauto. eapply cumul_refl'. } intros Hf. simpl in Hf. destruct u. simpl in Hf. - - pose proof (env_prop_typing _ _ validity _ wfΣ _ _ _ Hf). simpl in X. + - pose proof (env_prop_typing _ _ validity_env _ wfΣ _ _ _ Hf). simpl in X. eapply inversion_App in Hf as [na' [A' [B' [Hf' [Ha HA''']]]]]. eexists _; intuition eauto. econstructor; eauto with pcuic. eapply validity; eauto with wf pcuic. @@ -321,6 +471,18 @@ Lemma type_App' {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t na Σ;;; Γ |- u : A -> Σ;;; Γ |- tApp t u : B {0 := u}. Proof. intros Ht Hu. - have [s Hs] := validity_term wfΣ Ht. + have [s Hs] := validity Ht. eapply type_App; eauto. -Qed. \ No newline at end of file +Qed. + +Lemma type_mkApps_arity {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t u tty T} : + Σ;;; Γ |- t : tty -> + arity_spine Σ Γ tty u T -> + Σ;;; Γ |- mkApps t u : T. +Proof. + intros Ht Hty. + pose proof (validity Ht). + eapply type_mkApps; tea. + eapply wf_arity_spine_typing_spine; tea. + constructor; tas. +Qed. diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index d5b17f105..8488e2eaf 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -93,7 +93,7 @@ Definition isConstruct t := | _ => false end. -Definition isAssRel Γ x := +Definition isAssRel (Γ : context) x := match x with | tRel i => match option_map decl_body (nth_error Γ i) with @@ -180,7 +180,7 @@ Section Wcbv. (** Constant unfolding *) | eval_delta c decl body (isdecl : declared_constant Σ c decl) u res : decl.(cst_body) = Some body -> - eval (subst_instance_constr u body) res -> + eval (subst_instance u body) res -> eval (tConst c u) res (** Axiom *) @@ -189,10 +189,12 @@ Section Wcbv. eval (tConst c u) (tConst c u) (** Case *) - | eval_iota ind pars discr c u args p brs res : - eval discr (mkApps (tConstruct ind c u) args) -> - eval (iota_red pars c args brs) res -> - eval (tCase (ind, pars) p discr brs) res + | eval_iota ci discr c u args p brs br res : + eval discr (mkApps (tConstruct ci.(ci_ind) c u) args) -> + nth_error brs c = Some br -> + #|skipn ci.(ci_npar) args| = context_assumptions br.(bcontext) -> + eval (iota_red ci.(ci_npar) args br) res -> + eval (tCase ci p discr brs) res (** Proj *) | eval_proj i pars arg discr args u a res : @@ -468,7 +470,7 @@ Section Wcbv. rewrite isFixApp_mkApps => //. rewrite -mkApps_nested; simpl. rewrite orb_false_r. - destruct t; auto. + destruct t=> //. - destruct f; try discriminate. apply All_All2_refl in X0. now apply eval_stuck_fix. @@ -479,36 +481,47 @@ Section Wcbv. Lemma closed_def `{checker_flags} c decl u b : wf Σ -> declared_constant Σ c decl -> cst_body decl = Some b -> - closed (subst_instance_constr u b). + closed (subst_instance u b). Proof. move=> wfΣ Hc Hb. - rewrite PCUICClosed.closedn_subst_instance_constr. + rewrite PCUICClosed.closedn_subst_instance. apply declared_decl_closed in Hc => //. simpl in Hc. red in Hc. rewrite Hb in Hc. simpl in Hc. now move/andP: Hc. Qed. - Lemma closed_iota ind pars c u args brs : forallb (test_snd (closedn 0)) brs -> + + Lemma closed_iota ind pars c u args brs br : + forallb (test_branch_k closedn 0) brs -> closed (mkApps (tConstruct ind c u) args) -> - closed (iota_red pars c args brs). + #|skipn pars args| = context_assumptions (bcontext br) -> + nth_error brs c = Some br -> + closed (iota_red pars args br). Proof. - unfold iota_red => cbrs cargs. - eapply closedn_mkApps. solve_all. - rewrite nth_nth_error. - destruct (nth_error_spec brs c) as [br e|e]. - eapply All_nth_error in e; eauto. simpl in e. apply e. - auto. - eapply closedn_mkApps_inv in cargs. - move/andP: cargs => [Hcons Hargs]. now rewrite forallb_skipn. + unfold iota_red => cbrs cargs hass e. + solve_all. + eapply All_nth_error in e; eauto. simpl in e. + rewrite closedn_mkApps in cargs. + move/andP: cargs => [Hcons Hargs]. + eapply (closedn_subst _ 0 0). + now rewrite forallb_rev forallb_skipn //. + simpl. rewrite List.rev_length /expand_lets /expand_lets_k. + rewrite -(Nat.add_0_r #|skipn pars args|). + rewrite hass. + move/andP: e => [cltx clb]. + eapply (closedn_subst _ _ 0). + eapply closedn_extended_subst => //. + rewrite extended_subst_length Nat.add_0_r /= Nat.add_comm. + eapply closedn_lift. now rewrite Nat.add_0_r in clb. Qed. Lemma closed_arg f args n a : closed (mkApps f args) -> nth_error args n = Some a -> closed a. Proof. - move/closedn_mkApps_inv/andP => [cf cargs]. + rewrite closedn_mkApps. + move/andP => [cf cargs]. solve_all. eapply All_nth_error in cargs; eauto. Qed. - Lemma closed_unfold_fix mfix idx narg fn : closed (tFix mfix idx) -> unfold_fix mfix idx = Some (narg, fn) -> closed fn. @@ -606,32 +619,35 @@ Section Wcbv. - eapply IHev3. unshelve eapply closed_beta. 3:eauto. exact na. simpl. eauto. - eapply IHev2. now rewrite closed_csubst. - apply IHev. eapply closed_def; eauto. - - eapply IHev2. eapply closed_iota in Hc''. eauto. eauto. + - eapply IHev2. eapply closed_iota in Hc''; tea. + eapply IHev1; assumption. - eapply IHev2; auto. specialize (IHev1 Hc). - eapply closedn_mkApps_inv in IHev1. + rewrite closedn_mkApps in IHev1. move/andP: IHev1 => [Hcons Hargs]. solve_all. eapply All_nth_error in Hargs; eauto. - eapply IHev3. - apply andb_true_iff. + apply/andP. split; [|easy]. specialize (IHev1 Hc). - eapply closedn_mkApps_inv in IHev1. - apply andb_true_iff in IHev1. - eapply closedn_mkApps; [|easy]. + rewrite closedn_mkApps in IHev1. + move/andP: IHev1 => [clfix clargs]. + rewrite closedn_mkApps clargs andb_true_r. eapply closed_unfold_fix; [easy|]. now rewrite closed_unfold_fix_cunfold_eq. - apply andb_true_iff. split; [|easy]. solve_all. - - eapply IHev. move/closedn_mkApps_inv/andP: Hc' => [Hfix Hargs]. - repeat (apply/andP; split; auto). eapply closedn_mkApps. + - eapply IHev. rewrite closedn_mkApps. + rewrite closedn_mkApps in Hc'. move/andP: Hc' => [Hfix Hargs]. + repeat (apply/andP; split; auto). rewrite -closed_unfold_cofix_cunfold_eq in e => //. eapply closed_unfold_cofix in e; eauto. - auto. - - eapply IHev. move/closedn_mkApps_inv/andP: Hc => [Hfix Hargs]. - eapply closedn_mkApps; eauto. + - eapply IHev. rewrite closedn_mkApps in Hc *. + move/andP: Hc => [Hfix Hargs]. + rewrite closedn_mkApps Hargs. rewrite -closed_unfold_cofix_cunfold_eq in e => //. eapply closed_unfold_cofix in e; eauto. + now rewrite e. - apply/andP; split; auto. Qed. @@ -698,6 +714,17 @@ Section Wcbv. now induction p using le_ind_dep; intros q; depelim q. Qed. + Instance branch_UIP : UIP (branch term). + Proof. + eapply EqDec.eqdec_uip; tc. + Qed. + + Instance option_UIP {A} (u : EqDec A) : UIP (option A). + Proof. + eapply EqDec.eqdec_uip; tc. + eqdec_proof. + Qed. + Unset SsrRewrite. Lemma eval_unique_sig {t v v'} : forall (ev1 : eval t v) (ev2 : eval t v'), @@ -734,7 +761,10 @@ Section Wcbv. noconf eq1. noconf eq2. noconf IHev1. - now specialize (IHev2 _ ev'2); noconf IHev2. + pose proof e1. rewrite e in H. noconf H. + specialize (IHev2 _ ev'2); noconf IHev2. + assert (e = e1) as -> by now apply uip. + now assert (e0 = e2) as -> by now apply uip. + apply eval_mkApps_tCoFix in ev1 as H. destruct H as (? & ?); solve_discr. - depelim ev'; try go. @@ -764,7 +794,7 @@ Section Wcbv. + specialize (IHev1 _ ev'1). noconf IHev1. exfalso. - rewrite isFixApp_mkApps in i by easy. + rewrite isFixApp_mkApps in i; try easy. cbn in *. now rewrite Bool.orb_true_r in i. - depelim ev'; try go. @@ -786,7 +816,7 @@ Section Wcbv. + specialize (IHev1 _ ev'1). noconf IHev1. exfalso. - rewrite isFixApp_mkApps in i by easy. + rewrite isFixApp_mkApps in i; try easy. cbn in *. now rewrite Bool.orb_true_r in i. - depelim ev'; try go. @@ -814,12 +844,12 @@ Section Wcbv. - depelim ev'; try go. + specialize (IHev1 _ ev'1); noconf IHev1. exfalso. - rewrite isFixApp_mkApps in i by easy. + rewrite isFixApp_mkApps in i; try easy. cbn in *. now rewrite Bool.orb_true_r in i. + specialize (IHev1 _ ev'1); noconf IHev1. exfalso. - rewrite isFixApp_mkApps in i by easy. + rewrite isFixApp_mkApps in i; try easy. cbn in *. now rewrite Bool.orb_true_r in i. + specialize (IHev1 _ ev'1); noconf IHev1. @@ -860,7 +890,7 @@ Section Wcbv. eval (tConst c u) v -> ∑ decl, declared_constant Σ c decl * match cst_body decl with - | Some body => eval (subst_instance_constr u body) v + | Some body => eval (subst_instance u body) v | None => v = tConst c u end. Proof. @@ -882,11 +912,11 @@ Section Wcbv. Proof. revert l'. induction l using rev_ind; intros l' evf vf' evl. depelim evl. eapply evf. - eapply All2_app_inv in evl as [[? ?] [? ?]]. - intuition auto. subst. depelim a. depelim a. + eapply All2_app_inv_l in evl as (?&?&?&?&?). + intuition auto. subst. depelim a0. depelim a0. rewrite - !mkApps_nested /=. eapply eval_app_cong; auto. rewrite isFixApp_mkApps. auto. - destruct l0 using rev_ind; simpl; [|rewrite - !mkApps_nested]; simpl in *; destruct f'; + destruct x0 using rev_ind; simpl; [|rewrite - !mkApps_nested]; simpl in *; destruct f'; try discriminate; try constructor. Qed. Arguments removelast : simpl nomatch. diff --git a/pcuic/theories/PCUICWeakening.v b/pcuic/theories/PCUICWeakening.v index e9f27ea0d..0b0b95a02 100644 --- a/pcuic/theories/PCUICWeakening.v +++ b/pcuic/theories/PCUICWeakening.v @@ -1,38 +1,34 @@ (* Distributed under the terms of the MIT license. *) +From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICTyping PCUICWeakeningEnv - PCUICClosed PCUICReduction PCUICPosition PCUICGeneration. + PCUICClosed PCUICReduction PCUICPosition PCUICGeneration + PCUICSigmaCalculus PCUICRename PCUICOnFreeVars. -Require Import ssreflect. +Require Import ssreflect ssrbool. From Equations Require Import Equations. +Implicit Types cf : checker_flags. + (** * Weakening lemmas for typing derivations. [weakening_*] proves weakening of typing, reduction etc... w.r.t. the *local* environment. *) - Set Default Goal Selector "!". Generalizable Variables Σ Γ t T. -Derive Signature NoConfusion for All_local_env. -Derive Signature for All_local_env_over. - (* FIXME inefficiency in equations: using a very slow "pattern_sigma" to simplify an equality between sigma types *) Ltac Equations.CoreTactics.destruct_tele_eq H ::= noconf H. -(* Derive Signature NoConfusion for All_local_env. *) -Derive NoConfusion for All_local_env_over. -Derive NoConfusion for context_decl. - Lemma typed_liftn `{checker_flags} Σ Γ t T n k : wf Σ.1 -> wf_local Σ Γ -> k >= #|Γ| -> Σ ;;; Γ |- t : T -> lift n k T = T /\ lift n k t = t. Proof. intros wfΣ wfΓ Hk Hty. apply typecheck_closed in Hty; eauto. - destruct Hty as [_ Hcl]. + destruct Hty as [_ [_ Hcl]]. rewrite -> andb_and in Hcl. destruct Hcl as [clb clty]. pose proof (closed_upwards k clb). pose proof (closed_upwards k clty). @@ -42,13 +38,11 @@ Proof. now apply (lift_closed n) in H1. Qed. - Lemma closed_ctx_lift n k ctx : closed_ctx ctx -> lift_context n k ctx = ctx. Proof. induction ctx in n, k |- *; auto. - unfold closed_ctx, id. simpl. - rewrite mapi_app forallb_app List.rev_length /= lift_context_snoc0 /snoc Nat.add_0_r. - move/andb_and => /= [Hctx /andb_and [Ha _]]. + rewrite closedn_ctx_cons lift_context_snoc0 /snoc. + move/andb_and => /= [Hctx Hd]. rewrite IHctx // lift_decl_closed //. now apply: closed_decl_upwards. Qed. @@ -97,25 +91,177 @@ Proof. rewrite permute_lift; try easy. Qed. -Lemma lift_iota_red n k pars c args brs : - lift n k (iota_red pars c args brs) = - iota_red pars c (List.map (lift n k) args) (List.map (on_snd (lift n k)) brs). + +Lemma All_local_env_eq P ctx ctx' : + All_local_env P ctx -> + ctx = ctx' -> + All_local_env P ctx'. +Proof. now intros H ->. Qed. + +Hint Rewrite shiftn_rshiftk : sigma. + +Lemma weakening_renaming P Γ Γ' Γ'' : + urenaming P (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (Γ ,,, Γ') + (lift_renaming #|Γ''| #|Γ'|). +Proof. + intros i d hpi hnth. + rewrite /lift_renaming. + destruct (Nat.leb #|Γ'| i) eqn:leb; [apply Nat.leb_le in leb|eapply Nat.leb_nle in leb]. + - rewrite -weaken_nth_error_ge //. + exists d; split; auto. + split; auto. + split. + * apply rename_ext => k. rewrite /rshiftk /lift_renaming. + repeat nat_compare_specs. + * destruct (decl_body d) => /= //. + f_equal. apply rename_ext => k. + rewrite /rshiftk; now nat_compare_specs. + - rewrite weaken_nth_error_lt; try lia. + rewrite hnth /=. eexists. split; [eauto|]. + simpl. rewrite !lift_rename !rename_compose /lift_renaming /rshiftk /=. + repeat split. + * apply rename_ext => k. now repeat nat_compare_specs. + * destruct (decl_body d) => /= //. f_equal. + rewrite lift_rename rename_compose /lift_renaming. + apply rename_ext => k. simpl. now repeat nat_compare_specs. +Qed. + +Variant lookup_decl_spec Γ Δ i : option context_decl -> Type := +| lookup_head d : i < #|Δ| -> + nth_error Δ i = Some d -> lookup_decl_spec Γ Δ i (Some d) +| lookup_tail d : #|Δ| <= i < #|Γ| + #|Δ| -> + nth_error Γ (i - #|Δ|) = Some d -> + lookup_decl_spec Γ Δ i (Some d) +| lookup_above : #|Γ| + #|Δ| <= i -> lookup_decl_spec Γ Δ i None. + +Lemma lookup_declP Γ Δ i : lookup_decl_spec Γ Δ i (nth_error (Γ ,,, Δ) i). +Proof. + destruct (Nat.ltb i #|Δ|) eqn:ltb. + - apply Nat.ltb_lt in ltb. + rewrite nth_error_app_lt //. + destruct nth_error eqn:hnth. + * constructor; auto. + * apply nth_error_None in hnth. lia. + - apply Nat.ltb_nlt in ltb. + rewrite nth_error_app_ge; try lia. + destruct nth_error eqn:hnth. + * constructor 2; auto. + apply nth_error_Some_length in hnth. + split; lia. + * constructor. eapply nth_error_None in hnth. lia. +Qed. + +Hint Rewrite rename_context_length : len. + +Variant shiftn_spec k f i : nat -> Type := +| shiftn_below : i < k -> shiftn_spec k f i i +| shiftn_above : k <= i -> shiftn_spec k f i (k + f (i - k)). + +Lemma shiftnP k f i : shiftn_spec k f i (shiftn k f i). +Proof. + rewrite /shiftn. + destruct (Nat.ltb i k) eqn:ltb. + * apply Nat.ltb_lt in ltb. + now constructor. + * apply Nat.ltb_nlt in ltb. + constructor. lia. +Qed. + +Lemma rename_context_lift_context n k Γ : + rename_context (lift_renaming n k) Γ = lift_context n k Γ. +Proof. + rewrite /rename_context /lift_context. + apply fold_context_k_ext => i t. + now rewrite lift_rename shiftn_lift_renaming. +Qed. + +Lemma weakening_wf_local {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} : + wf_local Σ (Γ ,,, Γ') -> + wf_local Σ (Γ ,,, Γ'') -> + wf_local Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ'). +Proof. + intros wfΓ' wfΓ''. + pose proof (env_prop_wf_local _ _ typing_rename_prop _ wfΣ _ wfΓ') as [_ X]. simpl in X. + eapply All_local_env_app_inv in X as [XΓ XΓ']. + apply wf_local_app => //. + rewrite /lift_context. + apply All_local_env_fold. + eapply (All_local_env_impl_ind XΓ'). + intros Δ t [T|] IH; unfold lift_typing; simpl. + - intros Hf. red. rewrite -/(lift_context #|Γ''| 0 Δ). + rewrite Nat.add_0_r. rewrite !lift_rename. + eapply (Hf (fun x => true)). + split. + + apply wf_local_app; auto. + apply All_local_env_fold in IH. apply IH. + + apply (weakening_renaming _ Γ Δ Γ''). + - intros [s Hs]; exists s. red. + rewrite -/(lift_context #|Γ''| 0 Δ). + rewrite Nat.add_0_r !lift_rename. + apply (Hs (fun _ => true)). + split. + + apply wf_local_app; auto. + apply All_local_env_fold in IH. apply IH. + + apply (weakening_renaming _ Γ Δ Γ''). +Qed. + +Lemma weakening_wf_local_eq {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ'' n} : + wf_local Σ (Γ ,,, Γ') -> + wf_local Σ (Γ ,,, Γ'') -> + n = #|Γ''| -> + wf_local Σ (Γ ,,, Γ'' ,,, lift_context n 0 Γ'). +Proof. + intros ? ? ->; now apply weakening_wf_local. +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 (lift_renaming #|Γ''| #|Γ'|) T. Proof. - unfold iota_red. rewrite !lift_mkApps. f_equal; auto using map_skipn. - rewrite nth_map; simpl; auto. + intros wfext Ht. + eapply (typing_rename); eauto. + rewrite rename_context_lift_context. + split. + - eapply weakening_wf_local; eauto with pcuic. + - now apply weakening_renaming. Qed. -Lemma parsubst_empty k a : subst [] k a = a. +Lemma weakening_typing `{cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} {t T} : + wf_local Σ (Γ ,,, Γ'') -> + Σ ;;; Γ ,,, Γ' |- t : T -> + Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| t : lift #|Γ''| #|Γ'| T. Proof. - induction a in k |- * using term_forall_list_ind; simpl; try congruence; - try solve [f_equal; eauto; solve_all; eauto]. + intros wfext Ht. + rewrite !lift_rename. + eapply (typing_rename); eauto. + split. + - eapply weakening_wf_local; eauto with pcuic. + - now apply weakening_renaming. +Qed. - - elim (Nat.compare_spec k n); destruct (Nat.leb_spec k n); intros; try easy. - + subst. rewrite Nat.sub_diag. simpl. rewrite Nat.sub_0_r. reflexivity. - + assert (n - k > 0) by lia. - assert (exists n', n - k = S n'). - * exists (Nat.pred (n - k)). lia. - * destruct H2. rewrite H2. simpl. now rewrite Nat.sub_0_r. +Lemma weakening `{cf : checker_flags} Σ Γ Γ' (t : term) T : + wf Σ.1 -> wf_local Σ (Γ ,,, Γ') -> + Σ ;;; Γ |- t : T -> + Σ ;;; Γ ,,, Γ' |- lift0 #|Γ'| t : lift0 #|Γ'| T. +Proof. + intros HΣ HΓΓ' * H. + eapply (weakening_typing (Γ' := [])); eauto. +Qed. + +Lemma weaken_wf_local {cf:checker_flags} {Σ Δ} Γ : + wf Σ.1 -> + wf_local Σ Γ -> + wf_local Σ Δ -> wf_local Σ (Γ ,,, Δ). +Proof. + intros wfΣ wfΓ wfΔ. + generalize (weakening_wf_local (Γ := []) (Γ'' := Γ) (Γ' := Δ)) => /=. + rewrite !app_context_nil_l. + move/(_ wfΔ wfΓ). + rewrite closed_ctx_lift //. + now eapply closed_wf_local. Qed. Lemma smash_context_lift Δ k n Γ : @@ -141,41 +287,10 @@ Proof. f_equal. rewrite lift_context_app. simpl. rewrite /app_context; lia_f_equal. - rewrite /lift_context // /fold_context /= /map_decl /=. + rewrite /lift_context // /fold_context_k /= /map_decl /=. now lia_f_equal. Qed. -Lemma lift_unfold_fix n k mfix idx narg fn : - unfold_fix mfix idx = Some (narg, fn) -> - unfold_fix (map (map_def (lift n k) (lift n (#|mfix| + k))) mfix) idx = Some (narg, lift n k fn). -Proof. - unfold unfold_fix. - rewrite nth_error_map. destruct (nth_error mfix idx) eqn:Hdef; try congruence. - intros [= <- <-]. simpl. - repeat f_equal. - rewrite (distr_lift_subst_rec _ _ n 0 k). - rewrite fix_subst_length. f_equal. - unfold fix_subst. rewrite !map_length. - generalize #|mfix| at 2 3. induction n0; auto. simpl. - f_equal. apply IHn0. -Qed. -Hint Resolve lift_unfold_fix : pcuic. - -Lemma lift_unfold_cofix n k mfix idx narg fn : - unfold_cofix mfix idx = Some (narg, fn) -> - unfold_cofix (map (map_def (lift n k) (lift n (#|mfix| + k))) mfix) idx = Some (narg, lift n k fn). -Proof. - unfold unfold_cofix. - rewrite nth_error_map. destruct (nth_error mfix idx) eqn:Hdef; try congruence. - intros [= <- <-]. simpl. repeat f_equal. - rewrite (distr_lift_subst_rec _ _ n 0 k). - rewrite cofix_subst_length. f_equal. - unfold cofix_subst. rewrite !map_length. - generalize #|mfix| at 2 3. induction n0; auto. simpl. - f_equal. apply IHn0. -Qed. -Hint Resolve lift_unfold_cofix : pcuic. - Lemma decompose_app_rec_lift n k t l : let (f, a) := decompose_app_rec t l in decompose_app_rec (lift n k t) (map (lift n k) l) = (lift n k f, map (lift n k) a). @@ -207,169 +322,34 @@ Proof. Qed. Hint Resolve lift_is_constructor : core. -Hint Rewrite lift_subst_instance_constr : lift. +Hint Rewrite subst_instance_lift : lift. Hint Rewrite lift_mkApps : lift. Hint Rewrite distr_lift_subst distr_lift_subst10 : lift. -Hint Rewrite lift_iota_red : lift. Lemma lift_declared_constant `{checker_flags} Σ cst decl n k : wf Σ -> declared_constant Σ cst decl -> decl = map_constant_body (lift n k) decl. Proof. - unfold declared_constant. - intros. - eapply lookup_on_global_env in H0; eauto. - destruct H0 as [Σ' [wfΣ' decl']]. - red in decl'. red in decl'. - destruct decl. simpl in *. destruct cst_body. - - unfold map_constant_body. simpl. - pose proof decl' as declty. - apply typecheck_closed in declty; eauto. - + destruct declty as [declty Hcl]. - rewrite -> andb_and in Hcl. destruct Hcl as [clb clty]. - pose proof (closed_upwards k clb). - pose proof (closed_upwards k clty). - simpl in *. forward H0 by lia. forward H1 by lia. - apply (lift_closed n k) in H0. - apply (lift_closed n k) in H1. rewrite H0 H1. reflexivity. - - - red in decl'. - destruct decl'. - apply subject_closed in t; auto. - eapply closed_upwards in t; simpl. - * apply (lift_closed n k) in t. unfold map_constant_body. simpl. - rewrite t. reflexivity. - * lia. + intros wf declc. + rewrite /map_constant_body; destruct decl; simpl; f_equal; rewrite ?lift_rename. + - eapply declared_constant_closed_type in declc; eauto. + now rewrite rename_closed. + - destruct cst_body0 eqn:cb => /= //. + f_equal. + eapply declared_constant_closed_body in declc; simpl; eauto. + now rewrite lift_rename rename_closed. Qed. Definition lift_mutual_inductive_body n k m := map_mutual_inductive_body (fun k' => lift n (k' + k)) m. -Lemma lift_wf_local `{checker_flags} Σ Γ n k : - wf Σ.1 -> - wf_local Σ Γ -> - lift_context n k Γ = Γ. -Proof. - intros wfΣ. - induction 1; auto; unfold lift_context, snoc; rewrite fold_context_snoc0; auto; unfold snoc; - f_equal; auto; unfold map_decl; simpl. - - destruct t0 as [s Hs]. unfold vass. f_equal. - eapply typed_liftn; eauto. lia. - - red in t0. destruct t0. unfold vdef. f_equal. - + f_equal. eapply typed_liftn; eauto. lia. - + eapply typed_liftn in t0 as [Ht HT]; eauto. lia. -Qed. - -Lemma lift_declared_minductive `{checker_flags} {Σ : global_env} cst decl n k : - wf Σ -> - declared_minductive Σ cst decl -> - lift_mutual_inductive_body n k decl = decl. -Proof. - intros wfΣ Hdecl. - pose proof (on_declared_minductive wfΣ Hdecl). apply onNpars in X. - apply (declared_inductive_closed (Σ:=(empty_ext Σ))) in Hdecl; auto. - move: Hdecl. - rewrite /closed_inductive_decl /lift_mutual_inductive_body. - destruct decl; simpl. - move/andb_and => [clpar clbodies]. f_equal. - - now rewrite [fold_context _ _]closed_ctx_lift. - - eapply forallb_All in clbodies. - eapply Alli_mapi_id. - * eapply (All_Alli clbodies). intros; eauto. - intros. eapply H0. - * simpl; intros. - move: H0. rewrite /closed_inductive_body. - destruct x; simpl. move=> /andb_and[/andb_and [ci ct] cp]. - f_equal. - + rewrite lift_closed; eauto. - eapply closed_upwards; eauto; lia. - + eapply All_map_id. eapply forallb_All in ct. - eapply (All_impl ct). intros x. - destruct x as [[id ty] arg]; unfold on_pi2; intros c; simpl; repeat f_equal. - apply lift_closed. unfold cdecl_type in c; simpl in c. - eapply closed_upwards; eauto; lia. - + simpl in X. rewrite -X in cp. - eapply forallb_All in cp. eapply All_map_id; eauto. - eapply (All_impl cp); intuition auto. - destruct x; unfold on_snd; simpl; f_equal. - apply lift_closed. rewrite context_assumptions_fold. - eapply closed_upwards; eauto; lia. -Qed. - -Lemma lift_declared_inductive `{checker_flags} Σ ind mdecl idecl n k : - wf Σ -> - declared_inductive Σ mdecl ind idecl -> - map_one_inductive_body (context_assumptions mdecl.(ind_params)) - (length (arities_context mdecl.(ind_bodies))) (fun k' => lift n (k' + k)) - (inductive_ind ind) idecl = idecl. -Proof. - unfold declared_inductive. intros wfΣ [Hmdecl Hidecl]. - eapply (lift_declared_minductive _ _ n k) in Hmdecl. 2: auto. - unfold lift_mutual_inductive_body in Hmdecl. - destruct mdecl. simpl in *. - injection Hmdecl. intros Heq. - clear Hmdecl. - pose proof Hidecl as Hidecl'. - rewrite <- Heq in Hidecl'. - rewrite nth_error_mapi in Hidecl'. - clear Heq. - unfold option_map in Hidecl'. rewrite Hidecl in Hidecl'. - congruence. -Qed. - -Lemma subst0_inds_lift ind u mdecl n k t : - (subst0 (inds (inductive_mind ind) u (ind_bodies mdecl)) - (lift n (#|arities_context (ind_bodies mdecl)| + k) t)) = - lift n k (subst0 (inds (inductive_mind ind) u (ind_bodies mdecl)) t). -Proof. - rewrite (distr_lift_subst_rec _ _ n 0 k). simpl. - unfold arities_context. rewrite rev_map_length inds_length. - f_equal. generalize (ind_bodies mdecl). - clear. intros. - induction l; unfold inds; simpl; auto. f_equal. auto. -Qed. - -Lemma lift_declared_constructor `{checker_flags} Σ c u mdecl idecl cdecl n k : - wf Σ -> - declared_constructor Σ mdecl idecl c cdecl -> - lift n k (type_of_constructor mdecl cdecl c u) = (type_of_constructor mdecl cdecl c u). -Proof. - unfold declared_constructor. destruct c as [i ci]. intros wfΣ [Hidecl Hcdecl]. - eapply (lift_declared_inductive _ _ _ _ n k) in Hidecl; eauto. - unfold type_of_constructor. destruct cdecl as [[id t'] arity]. - destruct idecl; simpl in *. - injection Hidecl. - intros. - pose Hcdecl as Hcdecl'. - rewrite <- H1 in Hcdecl'. - rewrite nth_error_map in Hcdecl'. rewrite Hcdecl in Hcdecl'. - simpl in Hcdecl'. injection Hcdecl'. - intros. - rewrite <- H3 at 2. - rewrite <- lift_subst_instance_constr. - now rewrite subst0_inds_lift. -Qed. - -Lemma lift_declared_projection `{checker_flags} Σ c mdecl idecl pdecl n k : - wf Σ -> - declared_projection Σ mdecl idecl c pdecl -> - on_snd (lift n (S (ind_npars mdecl + k))) pdecl = pdecl. -Proof. - intros. - eapply (declared_projection_closed (Σ:=empty_ext Σ)) in H0; auto. - unfold on_snd. simpl. - rewrite lift_closed. - - eapply closed_upwards; eauto; try lia. - - destruct pdecl; reflexivity. -Qed. - Lemma lift_fix_context: forall (mfix : list (def term)) (n k : nat), fix_context (map (map_def (lift n k) (lift n (#|mfix| + k))) mfix) = lift_context n k (fix_context mfix). Proof. intros mfix n k. unfold fix_context. - rewrite map_vass_map_def rev_mapi. + rewrite PCUICLiftSubst.map_vass_map_def rev_mapi. fold (fix_context mfix). rewrite (lift_context_alt n k (fix_context mfix)). unfold lift_decl. now rewrite mapi_length fix_context_length. @@ -377,160 +357,6 @@ Qed. Hint Rewrite <- lift_fix_context : lift. -Lemma All_local_env_lift `{checker_flags} - (P Q : context -> term -> option term -> Type) c n k : - All_local_env Q c -> - (forall Γ t T, - Q Γ t T -> - P (lift_context n k Γ) (lift n (#|Γ| + k) t) - (option_map (lift n (#|Γ| + k)) T) - ) -> - All_local_env P (lift_context n k c). -Proof. - intros Hq Hf. - induction Hq in |- *; try econstructor; eauto; - simpl; rewrite lift_context_snoc; econstructor; eauto. - - simpl. eapply (Hf _ _ None). eauto. - - simpl. eapply (Hf _ _ None). eauto. - - simpl. eapply (Hf _ _ (Some t)). eauto. -Qed. - -Lemma lift_destArity ctx t n k : - destArity (lift_context n k ctx) (lift n (#|ctx| + k) t) = - match destArity ctx t with - | Some (args, s) => Some (lift_context n k args, s) - | None => None - end. -Proof. - revert ctx. - induction t in n, k |- * using term_forall_list_ind; intros ctx; simpl; trivial. - - move: (IHt2 n k (ctx,, vass n0 t1)). - now rewrite lift_context_snoc /= /lift_decl /map_decl /vass /= => ->. - - move: (IHt3 n k (ctx,, vdef n0 t1 t2)). - now rewrite lift_context_snoc /= /lift_decl /map_decl /vass /= => ->. -Qed. - -(* Lemma lift_strip_outer_cast n k t : lift n k (strip_outer_cast t) = strip_outer_cast (lift n k t). *) -(* Proof. *) -(* induction t; simpl; try reflexivity. *) -(* destruct Nat.leb; reflexivity. *) -(* now rewrite IHt1. *) -(* Qed. *) - -Definition on_pair {A B C D} (f : A -> B) (g : C -> D) (x : A * C) := - (f (fst x), g (snd x)). - -Lemma lift_instantiate_params_subst n k params args s t : - instantiate_params_subst (mapi_rec (fun k' decl => lift_decl n (k' + k) decl) params #|s|) - (map (lift n k) args) (map (lift n k) s) (lift n (#|s| + k) t) = - option_map (on_pair (map (lift n k)) (lift n (#|s| + k + #|params|))) (instantiate_params_subst params args s t). -Proof. - induction params in args, t, n, k, s |- *. - - destruct args; simpl; rewrite ?Nat.add_0_r; reflexivity. - - simpl. simpl. (* rewrite <- lift_strip_outer_cast. generalize (strip_outer_cast t). *) - (* clear t; intros t. *) - destruct a as [na [body|] ty]; simpl; try congruence. - + destruct t; simpl; try congruence. - specialize (IHparams n k args (subst0 s body :: s) t3). - rewrite <- Nat.add_succ_r. simpl in IHparams. - rewrite Nat.add_succ_r. - replace (#|s| + k + S #|params|) with (S (#|s| + k + #|params|)) by lia. - rewrite <- IHparams. - rewrite distr_lift_subst. reflexivity. - + destruct t; simpl; try congruence. - destruct args; simpl; try congruence. - specialize (IHparams n k args (t :: s) t2). simpl in IHparams. - replace (#|s| + k + S #|params|) with (S (#|s| + k + #|params|)) by lia. - rewrite <- IHparams. auto. -Qed. - -Lemma instantiate_params_subst_length params args s t ctx t' : - instantiate_params_subst params args s t = Some (ctx, t') -> - #|ctx| = #|s| + #|params|. -Proof. - induction params in args, s, t, ctx, t' |- * ; - destruct args; simpl; auto; try congruence. - - rewrite Nat.add_0_r. congruence. - - destruct decl_body. - + simpl. - destruct t; simpl; try congruence. - intros. erewrite IHparams; eauto. simpl. lia. - + destruct t; simpl; try congruence. - - destruct decl_body. - + simpl. - destruct t; simpl; try congruence. - intros. erewrite IHparams; eauto. simpl. lia. - + destruct t; simpl; try congruence. - intros. erewrite IHparams; eauto. simpl. lia. -Qed. - -Lemma closed_tele_lift n k ctx : - closed_ctx ctx -> - mapi (fun (k' : nat) (decl : context_decl) => lift_decl n (k' + k) decl) (List.rev ctx) = List.rev ctx. -Proof. - rewrite /closedn_ctx /mapi. simpl. generalize 0. - induction ctx using rev_ind. - 1: move=> //. - move=> n0. - rewrite /closedn_ctx !rev_app_distr /id /=. - move/andb_and => [closedx Hctx]. - rewrite lift_decl_closed. - - rewrite (@closed_decl_upwards n0) //; try lia. - - f_equal. now rewrite IHctx. -Qed. - -Lemma lift_instantiate_params n k params args t : - closed_ctx params -> - option_map (lift n k) (instantiate_params params args t) = - instantiate_params params (map (lift n k) args) (lift n k t). -Proof. - unfold instantiate_params. - move/(closed_tele_lift n k params)=> Heq. - rewrite -{2}Heq. - specialize (lift_instantiate_params_subst n k (List.rev params) args [] t). - move=> /= Heq'; rewrite Heq'. - case E: (instantiate_params_subst (List.rev params) args)=> [[l' t']|] /= //. - rewrite distr_lift_subst. - move/instantiate_params_subst_length: E => -> /=. do 3 f_equal. lia. -Qed. -Hint Rewrite lift_instantiate_params : lift. - -Lemma decompose_prod_assum_ctx ctx t : decompose_prod_assum ctx t = - let (ctx', t') := decompose_prod_assum [] t in - (ctx ,,, ctx', t'). -Proof. - induction t in ctx |- *; simpl; auto. - - simpl. rewrite IHt2. - rewrite (IHt2 ([] ,, vass _ _)). - destruct (decompose_prod_assum [] t2). simpl. - unfold snoc. now rewrite app_context_assoc. - - simpl. rewrite IHt3. - rewrite (IHt3 ([] ,, vdef _ _ _)). - destruct (decompose_prod_assum [] t3). simpl. - unfold snoc. now rewrite app_context_assoc. -Qed. - -Lemma lift_decompose_prod_assum_rec ctx t n k : - (let (ctx', t') := decompose_prod_assum ctx t in - (lift_context n k ctx', lift n (length ctx' + k) t')) = - decompose_prod_assum (lift_context n k ctx) (lift n (length ctx + k) t). -Proof. - induction t in n, k, ctx |- *; simpl; - try rewrite -> Nat.sub_diag, Nat.add_0_r; try (eauto; congruence). - - specialize (IHt2 (ctx ,, vass na t1) n k). - destruct decompose_prod_assum. rewrite IHt2. simpl. - rewrite lift_context_snoc. reflexivity. - - specialize (IHt3 (ctx ,, vdef na t1 t2) n k). - destruct decompose_prod_assum. rewrite IHt3. simpl. - rewrite lift_context_snoc. reflexivity. -Qed. - -Lemma lift_decompose_prod_assum t n k : - (let (ctx', t') := decompose_prod_assum [] t in - (lift_context n k ctx', lift n (length ctx' + k) t')) = - decompose_prod_assum [] (lift n k t). -Proof. apply lift_decompose_prod_assum_rec. Qed. - Lemma lift_it_mkProd_or_LetIn n k ctx t : lift n k (it_mkProd_or_LetIn ctx t) = it_mkProd_or_LetIn (lift_context n k ctx) (lift n (length ctx + k) t). @@ -543,19 +369,6 @@ Proof. Qed. Hint Rewrite lift_it_mkProd_or_LetIn : lift. -Lemma to_extended_list_lift n k c : - to_extended_list (lift_context n k c) = to_extended_list c. -Proof. - unfold to_extended_list, to_extended_list_k. generalize 0. - unf_term. generalize (@nil term) at 1 2. - induction c in n, k |- *; simpl; intros. 1: reflexivity. - rewrite -> lift_context_snoc0. unfold snoc. simpl. - destruct a. destruct decl_body. - - unfold lift_decl, map_decl. simpl. - now rewrite -> IHc. - - simpl. apply IHc. -Qed. - Lemma to_extended_list_map_lift: forall (n k : nat) (c : context), to_extended_list c = map (lift n (#|c| + k)) (to_extended_list c). Proof. @@ -568,97 +381,19 @@ Proof. - reflexivity. Qed. -Lemma weakening_red1 `{CF:checker_flags} Σ Γ Γ' Γ'' M N : +Lemma weakening_red1 `{cf:checker_flags} {Σ} Γ Γ' Γ'' M N : wf Σ -> red1 Σ (Γ ,,, Γ') M N -> red1 Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (lift #|Γ''| #|Γ'| M) (lift #|Γ''| #|Γ'| N). Proof. intros wfΣ H. - remember (Γ ,,, Γ') as Γ0. revert Γ Γ' Γ'' HeqΓ0. - induction H using red1_ind_all in |- *; intros Γ0 Γ' Γ'' HeqΓ0; try subst Γ; simpl; - autorewrite with lift; - try solve [ econstructor; eauto with pcuic ]. - - - elim (leb_spec_Set); intros Hn. - + rewrite -> simpl_lift; try lia. rewrite -> Nat.add_succ_r. - econstructor; eauto. - erewrite (weaken_nth_error_ge Hn) in H. eauto. - - + rewrite <- lift_simpl by easy. - econstructor. - rewrite -> (weaken_nth_error_lt Hn). - now unfold lift_decl; rewrite -> option_map_decl_body_map_decl, H. - - - econstructor; eauto with pcuic. - rewrite H0. f_equal. - eapply (lookup_on_global_env _ _ _ _ wfΣ) in H. - destruct H as [Σ' [wfΣ' decl']]. - red in decl'. red in decl'. - rewrite -> H0 in decl'. - apply typecheck_closed in decl'; eauto. - destruct decl'. - rewrite -> andb_and in i. destruct i as [Hclosed _]. - simpl in Hclosed. - pose proof (closed_upwards #|Γ'| Hclosed). - forward H by lia. - apply (lift_closed #|Γ''| #|Γ'|) in H. auto. - - - simpl. constructor. - now rewrite -> nth_error_map, H. - - - constructor. - specialize (IHred1 Γ0 (Γ' ,, vass na N) Γ'' eq_refl). - rewrite -> lift_context_snoc, Nat.add_0_r in IHred1. apply IHred1. - - - constructor. - specialize (IHred1 Γ0 (Γ' ,, vdef na b t) Γ'' eq_refl). - rewrite -> lift_context_snoc, Nat.add_0_r in IHred1. apply IHred1. - - - constructor. - induction X; constructor; auto. - intuition; eauto. - - - constructor. - specialize (IHred1 Γ0 (Γ' ,, vass na M1) Γ'' eq_refl). - rewrite -> lift_context_snoc, Nat.add_0_r in IHred1. apply IHred1. - - - constructor. - induction X; constructor; auto. - intuition; eauto. - - - constructor. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - induction X; simpl; constructor; simpl; intuition eauto. - congruence. - - - apply fix_red_body. rewrite !lift_fix_context. - rewrite <- (OnOne2_length X). - eapply OnOne2_map. unfold on_Trel; solve_all. 2: congruence. - specialize (b0 Γ0 (Γ' ,,, fix_context mfix0)). - rewrite app_context_assoc in b0. specialize (b0 Γ'' eq_refl). - rewrite -> app_context_length, fix_context_length in *. - rewrite -> lift_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - auto. - - - constructor. - rewrite -> (OnOne2_length X). generalize (#|mfix1|). - induction X; simpl; constructor; intuition eauto. - + simpl; auto. - + simpl; congruence. - - - apply cofix_red_body. rewrite !lift_fix_context. - rewrite <- (OnOne2_length X). - eapply OnOne2_map. unfold on_Trel; solve_all. 2: congruence. - specialize (b0 Γ0 (Γ' ,,, fix_context mfix0)). - rewrite app_context_assoc in b0. specialize (b0 Γ'' eq_refl). - rewrite -> app_context_length, fix_context_length in *. - rewrite -> lift_context_app in *. - rewrite -> app_context_assoc, Nat.add_0_r in *. - auto. + rewrite !lift_rename. + eapply red1_rename; eauto. + - eapply weakening_renaming. + - eapply on_free_vars_true. Qed. -Lemma weakening_red `{CF:checker_flags} Σ Γ Γ' Γ'' M N : +Lemma weakening_red `{cf:checker_flags} Σ Γ Γ' Γ'' M N : wf Σ -> red Σ (Γ ,,, Γ') M N -> red Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (lift #|Γ''| #|Γ'| M) (lift #|Γ''| #|Γ'| N). @@ -669,86 +404,11 @@ Proof. - etransitivity; eassumption. Qed. -Fixpoint lift_stack n k π := - match π with - | ε => ε - | App u π => - let k' := #|stack_context π| + k in - App (lift n k' u) (lift_stack n k π) - | Fix mfix idx args π => - let k' := #|stack_context π| + k in - let k'' := #|mfix| + k' in - let mfix' := List.map (map_def (lift n k') (lift n k'')) mfix in - Fix mfix' idx (map (lift n k') args) (lift_stack n k π) - | Fix_mfix_ty na bo ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (lift n k') (lift n k'')) mfix1 in - let mfix2' := List.map (map_def (lift n k') (lift n k'')) mfix2 in - Fix_mfix_ty na (lift n k'' bo) ra mfix1' mfix2' idx (lift_stack n k π) - | Fix_mfix_bd na ty ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (lift n k') (lift n k'')) mfix1 in - let mfix2' := List.map (map_def (lift n k') (lift n k'')) mfix2 in - Fix_mfix_bd na (lift n k' ty) ra mfix1' mfix2' idx (lift_stack n k π) - | CoFix mfix idx args π => - let k' := #|stack_context π| + k in - let k'' := #|mfix| + k' in - let mfix' := List.map (map_def (lift n k') (lift n k'')) mfix in - CoFix mfix' idx (map (lift n k') args) (lift_stack n k π) - | CoFix_mfix_ty na bo ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (lift n k') (lift n k'')) mfix1 in - let mfix2' := List.map (map_def (lift n k') (lift n k'')) mfix2 in - CoFix_mfix_ty na (lift n k'' bo) ra mfix1' mfix2' idx (lift_stack n k π) - | CoFix_mfix_bd na ty ra mfix1 mfix2 idx π => - let k' := #|stack_context π| + k in - let k'' := #|mfix1| + S #|mfix2| + k' in - let mfix1' := List.map (map_def (lift n k') (lift n k'')) mfix1 in - let mfix2' := List.map (map_def (lift n k') (lift n k'')) mfix2 in - CoFix_mfix_bd na (lift n k' ty) ra mfix1' mfix2' idx (lift_stack n k π) - | Case_p indn c brs π => - let k' := #|stack_context π| + k in - let brs' := List.map (on_snd (lift n k')) brs in - Case_p indn (lift n k' c) brs' (lift_stack n k π) - | Case indn pred brs π => - let k' := #|stack_context π| + k in - let brs' := List.map (on_snd (lift n k')) brs in - Case indn (lift n k' pred) brs' (lift_stack n k π) - | Case_brs indn pred c m brs1 brs2 π => - let k' := #|stack_context π| + k in - let brs1' := List.map (on_snd (lift n k')) brs1 in - let brs2' := List.map (on_snd (lift n k')) brs2 in - Case_brs indn (lift n k' pred) (lift n k' c) m brs1' brs2' (lift_stack n k π) - | Proj p π => - Proj p (lift_stack n k π) - | Prod_l na B π => - let k' := #|stack_context π| + k in - Prod_l na (lift n (S k') B) (lift_stack n k π) - | Prod_r na A π => - let k' := #|stack_context π| + k in - Prod_r na (lift n k' A) (lift_stack n k π) - | Lambda_ty na b π => - let k' := #|stack_context π| + k in - Lambda_ty na (lift n (S k') b) (lift_stack n k π) - | Lambda_tm na A π => - let k' := #|stack_context π| + k in - Lambda_tm na (lift n k' A) (lift_stack n k π) - | LetIn_bd na B u π => - let k' := #|stack_context π| + k in - LetIn_bd na (lift n k' B) (lift n (S k') u) (lift_stack n k π) - | LetIn_ty na b u π => - let k' := #|stack_context π| + k in - LetIn_ty na (lift n k' b) (lift n (S k') u) (lift_stack n k π) - | LetIn_in na b B π => - let k' := #|stack_context π| + k in - LetIn_in na (lift n k' b) (lift n k' B) (lift_stack n k π) - | coApp u π => - let k' := #|stack_context π| + k in - coApp (lift n k' u) (lift_stack n k π) - end. +Lemma weakening_red_0 {cf} {Σ} {wfΣ : wf Σ} Γ Γ' M N n : + n = #|Γ'| -> + red Σ Γ M N -> + red Σ (Γ ,,, Γ') (lift0 n M) (lift0 n N). +Proof. now move=> ->; apply (weakening_red Σ Γ [] Γ'). Qed. (* TODO MOVE *) Lemma fix_context_alt_length : @@ -761,40 +421,16 @@ Proof. rewrite mapi_length. reflexivity. Qed. -Lemma lift_zipc : - forall n k t π, - let k' := #|stack_context π| + k in - lift n k (zipc t π) = - zipc (lift n k' t) (lift_stack n k π). +Lemma map_decl_name_fold_context_k f ctx : + map decl_name (fold_context_k f ctx) = map decl_name ctx. +Proof. + now rewrite fold_context_k_alt map_mapi /= mapi_cst_map. +Qed. + +Lemma forget_types_fold_context_k f ctx : + forget_types (fold_context_k f ctx) = forget_types ctx. Proof. - intros n k t π k'. - induction π in n, k, t, k' |- *. - all: try reflexivity. - all: try solve [ - simpl ; rewrite IHπ ; cbn ; reflexivity - ]. - - simpl. rewrite IHπ. cbn. f_equal. - rewrite lift_mkApps. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. f_equal. - unfold map_def at 1. cbn. f_equal. - rewrite fix_context_alt_length. - rewrite !app_length. cbn. rewrite !map_length. - f_equal. f_equal. lia. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite lift_mkApps. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. reflexivity. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. rewrite !app_length. cbn. f_equal. - unfold map_def at 1. cbn. f_equal. - rewrite fix_context_alt_length. - rewrite !app_length. cbn. rewrite !map_length. - f_equal. f_equal. lia. - - simpl. rewrite IHπ. cbn. f_equal. f_equal. - rewrite map_app. cbn. reflexivity. + now rewrite /forget_types map_decl_name_fold_context_k. Qed. Lemma weakening_cumul `{CF:checker_flags} Σ Γ Γ' Γ'' M N : @@ -810,320 +446,11 @@ Proof. econstructor 3; eauto. Qed. -Lemma destArity_it_mkProd_or_LetIn ctx ctx' t : - destArity ctx (it_mkProd_or_LetIn ctx' t) = - destArity (ctx ,,, ctx') t. -Proof. - induction ctx' in ctx, t |- *; simpl; auto. - rewrite IHctx'. destruct a as [na [b|] ty]; reflexivity. -Qed. - -Lemma lift_build_case_predicate_type ind mdecl idecl u params ps n k : - closed_ctx (subst_instance_context u (ind_params mdecl)) -> - build_case_predicate_type ind mdecl - (map_one_inductive_body (context_assumptions mdecl.(ind_params)) - (length (arities_context (ind_bodies mdecl))) (fun k' => lift n (k' + k)) - (inductive_ind ind) idecl) - (map (lift n k) params) u ps - = option_map (lift n k) (build_case_predicate_type ind mdecl idecl params u ps). -Proof. - intros closedpars. unfold build_case_predicate_type. - rewrite -> ind_type_map. simpl. - epose proof (lift_instantiate_params n k _ params (subst_instance_constr u (ind_type idecl))) as H. - rewrite <- lift_subst_instance_constr. - erewrite <- H; trivial. clear H. - case_eq (instantiate_params (subst_instance_context u (ind_params mdecl)) params (subst_instance_constr u (ind_type idecl))) ; cbnr. - intros ity eq. - pose proof (lift_destArity [] ity n k) as H; cbn in H. rewrite H; clear H. - destruct destArity as [[ctx s] | ]; [|reflexivity]. simpl. f_equal. - rewrite lift_it_mkProd_or_LetIn; cbn. unf_term. f_equal. f_equal. - - destruct idecl; reflexivity. - - rewrite lift_mkApps; cbn; f_equal. rewrite map_app. f_equal. - + rewrite !map_map lift_context_length; apply map_ext. clear. - intro. now rewrite -> permute_lift by lia. - + now rewrite -> to_extended_list_lift, <- to_extended_list_map_lift. -Qed. - -Lemma lift_build_branches_type ind mdecl idecl u p params n k : - closed_ctx (subst_instance_context u (ind_params mdecl)) -> - build_branches_type ind mdecl - (map_one_inductive_body (context_assumptions mdecl.(ind_params)) - #|arities_context (ind_bodies mdecl)| (fun k' => lift n (k' + k)) - (inductive_ind ind) idecl) - (map (lift n k) params) u (lift n k p) - = map (option_map (on_snd (lift n k))) - (build_branches_type ind mdecl idecl params u p). -Proof. - intros closedpars. unfold build_branches_type. - rewrite -> ind_ctors_map. - rewrite -> mapi_map, map_mapi. eapply mapi_ext. intros i x. - destruct x as [[id t] arity]. simpl. - rewrite <- lift_subst_instance_constr. - rewrite subst0_inds_lift. - rewrite <- lift_instantiate_params ; trivial. - match goal with - | |- context [ option_map _ (instantiate_params ?x ?y ?z) ] => - destruct (instantiate_params x y z) eqn:Heqip; cbnr - end. - epose proof (lift_decompose_prod_assum t0 n k). - destruct (decompose_prod_assum [] t0). - rewrite <- H. - destruct (decompose_app t1) as [fn arg] eqn:?. - rewrite (decompose_app_lift _ _ _ fn arg); auto. simpl. - destruct (chop _ arg) eqn:Heqchop. - eapply chop_map in Heqchop. - rewrite -> Heqchop. clear Heqchop. - unfold on_snd. simpl. f_equal. - rewrite -> lift_it_mkProd_or_LetIn, !lift_mkApps, map_app; simpl. - rewrite -> !lift_mkApps, !map_app, lift_context_length. - rewrite -> permute_lift by lia. arith_congr. - now rewrite -> to_extended_list_lift, <- to_extended_list_map_lift. -Qed. - Lemma destInd_lift n k t : destInd (lift n k t) = destInd t. Proof. destruct t; simpl; try congruence. Qed. -Lemma weakening_check_one_fix (Γ' Γ'' : context) mfix : - map - (fun x : def term => - check_one_fix (map_def (lift #|Γ''| #|Γ'|) (lift #|Γ''| (#|mfix| + #|Γ'|)) x)) mfix = - map check_one_fix mfix. -Proof. - apply map_ext. move=> [na ty def rarg] /=. - rewrite decompose_prod_assum_ctx. - destruct (decompose_prod_assum _ ty) eqn:decomp. - rewrite decompose_prod_assum_ctx in decomp. - rewrite -lift_decompose_prod_assum. - destruct (decompose_prod_assum [] ty) eqn:decty. - noconf decomp. rewrite !app_context_nil_l (smash_context_lift []). - destruct (nth_error_spec (List.rev (smash_context [] c0)) rarg); - autorewrite with len in *; simpl in *. - - rewrite nth_error_rev_inv; autorewrite with len; simpl; auto. - rewrite nth_error_lift_context_eq. - simpl. - rewrite nth_error_rev_inv in e; autorewrite with len; auto. - autorewrite with len in e. simpl in e. rewrite e. simpl. - destruct (decompose_app (decl_type x)) eqn:Happ. - erewrite decompose_app_lift; eauto. - rewrite destInd_lift. reflexivity. - - erewrite (proj2 (nth_error_None _ _)); auto. - autorewrite with len. simpl; lia. -Qed. - -Lemma weakening_check_one_cofix (Γ' Γ'' : context) mfix : - map - (fun x : def term => - check_one_cofix (map_def (lift #|Γ''| #|Γ'|) (lift #|Γ''| (#|mfix| + #|Γ'|)) x)) mfix = - map check_one_cofix mfix. -Proof. - apply map_ext. move=> [na ty def rarg] /=. - rewrite decompose_prod_assum_ctx. - destruct (decompose_prod_assum _ ty) eqn:decomp. - rewrite decompose_prod_assum_ctx in decomp. - rewrite -lift_decompose_prod_assum. - destruct (decompose_prod_assum [] ty) eqn:decty. - noconf decomp. - destruct (decompose_app t) eqn:Happ. - erewrite decompose_app_lift; eauto. - rewrite destInd_lift. reflexivity. -Qed. - -Lemma weakening_typing_prop {cf:checker_flags} : env_prop (fun Σ Γ0 t T => - forall Γ Γ' Γ'' : context, - wf_local Σ (Γ ,,, Γ'') -> - Γ0 = Γ ,,, Γ' -> - Σ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| t : lift #|Γ''| #|Γ'| T) - (fun Σ Γ0 _ => - forall Γ Γ' Γ'' : context, - Γ0 = Γ ,,, Γ' -> - wf_local Σ (Γ ,,, Γ'') -> - wf_local Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ')). -Proof. - apply typing_ind_env; - intros Σ wfΣ Γ0; !!intros; subst Γ0; simpl in *; try solve [econstructor; eauto]; - try specialize (forall_Γ _ _ _ eq_refl wf). - - - induction Γ'; simpl; auto. - depelim X; rewrite lift_context_snoc; simpl; constructor. - + eapply IHΓ'; eauto. - + red. exists (tu.π1). simpl. - rewrite Nat.add_0_r. apply t0; auto. - + eapply IHΓ'; eauto. - + red. exists (tu.π1). simpl. - rewrite Nat.add_0_r. apply t1; auto. - + simpl. rewrite Nat.add_0_r. apply t0; auto. - - - elim (leb_spec_Set); intros Hn. - + rewrite -> simpl_lift; try lia. rewrite -> Nat.add_succ_r. - constructor. 1: auto. - now rewrite <- (weaken_nth_error_ge Hn). - + assert (forall t, lift0 (S n) (lift #|Γ''| (#|Γ'| - S n) t) = lift #|Γ''| #|Γ'| (lift0 (S n) t)). - * intros. - assert (H:#|Γ'| = S n + (#|Γ'| - S n)) by easy. - rewrite -> H at 2. - rewrite permute_lift; easy. - * rewrite <- H. - rewrite -> map_decl_type. constructor; auto. - now rewrite -> (weaken_nth_error_lt Hn), heq_nth_error. - - - econstructor; auto. - specialize (IHb Γ (Γ' ,, vass n t) Γ'' wf eq_refl). - rewrite -> lift_context_snoc, plus_0_r in IHb. - eapply IHb. - - - econstructor; auto. - simpl. - specialize (IHb Γ (Γ' ,, vass n t) Γ'' wf eq_refl). - rewrite -> lift_context_snoc, plus_0_r in IHb. - eapply IHb. - - - econstructor; auto. - specialize (IHb Γ Γ' Γ'' wf eq_refl). simpl. - specialize (IHb' Γ (Γ' ,, vdef n b b_ty) Γ'' wf eq_refl). - rewrite -> lift_context_snoc, plus_0_r in IHb'. - apply IHb'. - - - eapply refine_type. 1: econstructor; auto. - now rewrite -> distr_lift_subst10. - - - autorewrite with lift. - rewrite -> map_cst_type. constructor; auto. - erewrite <- lift_declared_constant; eauto. - - - autorewrite with lift. - erewrite <- (ind_type_map (fun k' => lift #|Γ''| (k' + #|Γ'|))). - pose proof isdecl as isdecl'. - destruct isdecl. intuition auto. - eapply lift_declared_inductive in isdecl'. 2: auto. - rewrite -> isdecl'. - econstructor; try red; intuition eauto. - - - rewrite (lift_declared_constructor _ (ind, i) u mdecl idecl cdecl _ _ wfΣ isdecl). - econstructor; eauto. - - - rewrite -> lift_mkApps, map_app, map_skipn. - specialize (IHc _ _ _ wf eq_refl). - specialize (IHp _ _ _ wf eq_refl). - assert (Hclos: closed_ctx (subst_instance_context u (ind_params mdecl))). { - destruct isdecl as [Hmdecl Hidecl]. - eapply on_declared_minductive in Hmdecl; eauto. - eapply onParams in Hmdecl. - rewrite closedn_subst_instance_context. - eapply closed_wf_local in Hmdecl; eauto. } - simpl. econstructor. - 8:{ cbn. rewrite -> firstn_map. - erewrite lift_build_branches_type; tea. - rewrite map_option_out_map_option_map. - subst params. erewrite heq_map_option_out. reflexivity. } - all: eauto. - -- erewrite -> lift_declared_inductive; eauto. - -- simpl. erewrite firstn_map, lift_build_case_predicate_type; tea. - subst params. erewrite heq_build_case_predicate_type; reflexivity. - -- destruct idecl; simpl in *; auto. - -- now rewrite -> !lift_mkApps in IHc. - -- solve_all. - destruct b0 as [s [Hs IH]]; eauto. - - - simpl. - erewrite (distr_lift_subst_rec _ _ _ 0 #|Γ'|). - simpl. rewrite -> map_rev. - subst ty. - rewrite -> List.rev_length, lift_subst_instance_constr. - replace (lift #|Γ''| (S (#|args| + #|Γ'|)) (snd pdecl)) - with (snd (on_snd (lift #|Γ''| (S (#|args| + #|Γ'|))) pdecl)) by now destruct pdecl. - econstructor. - + red. split. - * apply (proj1 isdecl). - * split. - -- rewrite -> (proj1 (proj2 isdecl)). f_equal. - rewrite -> heq_length. - symmetry. eapply lift_declared_projection; eauto. - -- apply (proj2 (proj2 isdecl)). - + specialize (IHc _ _ _ wf eq_refl). - rewrite -> lift_mkApps in *. eapply IHc. - + now rewrite -> map_length. - - - rewrite -> (map_dtype _ (lift #|Γ''| (#|mfix| + #|Γ'|))). - eapply type_Fix; auto. - * eapply fix_guard_lift ; eauto. - * rewrite -> nth_error_map, heq_nth_error. reflexivity. - * eapply All_map. - eapply (All_impl X0); simpl. - intros x [s [Hs Hs']]; exists s. - now specialize (Hs' _ _ _ wf eq_refl). - * eapply All_map. - eapply (All_impl X1); simpl. - intros x [Hb IH]. - rewrite lift_fix_context. - specialize (IH Γ (Γ' ,,, (fix_context mfix)) Γ'' wf). - rewrite app_context_assoc in IH. specialize (IH eq_refl). - rewrite lift_context_app Nat.add_0_r app_context_assoc in IH. - rewrite app_context_length fix_context_length in IH. - rewrite lift_context_length fix_context_length. - rewrite permute_lift; try lia. now rewrite (Nat.add_comm #|Γ'|). - * red; rewrite <-H1. unfold wf_fixpoint. - rewrite map_map_compose. - now rewrite weakening_check_one_fix. - - - rewrite -> (map_dtype _ (lift #|Γ''| (#|mfix| + #|Γ'|))). - eapply type_CoFix; auto. - * eapply cofix_guard_lift ; eauto. - * rewrite -> nth_error_map, heq_nth_error. reflexivity. - * eapply All_map. - eapply (All_impl X0); simpl. - intros x [s [Hs Hs']]; exists s. - now specialize (Hs' _ _ _ wf eq_refl). - * eapply All_map. - eapply (All_impl X1); simpl. - intros x [Hb IH]. - rewrite lift_fix_context. - specialize (IH Γ (Γ' ,,, (fix_context mfix)) Γ'' wf). - rewrite app_context_assoc in IH. specialize (IH eq_refl). - rewrite lift_context_app Nat.add_0_r app_context_assoc in IH. - rewrite app_context_length fix_context_length in IH. - rewrite lift_context_length fix_context_length. - rewrite permute_lift; try lia. now rewrite (Nat.add_comm #|Γ'|). - * red; rewrite <-H1. unfold wf_cofixpoint. - rewrite map_map_compose. - now rewrite weakening_check_one_cofix. - - - econstructor; eauto; now eapply weakening_cumul. -Qed. - -Lemma weakening_typing `{cf : checker_flags} Σ Γ Γ' Γ'' (t : term) : - wf Σ.1 -> - wf_local Σ (Γ ,,, Γ'') -> - forall T, Σ ;;; Γ ,,, Γ' |- t : T -> - Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- - lift #|Γ''| #|Γ'| t : lift #|Γ''| #|Γ'| T. -Proof. - intros HΣ HΓ'' T H. - exact ((weakening_typing_prop Σ HΣ _ t T H).2 _ _ _ HΓ'' eq_refl). -Qed. - -Lemma weakening_wf_local `{cf : checker_flags} Σ Γ Γ' Γ'' : - wf Σ.1 -> - wf_local Σ (Γ ,,, Γ') -> - wf_local Σ (Γ ,,, Γ'') -> - wf_local Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ'). -Proof. - intros HΣ HΓΓ' HΓ''. - exact (env_prop_wf_local _ _ weakening_typing_prop - Σ HΣ _ HΓΓ' _ _ _ eq_refl HΓ''). -Qed. - -Lemma weakening `{cf : checker_flags} Σ Γ Γ' (t : term) T : - wf Σ.1 -> wf_local Σ (Γ ,,, Γ') -> - Σ ;;; Γ |- t : T -> - Σ ;;; Γ ,,, Γ' |- lift0 #|Γ'| t : lift0 #|Γ'| T. -Proof. - intros HΣ HΓΓ' * H. - pose (weakening_typing Σ Γ [] Γ' t). - forward t0; eauto. -Qed. - (** Variant with more freedom on the length to apply it in backward-chainings. *) Lemma weakening_length {cf:checker_flags} Σ Γ Γ' t T n : wf Σ.1 -> @@ -1148,50 +475,49 @@ Proof. econstructor 3 ; eauto. Qed. -Lemma weaken_wf_local {cf:checker_flags} {Σ Γ } Δ : - wf Σ.1 -> - wf_local Σ Δ -> - wf_local Σ Γ -> wf_local Σ (Δ ,,, Γ). -Proof. - intros wfΣ wfΔ wfΓ. - move: (weakening_wf_local _ [] Γ Δ wfΣ). - rewrite !app_context_nil_l. - move/(_ wfΓ wfΔ). - rewrite closed_ctx_lift //. - now eapply closed_wf_local. -Qed. - Lemma weaken_ctx {cf:checker_flags} {Σ Γ t T} Δ : - wf Σ.1 -> wf_local Σ Δ -> + wf Σ.1 -> + wf_local Σ Δ -> Σ ;;; Γ |- t : T -> Σ ;;; Δ ,,, Γ |- t : T. Proof. intros wfΣ wfΔ ty. - epose proof (weakening_typing Σ [] Γ Δ t wfΣ). + epose proof (weakening_typing (Γ := [])). rewrite !app_context_nil_l in X. forward X by eauto using typing_wf_local. - pose proof (typing_wf_local ty). - pose proof (closed_wf_local wfΣ (typing_wf_local ty)). - specialize (X _ ty). - eapply PCUICClosed.typecheck_closed in ty as [_ closed]; auto. - move/andb_and: closed => [ct cT]. + specialize (X ty). + eapply PCUICClosed.typecheck_closed in ty as [_ [clΓ [clt clT]%andb_and]]; auto. rewrite !lift_closed // in X. now rewrite closed_ctx_lift in X. Qed. -Lemma weakening_gen : forall (cf : checker_flags) (Σ : global_env × universes_decl) +Lemma weakening_gen : forall (cf : checker_flags) (Σ : global_env_ext) (Γ Γ' : context) (t T : term) n, n = #|Γ'| -> - wf Σ.1 -> + wf Σ -> wf_local Σ (Γ ,,, Γ') -> Σ;;; Γ |- t : T -> Σ;;; Γ ,,, Γ' |- (lift0 n) t : (lift0 n) T. Proof. intros ; subst n; now apply weakening. Qed. +(** 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 Δ} : + Σ ;;; Γ |- t : T -> + wf_local Σ (Γ ,,, Δ) -> + n = #|Δ| -> + Σ ;;; Γ ,,, Δ |- t.[↑^n] : T.[↑^n]. +Proof. + intros ht hΔ ->. + eapply meta_conv_all. 3-4:now rewrite -rename_inst -lift0_rename. + 2:reflexivity. + eapply weakening_gen => //. +Qed. + Corollary All_mfix_wf {cf:checker_flags} Σ Γ mfix : - wf Σ.1 -> wf_local Σ Γ -> - All (fun d : def term => isType Σ Γ (dtype d)) mfix -> - wf_local Σ (Γ ,,, fix_context mfix). + wf Σ.1 -> wf_local Σ Γ -> + All (fun d : def term => isType Σ Γ (dtype d)) mfix -> + wf_local Σ (Γ ,,, fix_context mfix). Proof. move=> wfΣ wf a; move: wf. change (fix_context mfix) with (fix_context_gen #|@nil context_decl| mfix). @@ -1230,5 +556,6 @@ Proof. { rewrite firstn_length_le; auto with arith. } destruct wfty as [u Hu]. exists u. rewrite {3}H. - unshelve eapply (weakening_typing Σ (skipn n Γ) [] (firstn n Γ) ty _ _ (tSort u)); eauto with wf. + eapply (weakening_typing (Γ := skipn n Γ) (Γ' := []) (Γ'' := firstn n Γ) (T := tSort u)); + eauto with wf. Qed. diff --git a/pcuic/theories/PCUICWeakeningEnv.v b/pcuic/theories/PCUICWeakeningEnv.v index f10496b07..c5c4735f4 100644 --- a/pcuic/theories/PCUICWeakeningEnv.v +++ b/pcuic/theories/PCUICWeakeningEnv.v @@ -1,10 +1,14 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICEquality PCUICTyping. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils + PCUICEquality PCUICContextSubst PCUICUnivSubst PCUICCases + PCUICTyping PCUICContextRelation. +From Equations Require Import Equations. Require Import ssreflect. Set Default Goal Selector "!". +Implicit Types (cf : checker_flags). Lemma global_ext_constraints_app Σ Σ' φ : ConstraintSet.Subset (global_ext_constraints (Σ, φ)) @@ -117,18 +121,15 @@ Lemma eq_decl_subset {cf:checker_flags} le Σ φ φ' d d' : ConstraintSet.Subset φ φ' -> eq_decl le Σ φ d d' -> eq_decl le Σ φ' d d'. Proof. - intros Hφ [[Hann H1] H2]. split; [|eapply compare_term_subset; eauto]. - destruct d as [na [bd|] ty], d' as [na' [bd'|] ty']; cbn in *; split; trivial. - eapply eq_term_subset; eauto. + intros Hφ []; constructor; destruct le; + eauto using leq_term_subset, eq_term_subset. Qed. Lemma eq_context_subset {cf:checker_flags} le Σ φ φ' Γ Γ' : ConstraintSet.Subset φ φ' -> eq_context le Σ φ Γ Γ' -> eq_context le Σ φ' Γ Γ'. Proof. - intros Hφ. induction 1; constructor. - - eapply eq_decl_subset; eassumption. - - assumption. + intros Hφ. induction 1; constructor; auto; eapply eq_decl_subset; eassumption. Qed. Ltac my_rename_hyp h th := @@ -170,6 +171,58 @@ Proof. Qed. Hint Resolve extends_lookup : extends. +Lemma weakening_env_declared_constant `{CF:checker_flags}: + forall (Σ : global_env) cst (decl : constant_body), + declared_constant Σ cst decl -> + forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> declared_constant Σ' cst decl. +Proof. + intros Σ cst decl H0 Σ' X2 H2. + eapply extends_lookup; eauto. +Qed. +Hint Resolve weakening_env_declared_constant : extends. + +Lemma weakening_env_declared_minductive `{CF:checker_flags}: + forall (Σ : global_env) ind decl, + declared_minductive Σ ind decl -> + forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> declared_minductive Σ' ind decl. +Proof. + intros Σ cst decl H0 Σ' X2 H2. + eapply extends_lookup; eauto. +Qed. +Hint Resolve weakening_env_declared_minductive : extends. + +Lemma weakening_env_declared_inductive: + forall (H : checker_flags) (Σ : global_env) ind mdecl decl, + declared_inductive Σ mdecl ind decl -> + forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> declared_inductive Σ' mdecl ind decl. +Proof. + intros H Σ cst decl H0 [Hmdecl Hidecl] Σ' X2 H2. split; eauto with extends. +Qed. +Hint Resolve weakening_env_declared_inductive : extends. + +Lemma weakening_env_declared_constructor : + forall (H : checker_flags) (Σ : global_env) ind mdecl idecl decl, + declared_constructor Σ idecl ind mdecl decl -> + forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> + declared_constructor Σ' idecl ind mdecl decl. +Proof. + intros H Σ cst mdecl idecl cdecl [Hidecl Hcdecl] Σ' X2 H2. + split; eauto with extends. +Qed. +Hint Resolve weakening_env_declared_constructor : extends. + +Lemma weakening_env_declared_projection : + forall (H : checker_flags) (Σ : global_env) ind mdecl idecl decl, + declared_projection Σ idecl ind mdecl decl -> + forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> + declared_projection Σ' idecl ind mdecl decl. +Proof. + intros H Σ cst mdecl idecl cdecl [Hidecl Hcdecl] Σ' X2 H2. + split; eauto with extends. +Qed. +Hint Resolve weakening_env_declared_projection : extends. + + Lemma extends_wf_local `{checker_flags} Σ Γ (wfΓ : wf_local Σ Γ) : All_local_env_over typing (fun Σ0 Γ0 wfΓ (t T : term) ty => @@ -187,19 +240,6 @@ Proof. Qed. Hint Resolve extends_wf_local : extends. -Lemma weakening_env_red1 `{CF:checker_flags} Σ Σ' Γ M N : - wf Σ' -> - extends Σ Σ' -> - red1 Σ Γ M N -> - red1 Σ' Γ M N. -Proof. - induction 3 using red1_ind_all; - try solve [econstructor; eauto; - eapply (OnOne2_impl X1); simpl; intuition eauto]. - - eapply extends_lookup in X0; eauto. - econstructor; eauto. -Qed. Lemma global_variance_sigma_mon {cf:checker_flags} {Σ Σ' gr napp v} : wf Σ' -> extends Σ Σ' -> @@ -255,10 +295,17 @@ Proof. eapply R_global_instance_weaken_env. 6:eauto. all:eauto. - inversion 1; subst; constructor. eapply R_global_instance_weaken_env. 6:eauto. all:eauto. - - inversion 1; subst; constructor; eauto. - eapply All2_impl'; tea. - eapply All_impl; eauto. - cbn. intros x ? y [? ?]. split; eauto. + - inversion 1; subst; destruct X as [? [? ?]]; constructor; eauto. + * destruct X2 as [? [? ?]]. + constructor; intuition auto; solve_all. + + eauto using R_universe_instance_impl'. + + eapply All2_fold_impl_onctx; tea; simpl; unfold ondecl; intuition eauto. + depelim X0; constructor; eauto. + * eapply All2_impl'; tea. + eapply All_impl; eauto. + cbn. intros x [? ?] y [? ?]. split; eauto. + eapply All2_fold_impl_onctx; tea; simpl; unfold ondecl; intuition eauto. + depelim X5; constructor; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. @@ -269,6 +316,36 @@ Proof. cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. Qed. +(* Lemma extends_case_predicate_context {cf} Σ Σ' ci p pctx : + extends Σ Σ' -> wf Σ' -> + declared_inductive + case_predicate_context Σ ci p = case_predicate_context Σ' ci p. +Proof. + intros [] ext. + econstructor; eauto with extends. +Qed. +Hint Resolve extends_case_predicate_context : extends. *) + +(* Lemma extends_case_branches_contexts {cf} Σ Σ' ci p brsctx : + case_branches_contexts Σ ci p brsctx -> + extends Σ Σ' -> wf Σ' -> + case_branches_contexts Σ' ci p brsctx. +Proof. + intros [] ext. + econstructor; eauto with extends. +Qed. +Hint Resolve extends_case_branches_contexts : extends. *) + +Lemma weakening_env_red1 `{CF:checker_flags} Σ Σ' Γ M N : + wf Σ' -> + extends Σ Σ' -> + red1 Σ Γ M N -> + red1 Σ' Γ M N. +Proof. + induction 3 using red1_ind_all; + try solve [econstructor; eauto with extends; solve_all]. +Qed. + Lemma weakening_env_conv `{CF:checker_flags} Σ Σ' φ Γ M N : wf Σ' -> extends Σ Σ' -> @@ -303,72 +380,61 @@ Proof. - econstructor 3; eauto. eapply weakening_env_red1; eauto. exists Σ''; eauto. Qed. -Lemma weakening_env_is_allowed_elimination `{CF:checker_flags} Σ Σ' φ u allowed : +Lemma weakening_env_conv_decls {cf} {Σ φ Σ' Γ Γ'} : wf Σ' -> extends Σ Σ' -> - is_allowed_elimination (global_ext_constraints (Σ, φ)) u allowed -> - is_allowed_elimination (global_ext_constraints (Σ', φ)) u allowed. + CRelationClasses.subrelation (conv_decls (Σ, φ) Γ Γ') (conv_decls (Σ', φ) Γ Γ'). Proof. - intros wfΣ [Σ'' ->] al. - unfold is_allowed_elimination in *. - destruct check_univs; auto. - intros val sat. - unshelve epose proof (al val _) as al. - { eapply satisfies_subset; eauto. - apply global_ext_constraints_app. } - destruct allowed; auto; cbn in *; destruct ?; auto. + intros wf ext d d' Hd; depelim Hd; constructor; tas; + eapply weakening_env_conv; tea. Qed. -Hint Resolve weakening_env_is_allowed_elimination : extends. - -Lemma weakening_env_declared_constant `{CF:checker_flags}: - forall (Σ : global_env) cst (decl : constant_body), - declared_constant Σ cst decl -> - forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> declared_constant Σ' cst decl. -Proof. - intros Σ cst decl H0 Σ' X2 H2. - eapply extends_lookup; eauto. -Qed. -Hint Resolve weakening_env_declared_constant : extends. -Lemma weakening_env_declared_minductive `{CF:checker_flags}: - forall (Σ : global_env) ind decl, - declared_minductive Σ ind decl -> - forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> declared_minductive Σ' ind decl. +Lemma weakening_env_cumul_decls {cf} {Σ φ Σ' Γ Γ'} : + wf Σ' -> extends Σ Σ' -> + CRelationClasses.subrelation (cumul_decls (Σ, φ) Γ Γ') (cumul_decls (Σ', φ) Γ Γ'). Proof. - intros Σ cst decl H0 Σ' X2 H2. - eapply extends_lookup; eauto. + intros wf ext d d' Hd; depelim Hd; constructor; tas; + (eapply weakening_env_conv || eapply weakening_env_cumul); tea. Qed. -Hint Resolve weakening_env_declared_minductive : extends. -Lemma weakening_env_declared_inductive: - forall (H : checker_flags) (Σ : global_env) ind mdecl decl, - declared_inductive Σ ind mdecl decl -> - forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> declared_inductive Σ' ind mdecl decl. +Lemma weakening_env_conv_ctx {cf} {Σ Σ' φ Γ Δ} : + wf Σ' -> + extends Σ Σ' -> + conv_context (Σ, φ) Γ Δ -> + conv_context (Σ', φ) Γ Δ. Proof. - intros H Σ cst decl H0 [Hmdecl Hidecl] Σ' X2 H2. split; eauto with extends. + intros wf ext. + intros; eapply All2_fold_impl; tea => Γ0 Γ' d d'. + now eapply weakening_env_conv_decls. Qed. -Hint Resolve weakening_env_declared_inductive : extends. +Hint Resolve @weakening_env_conv_ctx : extends. -Lemma weakening_env_declared_constructor : - forall (H : checker_flags) (Σ : global_env) ind mdecl idecl decl, - declared_constructor Σ ind mdecl idecl decl -> - forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> - declared_constructor Σ' ind mdecl idecl decl. +Lemma weakening_env_cumul_ctx {cf} {Σ Σ' φ Γ Δ} : + wf Σ' -> + extends Σ Σ' -> + cumul_context (Σ, φ) Γ Δ -> + cumul_context (Σ', φ) Γ Δ. Proof. - intros H Σ cst mdecl idecl cdecl [Hidecl Hcdecl] Σ' X2 H2. - split; eauto with extends. + intros wf ext. + intros; eapply All2_fold_impl; tea => Γ0 Γ' d d'. + now eapply weakening_env_cumul_decls. Qed. -Hint Resolve weakening_env_declared_constructor : extends. +Hint Resolve @weakening_env_cumul_ctx : extends. -Lemma weakening_env_declared_projection : - forall (H : checker_flags) (Σ : global_env) ind mdecl idecl decl, - declared_projection Σ ind mdecl idecl decl -> - forall Σ' : global_env, wf Σ' -> extends Σ Σ' -> - declared_projection Σ' ind mdecl idecl decl. +Lemma weakening_env_is_allowed_elimination `{CF:checker_flags} Σ Σ' φ u allowed : + wf Σ' -> extends Σ Σ' -> + is_allowed_elimination (global_ext_constraints (Σ, φ)) u allowed -> + is_allowed_elimination (global_ext_constraints (Σ', φ)) u allowed. Proof. - intros H Σ cst mdecl idecl cdecl [Hidecl Hcdecl] Σ' X2 H2. - split; eauto with extends. + intros wfΣ [Σ'' ->] al. + unfold is_allowed_elimination in *. + destruct check_univs; auto. + intros val sat. + unshelve epose proof (al val _) as al. + { eapply satisfies_subset; eauto. + apply global_ext_constraints_app. } + destruct allowed; auto; cbn in *; destruct ?; auto. Qed. -Hint Resolve weakening_env_declared_projection : extends. +Hint Resolve weakening_env_is_allowed_elimination : extends. Lemma weakening_All_local_env_impl `{checker_flags} (P Q : context -> term -> option term -> Type) l : @@ -476,7 +542,7 @@ Hint Resolve extends_wf_fixpoint extends_wf_cofixpoint : extends. Lemma weakening_env `{checker_flags} : env_prop (fun Σ Γ t T => forall Σ', wf Σ' -> extends Σ.1 Σ' -> (Σ', Σ.2) ;;; Γ |- t : T) - (fun Σ Γ _ => + (fun Σ Γ => forall Σ', wf Σ' -> extends Σ.1 Σ' -> wf_local (Σ', Σ.2) Γ). Proof. apply typing_ind_env; intros; @@ -489,15 +555,24 @@ Proof. - econstructor; eauto 2 with extends. now apply extends_wf_universe. - econstructor; eauto 2 with extends. - close_Forall. intros; intuition eauto with extends. - destruct b as [s [Hs IH]]; eauto. + * eapply weakening_env_conv_ctx; eauto. + now destruct Σ. + * revert X6. clear -Σ' wfΣ' extΣ. + induction 1; constructor; eauto. + * close_Forall. intros; intuition eauto with extends. + eapply weakening_env_conv_ctx; eauto. + now destruct Σ. - econstructor; eauto with extends. + eapply fix_guard_extends; eauto. + + specialize (forall_Σ' _ wfΣ' extΣ). + now apply wf_local_app_inv in forall_Σ'. + eapply (All_impl X0); simpl; intuition eauto with extends. destruct X as [s Hs]; exists s. intuition eauto with extends. + eapply All_impl; eauto; simpl; intuition eauto with extends. - econstructor; eauto with extends. + eapply cofix_guard_extends; eauto. + + specialize (forall_Σ' _ wfΣ' extΣ). + now apply wf_local_app_inv in forall_Σ'. + eapply (All_impl X0); simpl; intuition eauto with extends. destruct X as [s Hs]; exists s. intuition eauto with extends. + eapply All_impl; eauto; simpl; intuition eauto with extends. @@ -520,7 +595,7 @@ Proof. intros HPΣ wfΣ' Hext Hdecl. destruct decl. 1:{ - destruct c. destruct cst_body. + destruct c. destruct cst_body0. - simpl in *. red in Hdecl |- *. simpl in *. eapply HPΣ; eauto. @@ -536,21 +611,21 @@ Proof. destruct X as [? ? ? ?]. unshelve econstructor; eauto. * unfold on_type in *; eauto. * clear on_cindices cstr_eq cstr_args_length. - revert on_cargs; generalize (cshape_sorts y) as l. - induction (cshape_args y); destruct l; simpl in *; eauto. + revert on_cargs. + induction (cstr_args x0) in y |- *; destruct y; simpl in *; eauto. ** destruct a as [na [b|] ty]; simpl in *; intuition eauto. ** destruct a as [na [b|] ty]; simpl in *; intuition eauto. * clear on_ctype on_cargs. revert on_cindices. - generalize (List.rev (PCUICLiftSubst.lift_context #|cshape_args y| 0 ind_indices)). - generalize (cshape_indices y). + generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))). + generalize (cstr_indices x0). induction 1; constructor; eauto. * simpl. intros v indv. specialize (on_ctype_variance v indv). simpl in *. move: on_ctype_variance. unfold cstr_respects_variance. destruct variance_universes as [[[univs u] u']|]; auto. intros [args idxs]. split. - ** eapply (context_relation_impl args); intros. + ** eapply (All2_fold_impl args); intros. inversion X; constructor; auto. ++ eapply weakening_env_cumul; eauto. ++ eapply weakening_env_conv; eauto. @@ -572,7 +647,7 @@ Proof. + intros v onv. move: (onIndices v onv). unfold ind_respects_variance. destruct variance_universes as [[[univs u] u']|] => //. - intros idx; eapply (context_relation_impl idx); simpl. + intros idx; eapply (All2_fold_impl idx); simpl. intros par par' t t' d. inv d; constructor; auto. ++ eapply weakening_env_cumul; eauto. @@ -633,7 +708,7 @@ Qed. Lemma declared_inductive_inv `{checker_flags} {Σ P ind mdecl idecl} : weaken_env_prop (lift_typing P) -> wf Σ -> Forall_decls_typing P Σ -> - declared_inductive Σ mdecl ind idecl -> + declared_inductive Σ ind mdecl idecl -> on_ind_body (lift_typing P) (Σ, ind_universes mdecl) (inductive_mind ind) mdecl (inductive_ind ind) idecl. Proof. intros. @@ -648,12 +723,12 @@ Lemma declared_constructor_inv `{checker_flags} {Σ P mdecl idecl ref cdecl} (HP : weaken_env_prop (lift_typing P)) (wfΣ : wf Σ) (HΣ : Forall_decls_typing P Σ) - (Hdecl : declared_constructor Σ mdecl idecl ref cdecl) : + (Hdecl : declared_constructor Σ ref mdecl idecl cdecl) : ∑ cs, let onib := declared_inductive_inv HP wfΣ HΣ (let (x, _) := Hdecl in x) in - nth_error onib.(ind_cshapes) ref.2 = Some cs + nth_error onib.(ind_cunivs) ref.2 = Some cs × on_constructor (lift_typing P) (Σ, ind_universes mdecl) mdecl - (inductive_ind ref.1) idecl onib.(ind_indices) cdecl cs. + (inductive_ind ref.1) idecl idecl.(ind_indices) cdecl cs. Proof. intros. destruct Hdecl as [Hidecl Hcdecl]. @@ -666,29 +741,33 @@ Lemma declared_projection_inv `{checker_flags} {Σ P mdecl idecl ref pdecl} : forall (HP : weaken_env_prop (lift_typing P)) (wfΣ : wf Σ) (HΣ : Forall_decls_typing P Σ) - (Hdecl : declared_projection Σ mdecl idecl ref pdecl), - let oib := declared_inductive_inv HP wfΣ HΣ (let (x, _) := Hdecl in x) in - match oib.(ind_cshapes) return Type with - | [cs] => - sorts_local_ctx (lift_typing P) (Σ, ind_universes mdecl) (arities_context (ind_bodies mdecl) ,,, ind_params mdecl) (cshape_args cs) - (cshape_sorts cs) * - on_projections mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) idecl (oib.(ind_indices)) cs * - ((snd ref) < context_assumptions cs.(cshape_args)) * - on_projection mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) cs (snd ref) pdecl + (Hdecl : declared_projection Σ ref mdecl idecl pdecl), + match idecl.(ind_ctors) return Type with + | [c] => + let oib := declared_inductive_inv HP wfΣ HΣ (let (x, _) := Hdecl in x) in + (match oib.(ind_cunivs) with + | [cs] => sorts_local_ctx (lift_typing P) (Σ, ind_universes mdecl) (arities_context (ind_bodies mdecl) ,,, ind_params mdecl) (cstr_args c) cs + | _ => False + end) * + on_projections mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) idecl (idecl.(ind_indices)) c * + ((snd ref) < context_assumptions c.(cstr_args)) * + on_projection mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) c (snd ref) pdecl | _ => False end. Proof. intros. destruct (declared_inductive_inv HP wfΣ HΣ (let (x, _) := Hdecl in x)) in *. - destruct Hdecl as [Hidecl [Hcdecl Hnpar]]. simpl. clearbody oib. + destruct Hdecl as [Hidecl [Hcdecl Hnpar]]. simpl. forward onProjections. { eapply nth_error_Some_length in Hcdecl. destruct (ind_projs idecl); simpl in *; try lia. congruence. } - destruct ind_cshapes as [|? []]; try contradiction. + destruct (ind_ctors idecl) as [|? []]; try contradiction. + destruct ind_cunivs as [|? []]; try contradiction; depelim onConstructors. + 2:{ depelim onConstructors. } intuition auto. - - red in onConstructors. destruct onProjections. + - destruct onProjections. destruct (ind_ctors idecl) as [|? []]; simpl in *; try discriminate. - inv onConstructors. now eapply on_cargs in X. + inv onConstructors. now eapply on_cargs in o. - destruct onProjections. eapply nth_error_Some_length in Hcdecl. lia. - destruct onProjections. eapply nth_error_alli in Hcdecl; eauto. @@ -721,18 +800,18 @@ Proof. now inv H0. Qed. -Lemma declared_inductive_inj `{cf : checker_flags} {Σ mdecl mdecl' ind idecl idecl'} : - declared_inductive Σ mdecl' ind idecl' -> - declared_inductive Σ mdecl ind idecl -> +Lemma declared_inductive_inj {Σ mdecl mdecl' ind idecl idecl'} : + declared_inductive Σ ind mdecl' idecl' -> + declared_inductive Σ ind mdecl idecl -> mdecl = mdecl' /\ idecl = idecl'. Proof. intros [] []. unfold declared_minductive in *. rewrite H in H1. inversion H1. subst. rewrite H2 in H0. inversion H0. eauto. Qed. -Lemma declared_constructor_inj `{cf : checker_flags} {Σ mdecl mdecl' idecl idecl' cdecl cdecl' c} : - declared_constructor Σ mdecl' idecl' c cdecl -> - declared_constructor Σ mdecl idecl c cdecl' -> +Lemma declared_constructor_inj {Σ mdecl mdecl' idecl idecl' cdecl cdecl' c} : + declared_constructor Σ c mdecl' idecl' cdecl -> + declared_constructor Σ c mdecl idecl cdecl' -> mdecl = mdecl' /\ idecl = idecl' /\ cdecl = cdecl'. Proof. intros [] []. @@ -740,9 +819,9 @@ Proof. rewrite H0 in H2. intuition congruence. Qed. -Lemma declared_projection_inj `{cf : checker_flags} {Σ mdecl mdecl' idecl idecl' pdecl pdecl' p} : - declared_projection Σ mdecl' idecl' p pdecl -> - declared_projection Σ mdecl idecl p pdecl' -> +Lemma declared_projection_inj {Σ mdecl mdecl' idecl idecl' pdecl pdecl' p} : + declared_projection Σ p mdecl' idecl' pdecl -> + declared_projection Σ p mdecl idecl pdecl' -> mdecl = mdecl' /\ idecl = idecl' /\ pdecl = pdecl'. Proof. intros [] []. @@ -751,12 +830,26 @@ Proof. rewrite H0 in H2. intuition congruence. Qed. -Lemma declared_inductive_minductive Σ ind mdecl idecl : - declared_inductive Σ mdecl ind idecl -> declared_minductive Σ (inductive_mind ind) mdecl. +Lemma declared_inductive_minductive {Σ ind mdecl idecl} : + declared_inductive Σ ind mdecl idecl -> declared_minductive Σ (inductive_mind ind) mdecl. Proof. now intros []. Qed. Hint Resolve declared_inductive_minductive : pcuic core. -Lemma on_declared_constant `{checker_flags} Σ cst decl : +Coercion declared_inductive_minductive : declared_inductive >-> declared_minductive. + +Lemma declared_constructor_inductive {Σ ind mdecl idecl cdecl} : + declared_constructor Σ ind mdecl idecl cdecl -> + declared_inductive Σ ind.1 mdecl idecl. +Proof. now intros []. Qed. +Coercion declared_constructor_inductive : declared_constructor >-> declared_inductive. + +Lemma declared_projection_inductive {Σ ind mdecl idecl cdecl} : + declared_projection Σ ind mdecl idecl cdecl -> + declared_inductive Σ ind.1.1 mdecl idecl. +Proof. now intros []. Qed. +Coercion declared_projection_inductive : declared_projection >-> declared_inductive. + +Lemma on_declared_constant `{checker_flags} {Σ cst decl} : wf Σ -> declared_constant Σ cst decl -> on_constant_decl (lift_typing typing) (Σ, cst_universes decl) decl. Proof. @@ -785,56 +878,55 @@ Proof. apply (declared_minductive_inv weaken_env_prop_typing wfΣ wfΣ Hdecl). Qed. -Lemma on_declared_inductive `{checker_flags} {Σ ref mdecl idecl} : - wf Σ -> - declared_inductive Σ mdecl ref idecl -> +Lemma on_declared_inductive `{checker_flags} {Σ ref mdecl idecl} {wfΣ : wf Σ} : + declared_inductive Σ ref mdecl idecl -> on_inductive (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ref) mdecl * on_ind_body (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind ref) mdecl (inductive_ind ref) idecl. Proof. - intros wfΣ Hdecl. + intros Hdecl. split. - destruct Hdecl as [Hmdecl _]. now apply on_declared_minductive in Hmdecl. - apply (declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ Hdecl). Defined. Lemma on_declared_constructor `{checker_flags} {Σ ref mdecl idecl cdecl} - (wfΣ : wf Σ) - (Hdecl : declared_constructor Σ mdecl idecl ref cdecl) : + {wfΣ : wf Σ} + (Hdecl : declared_constructor Σ ref mdecl idecl cdecl) : on_inductive (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind (fst ref)) mdecl * on_ind_body (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind (fst ref)) mdecl (inductive_ind (fst ref)) idecl * ∑ ind_ctor_sort, let onib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ (let (x, _) := Hdecl in x) in - nth_error (ind_cshapes onib) ref.2 = Some ind_ctor_sort + nth_error (ind_cunivs onib) ref.2 = Some ind_ctor_sort × on_constructor (lift_typing typing) (Σ, ind_universes mdecl) mdecl (inductive_ind (fst ref)) - idecl onib.(ind_indices) cdecl ind_ctor_sort. + idecl idecl.(ind_indices) cdecl ind_ctor_sort. Proof. - split. - - destruct Hdecl as [Hidecl Hcdecl]. - now apply on_declared_inductive in Hidecl. + split. + - apply (on_declared_inductive Hdecl). - apply (declared_constructor_inv weaken_env_prop_typing wfΣ wfΣ Hdecl). Defined. -Lemma on_declared_projection `{checker_flags} {Σ ref mdecl idecl pdecl} : - forall (wfΣ : wf Σ) (Hdecl : declared_projection Σ mdecl idecl ref pdecl), +Lemma on_declared_projection `{checker_flags} {Σ ref mdecl idecl pdecl} {wfΣ : wf Σ} + (Hdecl : declared_projection Σ ref mdecl idecl pdecl) : on_inductive (lift_typing typing) (Σ, ind_universes mdecl) (inductive_mind (fst (fst ref))) mdecl * - let oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ (let (x, _) := Hdecl in x) in - match oib.(ind_cshapes) return Type with - | [cs] => - sorts_local_ctx (lift_typing typing) (Σ, ind_universes mdecl) - (arities_context (ind_bodies mdecl) ,,, ind_params mdecl) (cshape_args cs) - (cshape_sorts cs) * - on_projections mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) idecl (oib.(ind_indices)) cs * - ((snd ref) < context_assumptions cs.(cshape_args)) * - on_projection mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) cs (snd ref) pdecl + match idecl.(ind_ctors) return Type with + | [c] => + let oib := declared_inductive_inv weaken_env_prop_typing wfΣ wfΣ (let (x, _) := Hdecl in x) in + (match oib.(ind_cunivs) with + | [cs] => sorts_local_ctx (lift_typing typing) (Σ, ind_universes mdecl) + (arities_context (ind_bodies mdecl) ,,, ind_params mdecl) (cstr_args c) cs + | _ => False + end) * + on_projections mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) idecl (idecl.(ind_indices)) c * + ((snd ref) < context_assumptions c.(cstr_args)) * + on_projection mdecl (inductive_mind ref.1.1) (inductive_ind ref.1.1) c (snd ref) pdecl | _ => False end. Proof. - intros wfΣ Hdecl. split. - - destruct Hdecl as [Hidecl Hcdecl]. now apply on_declared_inductive in Hidecl. + - apply (on_declared_inductive Hdecl). - apply (declared_projection_inv weaken_env_prop_typing wfΣ wfΣ Hdecl). Qed. diff --git a/pcuic/theories/PCUICWfCases.v b/pcuic/theories/PCUICWfCases.v new file mode 100644 index 000000000..f98bee0d1 --- /dev/null +++ b/pcuic/theories/PCUICWfCases.v @@ -0,0 +1,123 @@ + +(* Left-over from failed attempt using unexpanded contexts in case *) +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 + case representation that should match the global declarations + of the inductives. *) +Equations(noind) wf_cases (t : term) : bool := +| tRel _ => true; +| tVar _ => true; +| tEvar ev l => forallb wf_cases l; +| tSort s => true; +| tProd na t b => wf_cases t && wf_cases b; +| tLambda na t b => wf_cases t && wf_cases b; +| tLetIn na b t b' => [&& wf_cases b, wf_cases t & wf_cases b']; +| tApp t u => wf_cases t && wf_cases u; +| tConst _ _ => true; +| tInd _ _ => true; +| tConstruct _ _ _ => true; +| tCase ci p t brs with lookup_inductive Σ ci.(ci_ind) := { + | None => false; + | Some (mdecl, idecl) => + [&& wf_predicateb mdecl idecl p, + wf_branchesb idecl brs, + forallb wf_cases p.(pparams), + wf_cases t, + wf_cases p.(preturn) & forallb (wf_cases ∘ bbody) brs] + }; +| tProj p c => wf_cases c; +| tFix mfix idx => forallb (fun d => wf_cases d.(dtype) && wf_cases d.(dbody)) mfix; +| tCoFix mfix idx => forallb (fun d => wf_cases d.(dtype) && wf_cases d.(dbody)) mfix; +| tPrim p => true. + +Definition wf_cases_decl d := + wf_cases d.(decl_type) && option_default wf_cases d.(decl_body) true. + +Definition wf_cases_ctx ctx := + forallb wf_cases_decl ctx. + +End WfTerm. + +Lemma rename_wf_predicateb mdecl idecl p f : +wf_predicateb mdecl idecl (rename_predicate rename f p) = wf_predicateb mdecl idecl p. +Proof. +rewrite /wf_predicateb /rename_predicate. +now len. +Qed. + +Lemma map_branch_wf_branchb cdecl b f : +wf_branchb cdecl (map_branch f b) = wf_branchb cdecl b. +Proof. +now rewrite /wf_branchb /map_branch /=. +Qed. + + +Lemma forallb2_impl {A B} (p q : A -> B -> bool) l l' : + (forall x y, p x y -> q x y) -> + forallb2 p l l' -> forallb2 q l l'. +Proof. + intros hpq. + induction l in l' |- *; destruct l'; simpl; auto. + now move/andP=> [] /hpq -> /IHl ->. +Qed. + +Lemma forallb2_ext {A B} (p q : A -> B -> bool) l l' : + (forall x y, p x y = q x y) -> + forallb2 p l l' = forallb2 q l l'. +Proof. + intros hpq. + induction l in l' |- *; destruct l'; simpl; auto. + now rewrite hpq IHl. +Qed. + +Lemma forallb2_map_r {A B C} (p : A -> B -> bool) f l (l' : list C) : + forallb2 p l (map f l') = forallb2 (fun x y => p x (f y)) l l'. +Proof. + now rewrite -(map_id l) forallb2_map map_id. +Qed. + +Lemma rename_wf_branchesb idecl brs (f : branch term -> term -> term) : + wf_branchesb idecl (map (fun br => map_branch (f br) br) brs) = wf_branchesb idecl brs. +Proof. + rewrite /wf_branchesb /map_branch /=. + rewrite forallb2_map_r. + 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; + rewrite ?forallb_map; solve_all. + - eapply All_forallb_eq_forallb; eauto. + - destruct (lookup_inductive) as [[mdecl idecl]|] => /= //. + rewrite rename_wf_predicateb rename_wf_branchesb e IHt. repeat bool_congr. + rewrite forallb_map /=. f_equal. + { eapply All_forallb_eq_forallb; tea. + simpl; intuition auto. } + f_equal. f_equal. + { rewrite forallb_map /=. + eapply All_forallb_eq_forallb; tea. + simpl; intuition auto. } + - eapply All_forallb_eq_forallb; tea. + simpl; intuition auto. + now rewrite a b. + - eapply All_forallb_eq_forallb; tea. + simpl; intuition auto. + now rewrite a b. +Qed. + +Lemma wf_cases_fix_context Σ mfix : + forallb (fun d : def term => wf_cases Σ (dtype d) && wf_cases Σ (dbody d)) + mfix -> + wf_cases_ctx Σ (fix_context mfix). +Proof. + rewrite /wf_cases_ctx /fix_context. + rewrite /mapi. generalize 0 at 2. + induction mfix; simpl; auto. + move=> n /andP [/andP [wfa wfbod] wffix]. + now rewrite forallb_app /= /wf_cases_decl /= IHmfix // lift_rename wf_cases_rename wfa. +Qed. *) \ No newline at end of file diff --git a/pcuic/theories/PCUICWfUniverses.v b/pcuic/theories/PCUICWfUniverses.v index 2bf2fb4cc..fca922092 100644 --- a/pcuic/theories/PCUICWfUniverses.v +++ b/pcuic/theories/PCUICWfUniverses.v @@ -1,11 +1,10 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICInduction - PCUICLiftSubst PCUICTyping PCUICWeakeningEnv PCUICWeakening PCUICInversion +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction + PCUICLiftSubst PCUICSigmaCalculus PCUICTyping PCUICWeakeningEnv PCUICWeakening PCUICSubstitution PCUICReduction PCUICCumulativity PCUICGeneration - PCUICUnivSubst PCUICParallelReductionConfluence PCUICWeakeningEnv - PCUICUnivSubstitution PCUICConversion PCUICContexts. + PCUICUnivSubst PCUICWeakeningEnv PCUICUnivSubstitution. From Equations Require Import Equations. Require Import Equations.Prop.DepElim. @@ -83,7 +82,7 @@ Section CheckerFlags. apply forallbP. intros x; apply wf_universe_levelP. Qed. - Lemma wf_universe_subst_instance (Σ : global_env_ext) univs u l : + Lemma wf_universe_subst_instance_univ (Σ : global_env_ext) univs u l : wf Σ -> wf_universe Σ l -> wf_universe_instance (Σ.1, univs) u -> @@ -136,18 +135,18 @@ Section CheckerFlags. wf_universe (Σ, φ) (subst_instance_univ u s). Proof. intros wfΣ Hs cu. - apply (wf_universe_subst_instance (Σ, univs) φ); auto. + apply (wf_universe_subst_instance_univ (Σ, univs) φ); auto. Qed. - Lemma subst_instance_instance_empty u : + Lemma subst_instance_empty u : forallb (fun x => ~~ Level.is_var x) u -> - subst_instance_instance [] u = u. + subst_instance [] u = u. Proof. induction u; simpl; intros Hu; auto. - depelim Hu. + rewrite subst_instance_cons. + move/andP: Hu => [] isv Hf. rewrite IHu //. now destruct a => /= //; auto. - now destruct a => /= //; auto. Qed. Lemma wf_universe_level_mono Σ ctx u : @@ -215,8 +214,8 @@ Section CheckerFlags. apply In_Forall. auto. Qed. - Lemma in_subst_instance_instance l u u' : - In l (subst_instance_instance u u') -> + Lemma in_subst_instance l u u' : + In l (subst_instance u u') -> In l u \/ In l u' \/ l = Level.lSet. Proof. induction u'; simpl; auto. @@ -226,13 +225,13 @@ Section CheckerFlags. specialize (IHu' H). intuition auto. Qed. - Lemma wf_universe_subst_instance_instance Σ univs u u' φ : + Lemma wf_universe_subst_instance Σ univs u u' φ : wf Σ -> on_udecl_prop Σ univs -> wf_universe_instance (Σ, univs) u' -> wf_universe_instance (Σ, φ) u -> sub_context_set (monomorphic_udecl univs) (global_ext_context_set (Σ, φ)) -> - wf_universe_instance (Σ, φ) (subst_instance_instance u u'). + wf_universe_instance (Σ, φ) (subst_instance u u'). Proof. intros wfΣ onup Hs cu subc. destruct univs. @@ -293,8 +292,9 @@ Section CheckerFlags. | tApp t u | tProd _ t u | tLambda _ t u => wf_universes t && wf_universes u - | tCase _ t p brs => wf_universes t && wf_universes p && - forallb (test_snd wf_universes) brs + | tCase _ p c brs => + test_predicate (wf_universeb_instance Σ) wf_universes p && wf_universes c && + forallb (test_branch wf_universes) brs | tLetIn _ t t' u => wf_universes t && wf_universes t' && wf_universes u | tProj _ t => wf_universes t @@ -310,18 +310,44 @@ Section CheckerFlags. now rewrite IHAll H0. Qed. + Lemma test_context_mapi (p : term -> bool) f (ctx : context) k : + test_context p (mapi_context (shiftf f k) ctx) = test_context_k (fun k => p ∘ f k) k ctx. +Proof. + induction ctx; simpl; auto. + rewrite IHctx. f_equal. + now rewrite test_decl_map_decl. +Qed. +Hint Rewrite test_context_mapi : map. + +Lemma test_context_k_ctx (p : term -> bool) (ctx : context) k : + test_context p ctx = test_context_k (fun k => p) k ctx. +Proof. + induction ctx; simpl; auto. +Qed. + Lemma wf_universes_lift n k t : wf_universes (lift n k t) = wf_universes t. Proof. induction t in n, k |- * using term_forall_list_ind; simpl; auto; try rewrite ?IHt1 ?IHt2 ?IHt3; auto. - ssrbool.bool_congr. red in X. - rewrite forallb_map. - eapply All_forallb; eauto. simpl; intros []. - simpl. intros. cbn. now rewrite H. - rewrite forallb_map. + - destruct X as [? [? ?]]. solve_all. + rewrite IHt. + f_equal. f_equal. + unfold test_predicate => /=. + rewrite /id e. f_equal. + f_equal. f_equal. rewrite forallb_map. solve_all. + rewrite /shiftf. + rewrite test_context_mapi. + rewrite (test_context_k_ctx wf_universes (pcontext p) k). + eapply test_context_k_eqP_eq_spec; tea. + intros. solve_all. solve_all. + rewrite /test_branch. rewrite b. f_equal. + simpl. rewrite test_context_mapi. + rewrite (test_context_k_ctx wf_universes (bcontext x) k). + eapply test_context_k_eqP_eq_spec; tea. solve_all. + - rewrite forallb_map. eapply All_forallb; eauto. simpl; intros []. simpl. intros. cbn. now rewrite H. - rewrite forallb_map. + - rewrite forallb_map. eapply All_forallb; eauto. simpl; intros []. simpl. intros. cbn. now rewrite H. Qed. @@ -337,10 +363,20 @@ Section CheckerFlags. destruct nth_error eqn:nth; simpl; auto. eapply nth_error_all in nth; eauto. simpl in nth. intros. now rewrite wf_universes_lift. - - ssrbool.bool_congr. red in X. - rewrite forallb_map. - eapply All_forallb; eauto. simpl; intros []. - simpl. intros. cbn. now apply H. + - destruct X as [? [? ?]]. solve_all. + rewrite IHt. f_equal. f_equal. + unfold test_predicate => /=. + rewrite /id e. f_equal. + f_equal. f_equal. rewrite forallb_map. solve_all. + rewrite /shiftf. + rewrite test_context_mapi. + rewrite (test_context_k_ctx wf_universes (pcontext p) k). + eapply test_context_k_eqP_eq_spec; tea. + intros. solve_all. solve_all. + rewrite /test_branch. rewrite b. f_equal. + simpl. rewrite test_context_mapi. + rewrite (test_context_k_ctx wf_universes (bcontext x) k). + eapply test_context_k_eqP_eq_spec; tea. solve_all. - rewrite forallb_map. eapply All_forallb; eauto. simpl; intros []. simpl. intros. cbn. now rewrite H. @@ -375,33 +411,38 @@ Section CheckerFlags. intros wfΣ onudecl sub cu wft. induction t using term_forall_list_ind; simpl in *; auto; try to_prop; try apply /andP; to_wfu; intuition eauto 4. + all:autorewrite with map; repeat (f_equal; solve_all). - to_wfu. destruct Σ as [Σ univs']. simpl in *. - eapply (wf_universe_subst_instance (Σ, univs)); auto. + eapply (wf_universe_subst_instance_univ (Σ, univs)); auto. - - apply /andP; to_wfu; intuition eauto 4. - apply/wf_universe_instanceP. - eapply wf_universe_subst_instance_instance; eauto. + eapply wf_universe_subst_instance; eauto. destruct Σ; simpl in *. now move/wf_universe_instanceP: wft. - apply/wf_universe_instanceP. - eapply wf_universe_subst_instance_instance; eauto. + eapply wf_universe_subst_instance; eauto. destruct Σ; simpl in *. now move/wf_universe_instanceP: wft. - apply/wf_universe_instanceP. - eapply wf_universe_subst_instance_instance; eauto. + eapply wf_universe_subst_instance; eauto. destruct Σ; simpl in *. now move/wf_universe_instanceP: wft. - - apply /andP; to_wfu; intuition eauto 4. - - rewrite forallb_map. - red in X. solve_all. - - rewrite forallb_map. red in X. - solve_all. to_prop. - apply /andP; split; to_wfu; auto 4. - - rewrite forallb_map. red in X. - solve_all. to_prop. - apply /andP; split; to_wfu; auto 4. + - move/andP: H1; rewrite /test_predicate. + move => [] /andP [] /andP [] wfu wfpars wfpctx wfpret. + cbn. + rewrite (i wfpret). + rtoProp. intuition auto. + apply/wf_universe_instanceP. + eapply wf_universe_subst_instance; eauto. + destruct Σ; simpl in *. + now move/wf_universe_instanceP: wfu. + solve_all. solve_all. + - rewrite /test_branch. rtoProp. + move/andP: b => [] tctx wfu. + split; auto. simpl. + solve_all. Qed. Lemma weaken_wf_universe Σ Σ' t : wf Σ' -> extends Σ.1 Σ' -> @@ -464,11 +505,17 @@ Section CheckerFlags. - apply /wf_universe_instanceP; apply weaken_wf_universe_instance; eauto. now apply /wf_universe_instanceP. - apply /andP; to_wfu; intuition eauto 4. + move/andP: H => [] /andP [] /andP []. + rewrite /test_predicate. intros; rtoProp. + destruct X as [? [? ?]]. + intuition auto; solve_all. + apply /wf_universe_instanceP; apply weaken_wf_universe_instance; eauto. + now apply /wf_universe_instanceP. - red in X; solve_all. - - red in X. solve_all. to_prop. - apply /andP; split; to_wfu; auto 4. - - red in X. solve_all. to_prop. - apply /andP; split; to_wfu; auto 4. + move/andP: b. rewrite /test_branch. rtoProp. + solve_all. + - red in X. solve_all. + - red in X. solve_all. Qed. Lemma wf_universes_weaken_full : weaken_env_prop_full (fun Σ Γ t T => @@ -636,6 +683,22 @@ Section CheckerFlags. now rewrite it_mkProd_or_LetIn_app /= IHΓ /wf_ctx_universes forallb_app /= {3}/wf_decl_universes; cbn; bool_congr. Qed. + + Lemma test_context_app p Γ Δ : + test_context p (Γ ,,, Δ) = test_context p Γ && test_context p Δ. + Proof. + induction Δ; simpl; auto. + - now rewrite andb_true_r. + - now rewrite IHΔ andb_assoc. + Qed. + + + Lemma wf_universes_it_mkLambda_or_LetIn {Σ Γ T} : + wf_universes Σ (it_mkLambda_or_LetIn Γ T) = test_context (wf_universes Σ) Γ && wf_universes Σ T. + Proof. + induction Γ as [ |[na [b|] ty] Γ] using rev_ind; simpl; auto; + now rewrite it_mkLambda_or_LetIn_app /= IHΓ test_context_app /= /test_decl /= andb_assoc. + Qed. Lemma wf_projs Σ ind npars p : All (fun t : term => wf_universes Σ t) (projs ind npars p). @@ -654,24 +717,36 @@ Section CheckerFlags. move=> /andP []; rewrite /wf_decl_universes /= => wfty wfΓ. constructor; eauto. Qed. - + Theorem wf_types : env_prop (fun Σ Γ t T => wf_universes Σ t && wf_universes Σ T) - (fun Σ Γ wfΓ => - All_local_env_over typing - (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ) - (t T : term) (_ : Σ;;; Γ |- t : T) => wf_universes Σ t && wf_universes Σ T) Σ Γ - wfΓ). + (fun Σ Γ => + All_local_env + (lift_typing (fun (Σ : global_env_ext) (Γ : context) (t T : term) => + wf_universes Σ t && wf_universes Σ T) Σ) Γ × + test_context (wf_universes Σ) Γ). Proof. apply typing_ind_env; intros; rename_all_hyps; simpl; specIH; to_prop; simpl; auto. + - split. + * induction X; constructor; auto. + destruct tu as [s tu]; exists s; simpl. + now simpl in p. + destruct tu as [s tu]; exists s; simpl. + now simpl in p. + * induction X; simpl; auto. + rewrite IHX /= /test_decl /=. now move/andP: p. + rewrite IHX /= /test_decl /=. now move/andP: p => [] -> ->. + - rewrite wf_universes_lift. - destruct (nth_error_All_local_env_over heq_nth_error X) as [HΓ' Hd]. + destruct X as [X _]. + pose proof (nth_error_Some_length heq_nth_error). + eapply nth_error_All_local_env in X; tea. + rewrite heq_nth_error /= in X. red in X. destruct decl as [na [b|] ty]; cbn -[skipn] in *. - + destruct Hd as [Hd _]; now to_prop. - + destruct lookup_wf_local_decl; cbn -[skipn] in *. - destruct o. now simpl in Hd; to_prop. + + now to_prop. + + destruct X as [s Hs]. now to_prop. - apply/andP; split; to_wfu; eauto with pcuic. @@ -735,11 +810,23 @@ Section CheckerFlags. now eapply consistent_instance_ext_wf. - apply /andP. split. - solve_all. cbn in *. now to_prop. + solve_all. cbn in *. + destruct H0. + rewrite /test_predicate. + rewrite wf_universes_mkApps in H5. + move/andP: H5 => /= [] ->; rewrite forallb_app; move/andP => [] -> wfinds. + rewrite test_context_app in b0. move/andP: b0 => [] _ ->. + now rewrite H4. + rewrite /test_branch. + rewrite test_context_app in b2; move/andP: b2 => [] _ ->. + now rewrite H9. rewrite wf_universes_mkApps; apply/andP; split; auto. + rewrite /ptm. + rewrite wf_universes_it_mkLambda_or_LetIn H4. + destruct X1 as [_ X1]. rewrite /wf_ctx_universes. + now rewrite test_context_app in X1; move/andP: X1 => [] _ ->. rewrite forallb_app /= H /= andb_true_r. - rewrite forallb_skipn //. - rewrite wf_universes_mkApps in H0. + rewrite wf_universes_mkApps forallb_app in H5. now to_prop. - rewrite /subst1. rewrite wf_universes_subst. @@ -749,10 +836,12 @@ Section CheckerFlags. now intros _ hargs%forallb_All. pose proof (declared_projection_inv wf_universes_weaken wf X isdecl). destruct (declared_inductive_inv); simpl in *. - destruct ind_cshapes as [|cs []] => //. - destruct X1. red in o. subst ty. - destruct nth_error eqn:heq => //. - destruct o as [_ ->]. + destruct ind_ctors as [|cs []] => //. + destruct ind_cunivs as [|cunivs []] => //; + destruct X1 as [[[? ?] ?] ?] => //. + red in o0. + destruct nth_error eqn:heq => //. + subst ty. destruct o0 as [_ ->]. rewrite wf_universes_mkApps in H1. move/andP: H1 => [/wf_universe_instanceP wfu wfargs]. @@ -767,7 +856,6 @@ Section CheckerFlags. eapply wf_abstract_instance. rewrite wf_universes_subst. apply wf_projs. rewrite wf_universes_lift. - destruct p0 as [[? ?] ?]. rewrite smash_context_app smash_context_acc in heq. autorewrite with len in heq. rewrite nth_error_app_lt in heq. autorewrite with len. lia. @@ -788,17 +876,15 @@ Section CheckerFlags. 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. move:a => [s [Hty /andP[wfty wfs]]]. - to_prop. now rewrite wfty. + solve_all. now rewrite wf_universes_lift in H2. eapply nth_error_all in X0; eauto. simpl in X0. now move: X0 => [s [Hty /andP[wfty _]]]. - apply/andP; split; auto. - solve_all. move:a => [s [Hty /andP[wfty wfs]]]. - to_prop. now rewrite wfty. + solve_all. now rewrite wf_universes_lift in H2. eapply nth_error_all in X0; eauto. simpl in X0. now move: X0 => [s [Hty /andP[wfty _]]]. Qed. diff --git a/pcuic/theories/PCUICWhReduction.v b/pcuic/theories/PCUICWhReduction.v new file mode 100644 index 000000000..3a231ec36 --- /dev/null +++ b/pcuic/theories/PCUICWhReduction.v @@ -0,0 +1,606 @@ +(* Distributed under the terms of the MIT license. *) + +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 PCUICCases PCUICContextRelation + PCUICContextReduction PCUICEquality PCUICLiftSubst PCUICTyping PCUICWeakeningEnv + PCUICInduction PCUICRedTypeIrrelevance PCUICNormal PCUICReduction. +Require Import ssreflect. +Set Asymmetric Patterns. +From Equations Require Import Equations. + +Inductive wh_red1 (Σ : global_env) (Γ : context) : term -> term -> Type := +(** Reductions *) +(** Beta *) +| wh_red_beta na t b a : + wh_red1 Σ Γ (tApp (tLambda na t b) a) (subst10 a b) + +(** Let *) +| wh_red_zeta na b t b' : + wh_red1 Σ Γ (tLetIn na b t b') (subst10 b b') + +| wh_red_rel i body : + option_map decl_body (nth_error Γ i) = Some (Some body) -> + wh_red1 Σ Γ (tRel i) (lift0 (S i) body) + +(** Case *) +| wh_red_iota ci c u args p brs br : + nth_error brs c = Some br -> + #|skipn (ci_npar ci) args| = context_assumptions br.(bcontext) -> + wh_red1 Σ Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + (iota_red ci.(ci_npar) args br) + +(** Fix unfolding, with guard *) +| wh_red_fix mfix idx args a fn : + unfold_fix mfix idx = Some (#|args|, fn) -> + isConstruct_app a -> + wh_red1 Σ Γ (tApp (mkApps (tFix mfix idx) args) a) (tApp (mkApps fn args) a) + +(** CoFix-case unfolding *) +| wh_red_cofix_case ip p mfix idx args narg fn brs : + unfold_cofix mfix idx = Some (narg, fn) -> + wh_red1 Σ Γ (tCase ip p (mkApps (tCoFix mfix idx) args) brs) + (tCase ip p (mkApps fn args) brs) + +(** CoFix-proj unfolding *) +| wh_red_cofix_proj p mfix idx args narg fn : + unfold_cofix mfix idx = Some (narg, fn) -> + wh_red1 Σ Γ (tProj p (mkApps (tCoFix mfix idx) args)) + (tProj p (mkApps fn args)) + +(** Constant unfolding *) +| wh_red_delta c decl body (isdecl : declared_constant Σ c decl) u : + decl.(cst_body) = Some body -> + wh_red1 Σ Γ (tConst c u) (subst_instance u body) + +(** Proj *) +| wh_red_proj i pars narg args u arg: + nth_error args (pars + narg) = Some arg -> + wh_red1 Σ Γ (tProj (i, pars, narg) (mkApps (tConstruct i 0 u) args)) arg + +| case_red_discr ci p c c' brs : + wh_red1 Σ Γ c c' -> + wh_red1 Σ Γ (tCase ci p c brs) (tCase ci p c' brs) + +| proj_red p c c' : wh_red1 Σ Γ c c' -> wh_red1 Σ Γ (tProj p c) (tProj p c') + +| app_red_l M1 N1 M2 : wh_red1 Σ Γ M1 N1 -> wh_red1 Σ Γ (tApp M1 M2) (tApp N1 M2) + +(** Reduction of a fixpoint's principal/recursive argument *) +| wh_red_fix_arg mfix idx args fn arg arg' : + unfold_fix mfix idx = Some (#|args|, fn) -> + wh_red1 Σ Γ arg arg' -> + wh_red1 Σ Γ (tApp (mkApps (tFix mfix idx) args) arg) + (tApp (mkApps (tFix mfix idx) args) arg'). + +Derive Signature NoConfusion for wh_red1. + + + +From Coq Require Import ssrbool. + +Ltac invwh := simpl in *; try congruence || match goal with + | [ H : whne _ _ _ (mkApps _ _) |- _ ] => + eapply whne_mkApps_inv in H => //; solve_discr; + destruct H as [|[? [? [? [? [? [eq [? [? ?]]]]]]]]]; solve_discr + | [ H : whne _ _ _ (?f ?x) |- _ ] => depelim H; solve_discr; simpl in *; try congruence + end. + +Lemma nisConstruct_app_whne {Σ Γ a} : + whne RedFlags.default Σ Γ a -> isConstruct_app a -> False. +Proof. + rewrite /isConstruct_app. + destruct decompose_app eqn:da. + pose proof (decompose_app_notApp _ _ _ da). + eapply decompose_app_inv in da. subst. + intros wh. simpl. + destruct t => //. intros _. + repeat invwh. +Qed. + + +Set Equations With UIP. + +Lemma uip_pr1 {A B} {HA : UIP A} (x : A) (y y' : B x) : + y = y' -> + {| pr1 := x; pr2 := y |} = + {| pr1 := x; pr2 := y' |}. +Proof. + intros ->. + f_equal. +Qed. + +Lemma uip_K {A} {HA : UIP A} {x : A} (e : x = x) : e = eq_refl. +Proof. + apply uip. +Qed. + +Lemma mkApps_tApp_inj fn args t u : + ~~ isApp fn -> + mkApps fn args = tApp t u -> + args <> [] /\ t = mkApps fn (removelast args) /\ nth_error args #|removelast args| = Some u. +Proof. + intros napp eqapp. + destruct args using rev_case => //. + simpl in eqapp. subst fn => //. + rewrite -mkApps_nested in eqapp. noconf eqapp. + rewrite removelast_app // /= app_nil_r nth_error_app_ge // Nat.sub_diag /=. + repeat split; auto. now destruct args. +Qed. + +Ltac simpl_tApp_eq := + match goal with + | [ H : tApp _ _ = mkApps _ _ |- _ ] => + symmetry in H; simpl_tApp_eq + | [ H : mkApps _ _ = tApp _ _ |- _ ] => + let H' := fresh in let H'' := fresh in + let argsnil := fresh in + apply mkApps_tApp_inj in H as [argsnil [H' H'']] => //; + try rewrite -> H in *; try rewrite -> H' in * + end. + +Ltac simpl_mkApps := + match goal with + [ H : mkApps ?f _ = mkApps _ _ |- _ ] => + let H' := fresh in + let H'' := fresh in + pose proof (mkApps_eq_inj H eq_refl eq_refl) as [H' H'']; + noconf H'; noconf H'' + end. + +Ltac simpl_mkApps_in eqH := + match goal with + [ H : mkApps ?f _ = mkApps _ _ |- _ ] => + let H' := fresh in + let H'' := fresh in + pose proof (mkApps_eq_inj H eq_refl eq_refl) as [H' H'']; + noconf H'; noconf H''; try rewrite (uip_K H) in eqH; cbn in eqH; try noconf eqH + end. + +Lemma removelast_app_tip {A} (l : list A) (a : A) : + removelast (l ++ [a]) = l. +Proof. + now rewrite removelast_app // /= app_nil_r. +Qed. + +Lemma nth_error_app_removelast {A} (l : list A) (a : A) : + nth_error l #|removelast l| = Some a -> + removelast l ++ [a] = l. +Proof. + induction l using rev_case. + * rewrite nth_error_nil => //. + * rewrite removelast_app_tip. + intros hnth. + rewrite nth_error_app_ge // Nat.sub_diag /= in hnth. + now noconf hnth. +Qed. + +Lemma firstn_removelast_length {A} (l : list A) : + firstn #|removelast l| l = removelast l. +Proof. + induction l using rev_ind => /= //. + now rewrite removelast_app_tip (firstn_app_left _ 0) // /= app_nil_r. +Qed. + +Lemma skipn_removelast_length {A} (l : list A) : + skipn (S #|removelast l|) l = []. +Proof. + induction l using rev_ind => /= //. + rewrite removelast_app_tip -Nat.add_1_r skipn_all2 // app_length /= //. +Qed. + +Lemma wh_red1_fix {Σ Γ mfix idx t args} : + wh_red1 Σ Γ (mkApps (tFix mfix idx) args) t -> + (∑ rarg body arg, + unfold_fix mfix idx = Some (rarg, body) × + (nth_error args rarg = Some arg) × + ((isConstruct_app arg × t = mkApps body args) + + ∑ arg', (wh_red1 Σ Γ arg arg' × t = mkApps (tFix mfix idx) (firstn rarg args ++ (arg' :: skipn (S rarg) args))))). +Proof. + intros h; depind h; solve_discr. + - simpl_tApp_eq. simpl_mkApps. + eexists _, _, _; repeat split; eauto. + left. rewrite -mkApps_snoc nth_error_app_removelast //. + - simpl_tApp_eq. + specialize (IHh _ _ _ _ eq_refl) as [rarg [body [arg [unffix [hnth whne]]]]]. + eexists _, _, _; repeat split; tea. + now apply nth_error_removelast in hnth. + destruct whne; [left|right]; intuition auto. + * rewrite b. rewrite -mkApps_snoc. f_equal. + rewrite nth_error_app_removelast //. + * destruct s as [arg' [wharg ->]]. + exists arg'; split => //. + rewrite -mkApps_snoc. f_equal. + pose proof (nth_error_removelast hnth). + eapply nth_error_Some_length in H. + rewrite firstn_removelast // - !app_assoc /=. f_equal. f_equal. + destruct args using rev_case => //. + rewrite removelast_app_tip. + rewrite skipn_app. f_equal. + eapply nth_error_Some_length in hnth. + rewrite app_length /= in H. + rewrite removelast_app_tip in hnth. + assert (S rarg - #|args| = 0) as -> by lia. + rewrite skipn_0. + rewrite removelast_app_tip in H1. + rewrite nth_error_app_ge // Nat.sub_diag /= in H1. now noconf H1. + - simpl_tApp_eq; simpl_mkApps. + exists #|removelast args0|, fn, arg; repeat split; tea. + right. exists arg'; repeat split; auto. + rewrite -mkApps_snoc. f_equal. + now rewrite firstn_removelast_length skipn_removelast_length. +Qed. + +Lemma whne_fix Σ Γ mfix idx args : + whne RedFlags.default Σ Γ (mkApps (tFix mfix idx) args) -> + (∑ rarg body arg, + unfold_fix mfix idx = Some (rarg, body) × + (nth_error args rarg = Some arg) × + whne RedFlags.default Σ Γ arg). +Proof. + intros h; depind h; solve_discr. + - apply PCUICAstUtils.mkApps_tApp_inj in H as [-> ->] => //. + specialize (IHh _ _ _ eq_refl) as [rarg [body [arg [unffix [hnth whne]]]]]. + eexists _, _, _; repeat split; tea. + now apply nth_error_removelast in hnth. + - exists rarg, body, arg; repeat split; tea. + - simpl in e; congruence. +Qed. + +From MetaCoq.PCUIC Require Import PCUICSize. + +Lemma eqs_trans {A} {x y z : A} (e : x = y) (e' : x = z) : y = z. +Proof. rewrite -e. exact e'. Defined. + +Ltac inj_eqs := + match goal with + | [ H : ?x = ?y, H' : ?x = ?z |- _] => + let H'' := fresh in + pose proof (eqs_trans H H') as H''; progress noconf H'' + end. + +Lemma whne_wh_red1 Σ Γ t u : + wh_red1 Σ Γ t u -> whne RedFlags.default Σ Γ t -> False. +Proof. + intros r h. + induction t in r, h, u |- * using term_ind_size_app. + all:depelim h. + all:try solve [depelim r; solve_discr; simpl in *; try congruence]. + all:try solve [eapply mkApps_discr in H1; auto]. + - depelim r. + * depelim h; solve_discr; simpl in *; try congruence. + * eapply whne_fix in h as [rarg [body [arg [unf [nth whne]]]]]. + rewrite unf in e; noconf e. + eapply nth_error_Some_length in nth. lia. + * eauto. + * eapply whne_fix in h as [rarg' [body' [arg'' [unf' [nth' whne']]]]]. + rewrite unf' in e; noconf e. + eapply nth_error_Some_length in nth'. lia. + - rewrite H0 in r. + depelim r; solve_discr. + * repeat simpl_tApp_eq. simpl_mkApps. + subst t1. inj_eqs. + rewrite e in e1. noconf e1. rewrite e0 in H3; noconf H3. + eapply nisConstruct_app_whne in h; eauto. + * simpl_tApp_eq. + eapply wh_red1_fix in r as (?&?&?&?&?&?). + rewrite e1 in e; noconf e. + rewrite (nth_error_removelast e2) in e0; noconf e0. + simpl_tApp_eq. inj_eqs. + destruct s. + + destruct p. eapply nisConstruct_app_whne in h; eauto. + + destruct s as [arg' [wh _]]. + eapply H; tea. + eapply (nth_error_size size) in e2. + now rewrite /= size_mkApps. + * simpl_tApp_eq. simpl_mkApps. repeat inj_eqs. + eapply H; tea. rewrite -H0. + eapply (nth_error_size size) in e0. + now rewrite mkApps_size. + - depelim r; solve_discr. + * eapply whne_mkApps_inv in h as [|]; auto. + invwh. + destruct s as (? & ? & ? & ? & ? & ?). intuition discriminate. + * eapply whne_mkApps_inv in h as [|]; auto. + invwh. + destruct s as (? & ? & ? & ? & ? & ?). intuition discriminate. + * eauto. + - depelim r; solve_discr. + * eapply whne_mkApps_inv in h as [|]; auto. + invwh. + destruct s0 as (? & ? & ? & ? & ? & ?). intuition discriminate. + * eapply whne_mkApps_inv in h as [|]; auto. + invwh. + destruct s as (? & ? & ? & ? & ? & ?). intuition discriminate. + * eauto. +Qed. + +Lemma wh_red1_abs {Σ Γ na ty b t} : + wh_red1 Σ Γ (tLambda na ty b) t -> False. +Proof. + intros r; depind r; solve_discr. +Qed. + +Lemma wh_red1_constr {Σ Γ i n u args t} : + wh_red1 Σ Γ (mkApps (tConstruct i n u) args) t -> False. +Proof. + intros r; depind r; try simpl_tApp_eq; solve_discr; eauto. +Qed. + +Lemma wh_red1_inductive {Σ Γ i u args t} : + wh_red1 Σ Γ (mkApps (tInd i u) args) t -> False. +Proof. + intros r; depind r; try simpl_tApp_eq; solve_discr; eauto. +Qed. + +Lemma wh_red1_cofix {Σ Γ mfix idx args t} : + wh_red1 Σ Γ (mkApps (tCoFix mfix idx) args) t -> False. +Proof. + intros r; depind r; try simpl_tApp_eq; solve_discr; eauto. +Qed. + +Lemma whnf_wh_red1 Σ Γ t u : + wh_red1 Σ Γ t u -> whnf RedFlags.default Σ Γ t -> False. +Proof. + induction 2. + 1:eauto using whne_wh_red1. + all:depelim X; try simpl_tApp_eq; try simpl_mkApps; solve_discr. + - now eapply wh_red1_constr in X. + - now apply wh_red1_inductive in X. + - rewrite e in y. congruence. + - eapply wh_red1_fix in X as (?&?&?&?&?&?). + rewrite e in y. + now rewrite (nth_error_removelast e0) in y. + - rewrite e in y. congruence. + - now eapply wh_red1_cofix in X. +Qed. + +Lemma isConstruct_app_tApp t u : isConstruct_app (tApp t u) -> isConstruct_app t. +Proof. + rewrite /isConstruct_app /decompose_app /=. + now rewrite fst_decompose_app_rec. +Qed. + +Lemma isConstruct_app_spec t : + isConstruct_app t -> + ∑ ind n u args, t = mkApps (tConstruct ind n u) args. +Proof. + induction t => // /=. + - intros isc. apply isConstruct_app_tApp in isc. + destruct (IHt1 isc) as [ind [n [u [args ->]]]]. + exists ind, n, u, (args ++ [t2]). + now rewrite -mkApps_snoc. + - intros _. + now exists ind, n, ui, []. +Qed. + +Lemma wh_red1_isConstruct_app Σ Γ arg arg' : + wh_red1 Σ Γ arg arg' -> + isConstruct_app arg -> False. +Proof. + intros w isc. + eapply isConstruct_app_spec in isc as [ind [n [u [args' ->]]]]. + now eapply wh_red1_constr in w. +Qed. + +Lemma is_constructor_args narg args : is_constructor narg args -> args <> []. +Proof. + rewrite /is_constructor. + destruct args => //. now rewrite nth_error_nil. +Qed. + +Lemma is_constructor_removelast_args narg (args : list term) arg : + nth_error (removelast args) narg = Some arg -> args <> []. +Proof. + destruct args => //. now rewrite nth_error_nil. +Qed. + +Ltac invert_wh_red1 := + match goal with + | [ H : wh_red1 _ _ (mkApps (tConstruct _ _ _) _) _ |- _] => + now apply wh_red1_constr in H + | [ H : wh_red1 _ _ (mkApps (tCoFix _ _) _) _ |- _] => + now apply wh_red1_cofix in H + | [ H : wh_red1 _ _ (tLambda _ _ _) _ |- _] => + now apply wh_red1_abs in H + | [ H : wh_red1 _ _ (mkApps (tInd _ _) _) _ |- _] => + now apply wh_red1_inductive in H + end. + +Lemma uip_pr2 {A B} {HB : UIP B} (P Q : A -> B) (x x' : A) (y : P x = Q x) (y' : P x' = Q x') : + x = x' -> + {| pr1 := x; pr2 := y |} = + {| pr1 := x'; pr2 := y' |} :> sigma (fun x => P x = Q x). +Proof. + intros ->. + now rewrite (uip y y'). +Qed. + +Instance branch_UIP : UIP (branch term). +Proof. + eapply EqDec.eqdec_uip; tc. +Qed. + +Instance option_UIP {A} (u : EqDec A) : UIP (option A). +Proof. + eapply EqDec.eqdec_uip; tc. + eqdec_proof. +Qed. + +Ltac clear_uip := + match goal with + | [ H : ?x = ?y, H' : ?x = ?y |- _] => + rewrite -> (uip H H') in *; try clear H + end. + +Lemma isConstruct_app_whnf {Σ Γ t} : + isConstruct_app t -> whnf RedFlags.default Σ Γ t. +Proof. + move/isConstruct_app_spec => [ind [c [u [args ->]]]]. + eapply whnf_cstrapp. +Qed. + +Lemma wh_red1_unique_sig {Σ Γ t u u'} (r0 : wh_red1 Σ Γ t u) (r1 : wh_red1 Σ Γ t u') : + {| pr1 := {| pr1 := t; pr2 := u |}; pr2 := r0 |} = + {| pr1 := {| pr1 := t; pr2 := u' |}; pr2 := r1 |} :> sigma (fun x : sigma (fun _ : term => term) => wh_red1 Σ Γ (pr1 x) (pr2 x)). +Proof. + eapply noConfusion_wh_red1_obligation_1. + induction r0 in u', r1 |- *; depelim r1 => //. + all:try solve [ + let H' := fresh in + pose proof (f_equal (@pr1 _ _) H) as H'; simpl in H'; noconf H'; + solve_discr]. + all:try solve [try clear H; try clear IHr0; solve_discr]. + all:try solve [elimtype False; invert_wh_red1]. + all:try (simpl_mkApps_in H); try simpl_mkApps; repeat (inj_eqs; clear_uip); try reflexivity. + all:try (simpl; clear IHr0; invert_wh_red1). + - now rewrite (uip i i0). + - simpl. eapply wh_red1_fix in r1 as [rarg [body [arg [unf [hnth s]]]]]. + rewrite e in unf. noconf unf. + now apply nth_error_Some_length in hnth. + - simpl. apply (whnf_wh_red1 _ _ _ _ r1). + now eapply isConstruct_app_whnf. + - pose proof (declared_constant_inj _ _ isdecl isdecl0). + destruct H. inj_eqs. + repeat clear_uip. + now rewrite (uip isdecl isdecl0). + - simpl. specialize (IHr0 _ r1). + eapply noConfusion_wh_red1_obligation_1 in IHr0. now noconf IHr0. + - simpl. specialize (IHr0 _ r1). + eapply noConfusion_wh_red1_obligation_1 in IHr0. now noconf IHr0. + - simpl. clear IHr0. eapply wh_red1_fix in r0 as [rarg [body [arg [unf [hnth s]]]]]. + inj_eqs. now apply nth_error_Some_length in hnth. + - simpl. specialize (IHr0 _ r1). + eapply noConfusion_wh_red1_obligation_1 in IHr0. now noconf IHr0. + - simpl. clear IHr0. + eapply wh_red1_fix in r0 as [rarg [body [arg [unf [hnth s]]]]]. + inj_eqs. now apply nth_error_Some_length in hnth. + - simpl. clear IHr0. + eapply (whnf_wh_red1 _ _ _ _ r0). + now apply isConstruct_app_whnf. + - simpl; clear IHr0. + eapply wh_red1_fix in r1 as [rarg [body [arg'' [unf [hnth s]]]]]. + inj_eqs. + now apply nth_error_Some_length in hnth. + - specialize (IHr0 _ r1). + eapply noConfusion_wh_red1_obligation_1 in IHr0. now noconf IHr0. +Qed. + +(* Not only the relation is deterministic on end values, + we also show that it is also proof-irrelevant: there is actually a single + weak-head reduction path between two terms. *) + +Lemma wh_red1_unique {Σ Γ t u u'} : + wh_red1 Σ Γ t u -> wh_red1 Σ Γ t u' -> u = u'. +Proof. + intros r0 r1. + pose proof (wh_red1_unique_sig r0 r1). + noconf H. reflexivity. +Qed. + +Lemma wh_red1_irrelevant {Σ Γ t u} (r0 r1 : wh_red1 Σ Γ t u) : r0 = r1. +Proof. + pose proof (wh_red1_unique_sig r0 r1). + noconf H. simpl. reflexivity. +Qed. + +Lemma wh_red1_red1 {Σ Γ t u} : wh_red1 Σ Γ t u -> red1 Σ Γ t u. +Proof. + induction 1; try solve [econstructor; eauto]. + rewrite - !mkApps_snoc. + eapply red_fix. tea. + now rewrite /is_constructor nth_error_app_ge // Nat.sub_diag /=. +Qed. +From MetaCoq.PCUIC Require Import PCUICSubstitution. + +Lemma unfold_fix_args {mfix idx args narg fn} : + unfold_fix mfix idx = Some (narg, fn) -> + is_constructor narg args -> + ∑ arg, args = firstn narg args ++ (arg :: skipn (S narg) args) × + narg = #|firstn narg args| × + isConstruct_app arg. +Proof. + intros unf isc. + rewrite /is_constructor in isc. + move: isc. + case: nth_error_spec => [x hnth hlt|hle] => // isc. + exists x. split => //. + now eapply nth_error_firstn_skipn in hnth. + split => //. rewrite List.firstn_length. lia. +Qed. + +(** Even if the weak-head-reduction is carefully crafted to have unique derivations, + we still get the general reduction rules of fixpoints, where the principal argument + might be anywhere in the [args] spine. *) +Lemma wh_red_fix_red {Σ Γ mfix idx args narg fn} : + unfold_fix mfix idx = Some (narg, fn) -> + is_constructor narg args -> + wh_red1 Σ Γ (mkApps (tFix mfix idx) args) (mkApps fn args). +Proof. + intros unf isc. + destruct (unfold_fix_args unf isc) as [arg [hargs [hnth isc']]]. + clear isc. + rewrite hnth in unf. + rewrite hargs. + revert unf isc'. + clear hnth hargs. + generalize (firstn narg args). + induction (skipn (S narg) args) using rev_ind. + - intros. rewrite - !mkApps_nested. constructor; auto. + - intros nargs unf isc. + specialize (IHl _ unf isc). + rewrite (app_assoc _ [arg]) app_assoc. + rewrite - !(mkApps_nested _ _ [x]). + eapply app_red_l. + rewrite -app_assoc. apply IHl. +Qed. + +From Equations.Type Require Import Relation Relation_Properties. + +Definition wh_red Σ Γ := clos_refl_trans (wh_red1 Σ Γ). + +(** Sanity check: if there is a one-step reduction to a product, then there is also a weak-head-reduction + to the product. This is still far from a standardization theorem. *) +Lemma red1_tProd_wh_red {cf : checker_flags} {Σ : global_env_ext} {Γ t na A B} : red1 Σ Γ t (tProd na A B) -> + ∑ A' B', wh_red Σ Γ t (tProd na A' B') × red Σ Γ A' A × red Σ (Γ ,, vass na A) B' B. +Proof. + remember (tProd na A B) as t'. + intros red; revert na A B Heqt'. + induction red using red1_ind_all; intros. + all:try solve [ + eexists _, _; split; [constructor; erewrite <- Heqt'; econstructor; tea| + split; reflexivity] ]. + all:try congruence. + - eexists _, _; split. erewrite <- Heqt'. + constructor. + eapply wh_red_fix_red; tea. split; reflexivity. + - noconf Heqt'. + exists M1, M2. split. reflexivity. + split; try reflexivity. + now eapply red1_red. + - noconf Heqt'. + eexists _, _. split. + reflexivity. + split; try reflexivity. + now apply red1_red. +Qed. + +(** TODO: define a notion of internal reductions, following Takahashi's "Parallel reductions in lambda-calculus". + Internal reductions are exactly the congruence rules of reduction not in the weak-head reduction, e.g. + including reduction on the right of an application, or congruence for beta-redexes. + + This should allow to show that: + 1) head reduction is standardizing (his proof is for "strong" head reduction though, not sure if this + adapts smoothly to weak head reductions). We could also consider a strong form + of head reduction here, which would still produce unique (strong) head normal forms. + As long as we have at least on standardizing reduction allowing to uncover products/inductives etc. + we should be fine + 2) His paper also shows how one can adapt the confluence proof to η-reduction using η-postponment. + The main difference here seems to be that we have type annotations in the domain of lambdas, + but if we adapt eq-term to not compare those it should "just work". + +*) +(** If there is a one-step reduction then it is either a weak head reduction or an internal reduction *) +(* Lemma red1_wh_red1 {cf : checker_flags} {Σ : global_env_ext} {Γ t u} : + red1 Σ Γ u v -> wh_red1 Σ Γ t v + int_red1 Σ Γ t v. *) diff --git a/pcuic/theories/TemplateToPCUIC.v b/pcuic/theories/TemplateToPCUIC.v index a707b82c4..a89efdc29 100644 --- a/pcuic/theories/TemplateToPCUIC.v +++ b/pcuic/theories/TemplateToPCUIC.v @@ -1,7 +1,7 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Int63 FloatOps FloatAxioms. From MetaCoq.Template Require Import config utils AstUtils. -From MetaCoq.PCUIC Require Import PCUICAst. +From MetaCoq.PCUIC Require Import PCUICAst PCUICCases. Lemma to_Z_bounded_bool (i : Int63.int) : ((0 <=? φ (i)%int63) && (φ (i)%int63 tRel n | Ast.tVar n => tVar n @@ -30,9 +45,27 @@ Fixpoint trans (t : Ast.term) : term := | Ast.tProd na A B => tProd na (trans A) (trans B) | Ast.tCast c kind t => tApp (tLambda (mkBindAnn nAnon Relevant) (trans t) (tRel 0)) (trans c) | Ast.tLetIn na b t b' => tLetIn na (trans b) (trans t) (trans b') - | Ast.tCase ind p c brs => - let brs' := List.map (on_snd trans) brs in - tCase (fst ind) (trans p) (trans c) brs' + | Ast.tCase ci p c brs => + let p' := Ast.map_predicate id trans trans p in + let brs' := List.map (Ast.map_branch trans) brs in + match lookup_inductive Σ ci.(ci_ind) with + | 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 + p'.(Ast.pparams) p'.(Ast.puinst) br.(Ast.bcontext) br.(Ast.bbody)) + idecl.(ind_ctors) brs' in + tCase ci tp (trans c) tbrs + | 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. *) + tCase ci {| pparams := p'.(Ast.pparams); + puinst := p'.(Ast.puinst); + pcontext := map (fun na => vass na (tSort Universe.type0)) p'.(Ast.pcontext); + preturn := p'.(Ast.preturn) |} + (trans c) [] + end | Ast.tProj p c => tProj p (trans c) | Ast.tFix mfix idx => let mfix' := List.map (map_def trans trans) mfix in @@ -44,42 +77,52 @@ Fixpoint trans (t : Ast.term) : term := | Ast.tFloat n => tPrim (primFloat; primFloatModel (float64_to_model n)) end. -Definition trans_decl (d : Ast.context_decl) := - let 'Ast.mkdecl na b t := d in - {| decl_name := na; - decl_body := option_map trans b; - decl_type := trans t |}. + Definition trans_decl (d : Ast.Env.context_decl) := + let 'mkdecl na b t := d in + {| decl_name := na; + decl_body := option_map trans b; + decl_type := trans t |}. -Definition trans_local Γ := List.map trans_decl Γ. + Definition trans_local Γ := List.map trans_decl Γ. + + Definition trans_constructor_body (d : Ast.Env.constructor_body) := + {| 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_type := trans d.(Ast.Env.cstr_type); + cstr_arity := d.(Ast.Env.cstr_arity) |}. -Definition trans_one_ind_body (d : Ast.one_inductive_body) := - {| ind_name := d.(Ast.ind_name); - ind_relevance := d.(Ast.ind_relevance); - ind_type := trans d.(Ast.ind_type); - ind_kelim := d.(Ast.ind_kelim); - ind_ctors := List.map (fun '(x, y, z) => (x, trans y, z)) d.(Ast.ind_ctors); - ind_projs := List.map (fun '(x, y) => (x, trans y)) d.(Ast.ind_projs) |}. + Definition trans_one_ind_body (d : Ast.Env.one_inductive_body) := + {| ind_name := d.(Ast.Env.ind_name); + ind_relevance := d.(Ast.Env.ind_relevance); + ind_indices := trans_local d.(Ast.Env.ind_indices); + ind_sort := d.(Ast.Env.ind_sort); + ind_type := trans d.(Ast.Env.ind_type); + ind_kelim := d.(Ast.Env.ind_kelim); + ind_ctors := List.map trans_constructor_body d.(Ast.Env.ind_ctors); + ind_projs := List.map (fun '(x, y) => (x, trans y)) d.(Ast.Env.ind_projs) |}. -Definition trans_constant_body bd := - {| cst_type := trans bd.(Ast.cst_type); cst_body := option_map trans bd.(Ast.cst_body); - cst_universes := bd.(Ast.cst_universes) |}. + Definition trans_constant_body bd := + {| 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) |}. -Definition trans_minductive_body md := - {| ind_finite := md.(Ast.ind_finite); - ind_npars := md.(Ast.ind_npars); - ind_params := trans_local md.(Ast.ind_params); - ind_bodies := map trans_one_ind_body md.(Ast.ind_bodies); - ind_universes := md.(Ast.ind_universes); - ind_variance := md.(Ast.ind_variance) |}. + Definition trans_minductive_body md := + {| ind_finite := md.(Ast.Env.ind_finite); + ind_npars := md.(Ast.Env.ind_npars); + ind_params := trans_local md.(Ast.Env.ind_params); + ind_bodies := map trans_one_ind_body md.(Ast.Env.ind_bodies); + ind_universes := md.(Ast.Env.ind_universes); + ind_variance := md.(Ast.Env.ind_variance) |}. -Definition trans_global_decl (d : Ast.global_decl) := - match d with - | Ast.ConstantDecl bd => ConstantDecl (trans_constant_body bd) - | Ast.InductiveDecl bd => InductiveDecl (trans_minductive_body bd) - end. + Definition trans_global_decl (d : Ast.Env.global_decl) := + match d with + | Ast.Env.ConstantDecl bd => ConstantDecl (trans_constant_body bd) + | Ast.Env.InductiveDecl bd => InductiveDecl (trans_minductive_body bd) + end. +End Trans. -Definition trans_global_decls (d : Ast.global_env) := - List.map (on_snd trans_global_decl) d. +Definition trans_global_decls (d : Ast.Env.global_env) : global_env := + fold_right (fun decl Σ' => on_snd (trans_global_decl Σ') decl :: Σ') [] d. -Definition trans_global (Σ : Ast.global_env_ext) := +Definition trans_global (Σ : Ast.Env.global_env_ext) : global_env_ext := (trans_global_decls (fst Σ), snd Σ). diff --git a/pcuic/theories/TemplateToPCUICCorrectness.v b/pcuic/theories/TemplateToPCUICCorrectness.v index 18b010637..de0b853dc 100644 --- a/pcuic/theories/TemplateToPCUICCorrectness.v +++ b/pcuic/theories/TemplateToPCUICCorrectness.v @@ -1,17 +1,18 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import config utils Ast TypingWf WfInv. -From MetaCoq.Template Require TermEquality. +From Coq Require Import ssreflect. +From MetaCoq.Template Require Import config utils. +From MetaCoq.Template Require Ast TypingWf WfInv TermEquality. Set Warnings "-notation-overridden". From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCumulativity PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICTyping TemplateToPCUIC - PCUICWeakening PCUICSubstitution PCUICGeneration PCUICValidity. + PCUICWeakening PCUICSubstitution PCUICGeneration. Set Warnings "+notation-overridden". From Equations.Prop Require Import DepElim. Implicit Types cf : checker_flags. (* Source = Template, Target (unqualified) = Coq *) -Module S := Template.Ast. + Module SEq := Template.TermEquality. Module ST := Template.Typing. Module SL := Template.LiftSubst. @@ -23,33 +24,63 @@ Proof. intros H. revert u; induction v; simpl; trivial. intros. - now rewrite IHv, H. + now rewrite IHv H. Qed. Ltac solve_list := - rewrite !map_map_compose, ?compose_on_snd, ?compose_map_def; + rewrite !map_map_compose ?compose_on_snd ?compose_map_def; try rewrite !map_length; try solve_all; try typeclasses eauto with core. -Lemma trans_lift n k t : - trans (SL.lift n k t) = lift n k (trans t). +Lemma mkApps_app f l l' : mkApps f (l ++ l') = mkApps (mkApps f l) l'. Proof. - revert k. induction t using Template.Induction.term_forall_list_ind; simpl; intros; try congruence. - - f_equal. rewrite !map_map_compose. solve_all. - - rewrite lift_mkApps, IHt, map_map. - f_equal. rewrite map_map; solve_all. - - - f_equal; auto. solve_list. - - f_equal; auto; solve_list. - - f_equal; auto; solve_list. + revert f l'; induction l; simpl; trivial. Qed. + +Ltac maps := rewrite_strat (topdown (old_hints map)). +Ltac lengths := rewrite_strat (topdown (hints len)). -Lemma mkApps_app f l l' : mkApps f (l ++ l') = mkApps (mkApps f l) l'. +Lemma destArity_mkApps ctx t l : l <> [] -> destArity ctx (mkApps t l) = None. Proof. - revert f l'; induction l; simpl; trivial. + destruct l as [|a l]. congruence. + intros _. simpl. + revert t a; induction l; intros; simpl; try congruence. Qed. -Lemma trans_mkApp u a : trans (S.mkApp u a) = tApp (trans u) (trans a). +Section Translation. + Context (Σ : global_env). + Notation trans := (trans Σ). + Notation trans_local := (trans_local Σ). + + Ltac dest_lookup := + destruct lookup_inductive as [[mdecl idecl]|]. + +Lemma trans_lift n k t : + trans (Template.Ast.lift n k t) = lift n k (trans t). +Proof. + revert k. induction t using Template.Induction.term_forall_list_ind; simpl; intros; try congruence. + - f_equal. rewrite !map_map_compose. solve_all. + - rewrite lift_mkApps IHt map_map. + f_equal. rewrite map_map; solve_all. + + - destruct X; red in X0. + dest_lookup. simpl. + * f_equal; auto. + unfold trans_predicate, map_predicate_k; cbn. + f_equal; auto. solve_list. + todo "case". + todo "case". + todo "case". + * simpl. rewrite /id /map_predicate_k /=. f_equal; eauto. + f_equal; auto. rewrite !map_map_compose. solve_all. + rewrite mapi_context_fold fold_context_k_alt mapi_map /map_decl /= /shiftf. + rewrite map_length /= mapi_cst_map //. + rewrite map_length e. f_equal. + - f_equal; auto. maps. solve_all. + - f_equal; auto; solve_all. +Qed. + +Lemma trans_mkApp u a : trans (Template.Ast.mkApp u a) = tApp (trans u) (trans a). Proof. induction u; simpl; try reflexivity. rewrite map_app. @@ -59,7 +90,7 @@ Proof. Qed. Lemma trans_mkApps u v : - trans (S.mkApps u v) = mkApps (trans u) (List.map trans v). + trans (Template.Ast.mkApps u v) = mkApps (trans u) (List.map trans v). Proof. revert u; induction v. simpl; trivial. @@ -70,7 +101,7 @@ Proof. Qed. Lemma trans_subst t k u : - trans (SL.subst t k u) = subst (map trans t) k (trans 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. @@ -85,95 +116,39 @@ Proof. rewrite trans_mkApps. f_equal. solve_list. - - f_equal; auto; solve_list. + - destruct X; red in X0. + dest_lookup; cbn; f_equal; auto; solve_list. + 1-2:todo "case". + * unfold subst_predicate, id => /=. + f_equal; auto; solve_all. + rewrite mapi_context_fold fold_context_k_alt mapi_map /= /shiftf /map_decl /=. + now rewrite mapi_cst_map. - f_equal; auto; solve_list. - f_equal; auto; solve_list. Qed. Notation Tterm := Template.Ast.term. -Notation Tcontext := Template.Ast.context. +Notation Tcontext := Template.Ast.Env.context. -Lemma trans_subst_instance_constr u t : trans (Template.UnivSubst.subst_instance_constr u t) = - subst_instance_constr u (trans t). +Lemma trans_subst_instance u t : trans (subst_instance u t) = subst_instance u (trans t). Proof. + rewrite /subst_instance /=. induction t using Template.Induction.term_forall_list_ind; simpl; try congruence. { 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. } - 1-3:f_equal; auto; unfold BasicAst.tFixProp, BasicAst.tCaseBrsProp in *; + rewrite !map_map_compose. solve_all. } + 2-3:f_equal; auto; unfold BasicAst.tFixProp, Ast.tCaseBrsProp in *; repeat toAll; solve_list. -Qed. - -Require Import ssreflect. - -Lemma forall_decls_declared_constant Σ cst decl : - ST.declared_constant Σ cst decl -> - declared_constant (trans_global_decls Σ) cst (trans_constant_body decl). -Proof. - unfold declared_constant, ST.declared_constant. - induction Σ => //; try discriminate. - case: a => // /= k b. - unfold eq_kername; destruct kername_eq_dec; subst; auto. - - by move => [=] ->. -Qed. - -Lemma forall_decls_declared_minductive Σ cst decl : - ST.declared_minductive Σ cst decl -> - declared_minductive (trans_global_decls Σ) cst (trans_minductive_body decl). -Proof. - unfold declared_minductive, ST.declared_minductive. - induction Σ => //; try discriminate. - case: a => // /= k b. - unfold eq_kername; destruct kername_eq_dec; subst; auto. - - by move => [=] ->. -Qed. - -Lemma forall_decls_declared_inductive Σ mdecl ind decl : - ST.declared_inductive Σ mdecl ind decl -> - declared_inductive (trans_global_decls Σ) (trans_minductive_body mdecl) ind (trans_one_ind_body decl). -Proof. - unfold declared_inductive, ST.declared_inductive. - move=> [decl' Hnth]. - pose proof (forall_decls_declared_minductive _ _ _ decl'). - eexists. eauto. destruct decl'; simpl in *. - red in H. destruct mdecl; simpl. - by rewrite nth_error_map Hnth. -Qed. - -Lemma forall_decls_declared_constructor Σ cst mdecl idecl decl : - ST.declared_constructor Σ mdecl idecl cst decl -> - declared_constructor (trans_global_decls Σ) (trans_minductive_body mdecl) (trans_one_ind_body idecl) - cst ((fun '(x, y, z) => (x, trans y, z)) decl). -Proof. - unfold declared_constructor, ST.declared_constructor. - move=> [decl' Hnth]. - pose proof (forall_decls_declared_inductive _ _ _ _ decl'). split; auto. - destruct idecl; simpl. - by rewrite nth_error_map Hnth. -Qed. - -Lemma forall_decls_declared_projection Σ cst mdecl idecl decl : - ST.declared_projection Σ mdecl idecl cst decl -> - declared_projection (trans_global_decls Σ) (trans_minductive_body mdecl) (trans_one_ind_body idecl) - cst ((fun '(x, y) => (x, trans y)) decl). -Proof. - unfold declared_constructor, ST.declared_constructor. - move=> [decl' [Hnth Hnpar]]. - pose proof (forall_decls_declared_inductive _ _ _ _ decl'). split; auto. - destruct idecl; simpl. - by rewrite nth_error_map Hnth. -Qed. - -Lemma destArity_mkApps ctx t l : l <> [] -> destArity ctx (mkApps t l) = None. -Proof. - destruct l as [|a l]. congruence. - intros _. simpl. - revert t a; induction l; intros; simpl; try congruence. + destruct X; red in X0. + dest_lookup; cbn; f_equal; auto; solve_list. + 1-2:todo "case". + rewrite /map_predicate /= /id; f_equal; auto; try solve_list. + rewrite /map_context map_map_compose /map_decl //. Qed. Lemma trans_destArity ctx t : - S.wf t -> + Template.Ast.wf t -> match AstUtils.destArity ctx t with | Some (args, s) => destArity (trans_local ctx) (trans t) = @@ -183,10 +158,11 @@ Lemma trans_destArity ctx t : Proof. intros wf; revert ctx. induction wf using Template.Induction.term_wf_forall_list_ind; intros ctx; simpl; trivial. - apply (IHwf0 (S.vass n t :: ctx)). - apply (IHwf1 (S.vdef n t t0 :: ctx)). + apply (IHwf0 (Ast.Env.vass n t :: ctx)). + apply (IHwf1 (Ast.Env.vdef n t t0 :: ctx)). destruct l. congruence. now apply destArity_mkApps. + dest_lookup => //. Qed. (* TODO Duplicate? *) @@ -237,73 +213,17 @@ 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 (ST.inds kn u bodies) = inds kn u (map trans_one_ind_body bodies). +Lemma trans_inds kn u bodies : map trans (ST.inds kn u bodies) = + inds kn u (map (trans_one_ind_body Σ) bodies). Proof. unfold inds, ST.inds. rewrite map_length. induction bodies. simpl. reflexivity. simpl; f_equal. auto. Qed. -Lemma trans_instantiate_params_subst params args s t : - All TypingWf.wf_decl params -> All Ast.wf s -> - All Ast.wf args -> - forall s' t', - ST.instantiate_params_subst params args s t = Some (s', t') -> - instantiate_params_subst (map trans_decl params) - (map trans args) (map trans s) (trans t) = - Some (map trans s', trans t'). -Proof. - induction params in args, t, s |- *. - - destruct args; simpl; rewrite ?Nat.add_0_r; intros Hparams Hs Hargs s' t' [= -> ->]; auto. - - simpl. intros Hparams Hs Hargs s' t'. - destruct a as [na [body|] ty]; simpl; try congruence. - destruct t; simpl; try congruence. - -- intros Ht' . - erewrite <- IHparams. f_equal. 5:eauto. - simpl. rewrite trans_subst; auto. - inv Hparams. red in H. simpl in H. intuition auto. - constructor; auto. - inv Hparams; red in H; simpl in H; intuition auto. - apply Template.LiftSubst.wf_subst; auto. solve_all. - auto. - -- intros Ht'. destruct t; try congruence. - destruct args; try congruence; simpl. - erewrite <- IHparams. 5:eauto. simpl. reflexivity. - now inv Hparams. - constructor; auto. - now inv Hargs. now inv Hargs. -Qed. - -Lemma trans_instantiate_params params args t : - S.wf t -> - All TypingWf.wf_decl params -> - All Ast.wf args -> - forall t', - ST.instantiate_params params args t = Some t' -> - instantiate_params (map trans_decl params) (map trans args) (trans t) = - Some (trans t'). -Proof. - intros wft wfpars wfargs t' eq. - revert eq. - unfold ST.instantiate_params. - case_eq (ST.instantiate_params_subst (List.rev params) args [] t). - all: try discriminate. - intros [ctx u] e eq. inversion eq. subst. clear eq. - assert (wfargs' : Forall Ast.wf args) by (apply All_Forall ; assumption). - assert (wfpars' : Forall wf_decl (List.rev params)). - { apply rev_Forall. apply All_Forall. assumption. } - assert (wfpars'' : All wf_decl (List.rev params)). - { apply Forall_All. assumption. } - apply wf_instantiate_params_subst_ctx in e as wfctx ; trivial. - apply wf_instantiate_params_subst_term in e as wfu ; trivial. - apply trans_instantiate_params_subst in e ; trivial. - cbn in e. unfold instantiate_params. - rewrite map_rev in e. - rewrite e. f_equal. symmetry. - apply trans_subst. -Qed. +Notation trans_decl := (trans_decl Σ). Lemma trans_it_mkProd_or_LetIn ctx t : - trans (Template.Ast.it_mkProd_or_LetIn ctx t) = + trans (Ast.Env.it_mkProd_or_LetIn ctx t) = it_mkProd_or_LetIn (map trans_decl ctx) (trans t). Proof. induction ctx in t |- *; simpl; auto. @@ -312,21 +232,19 @@ Proof. now rewrite IHctx. Qed. -Lemma trans_local_subst_instance_context : - forall u Γ, - trans_local (UnivSubst.subst_instance_context u Γ) = - subst_instance_context u (trans_local Γ). +Lemma trans_local_subst_instance u (Γ : Ast.Env.context) : + trans_local (subst_instance u Γ) = subst_instance u (trans_local Γ). Proof. - intros u Γ. + rewrite /subst_instance /=. induction Γ as [| [na [b|] A] Γ ih ] in u |- *. - reflexivity. - simpl. f_equal. 2: eapply ih. unfold map_decl. simpl. - rewrite 2!trans_subst_instance_constr. + rewrite 2!trans_subst_instance. reflexivity. - simpl. f_equal. 2: eapply ih. unfold map_decl. simpl. - rewrite trans_subst_instance_constr. + rewrite trans_subst_instance. reflexivity. Qed. @@ -346,8 +264,8 @@ Qed. *) (*Lemma trans_decompose_prod_assum : forall Γ t, - let '(Δ, c) := AstUtils.decompose_prod_assum (S.map_context AstUtils.strip_casts Γ) (AstUtils.strip_casts t) in - decompose_prod_assum (trans_local (S.map_context AstUtils.strip_casts Γ)) (trans (AstUtils.strip_casts t)) = + let '(Δ, c) := AstUtils.decompose_prod_assum (Template.Ast.map_context AstUtils.strip_casts Γ) (AstUtils.strip_casts t) in + decompose_prod_assum (trans_local (Template.Ast.map_context AstUtils.strip_casts Γ)) (trans (AstUtils.strip_casts t)) = (trans_local Δ, trans c). Proof. intros Γ t. @@ -372,7 +290,7 @@ Qed. Lemma trans_decompose_prod_assum : forall Γ t, - S.wf t -> + Template.Ast.wf t -> let '(Δ, c) := AstUtils.decompose_prod_assum Γ t in decompose_prod_assum (trans_local Γ) (trans t) = (trans_local Δ, trans c). Proof. @@ -382,11 +300,14 @@ Proof. induction wf using Template.Induction.term_wf_forall_list_ind; intros. all: try solve [ inversion e ; subst ; reflexivity ]. - simpl in e. eapply IHwf0 in e as e'. now simpl. - - simpl. simpl in e. eapply (IHwf1 (Γ ,, Ast.vdef n t t0)) in e as e'. assumption. + - simpl. simpl in e. eapply (IHwf1 (Γ ,, Ast.Env.vdef n t t0)) in e as e'. assumption. - simpl in *. noconf e. simpl. destruct l => //. cbn [map]. rewrite decompose_prod_assum_mkApps_nonnil //. + - simpl. + simpl in e. noconf e. simpl. + dest_lookup => //. Qed. (* Lemma trans_isApp t : Ast.isApp t = false -> PCUICAst.isApp (trans t) = false. @@ -406,12 +327,13 @@ Proof. destruct (AstUtils.decompose_app t). Admitted. *) -Lemma trans_ind_params mdecl : trans_local (Ast.ind_params mdecl) = ind_params (trans_minductive_body mdecl). +Lemma trans_ind_params mdecl : trans_local (Ast.Env.ind_params mdecl) = ind_params (trans_minductive_body Σ mdecl). Proof. reflexivity. Qed. -Lemma trans_ind_bodies mdecl : map trans_one_ind_body (Ast.ind_bodies mdecl) = ind_bodies (trans_minductive_body mdecl). +Lemma trans_ind_bodies mdecl : map (trans_one_ind_body Σ) (Ast.Env.ind_bodies mdecl) = ind_bodies (trans_minductive_body Σ mdecl). Proof. reflexivity. Qed. -From MetaCoq.PCUIC Require Import PCUICClosed PCUICInductiveInversion. + +(* From MetaCoq.PCUIC Require Import PCUICClosed PCUICInductiveInversion. Lemma instantiate_params_spec params paramsi concl ty : instantiate_params params paramsi (it_mkProd_or_LetIn params concl) = Some ty -> @@ -424,345 +346,39 @@ Proof. rewrite decompose_prod_n_assum_it_mkProd app_nil_r in da. noconf da. apply context_subst_subst_extended_subst in dp as ->. rewrite map_subst_expand_lets ?List.rev_length //. -Qed. +Qed. *) -Lemma trans_ind_bodies_length mdecl : #|TemplateEnvironment.ind_bodies mdecl| = #|ind_bodies (trans_minductive_body mdecl)|. +Lemma trans_ind_bodies_length mdecl : #|Ast.Env.ind_bodies mdecl| = #|ind_bodies (trans_minductive_body Σ mdecl)|. Proof. simpl. now rewrite map_length. Qed. -Lemma trans_ind_params_length mdecl : #|TemplateEnvironment.ind_params mdecl| = #|ind_params (trans_minductive_body mdecl)|. +Lemma trans_ind_params_length mdecl : #|Ast.Env.ind_params mdecl| = #|ind_params (trans_minductive_body Σ mdecl)|. Proof. simpl. now rewrite map_length. Qed. -Lemma trans_ind_npars mdecl : Ast.ind_npars mdecl = ind_npars (trans_minductive_body mdecl). +Lemma trans_ind_npars mdecl : Ast.Env.ind_npars mdecl = ind_npars (trans_minductive_body Σ mdecl). Proof. simpl. reflexivity. Qed. -Lemma trans_reln l p Γ : map trans (Ast.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. now rewrite IHΓ. Qed. -Lemma trans_to_extended_list Γ n : map trans (Ast.to_extended_list_k Γ n) = to_extended_list_k (trans_local Γ) n. +Lemma trans_to_extended_list Γ n : map trans (Ast.Env.to_extended_list_k Γ n) = to_extended_list_k (trans_local Γ) n. Proof. now rewrite /to_extended_list_k trans_reln. Qed. -Definition trans_constructor_shape (t : ST.constructor_shape) : constructor_shape := - {| cshape_args := trans_local t.(ST.cshape_args); - cshape_indices := map trans t.(ST.cshape_indices); - cshape_sorts := t.(ST.cshape_sorts) |}. - -Lemma trans_cshape_args cs : trans_local (ST.cshape_args cs) = cshape_args (trans_constructor_shape cs). -Proof. reflexivity. Qed. - -Lemma trans_cshape_args_length cs : #|ST.cshape_args cs| = #|cshape_args (trans_constructor_shape cs)|. -Proof. now rewrite -trans_cshape_args map_length. Qed. - -Lemma context_assumptions_map ctx : context_assumptions (map trans_decl ctx) = Ast.context_assumptions ctx. -Proof. - induction ctx as [|[na [b|] ty] ctx]; simpl; auto. -Qed. - -(* Lemma decompose_prod_assum_mkApps ctx t f l : - decompose_prod_assum ctx t = (ctx', l) -> - it_mkProd_or_LetIn ctx t = it_mkProd_or_LetIn ctx' (mkApps t' -> - () *) -(* -Lemma decompose_app_trans_inv t ind u l : - Ast.wf t -> - decompose_app (trans t) = (tInd ind u, l) -> - ∑ l', l = map trans l' /\ AstUtils.decompose_app t = (Ast.tInd ind u, l'). +Lemma context_assumptions_map ctx : context_assumptions (map trans_decl ctx) = Ast.Env.context_assumptions ctx. Proof. - destruct t => //. simpl. - intros wf. - destruct decompose_app eqn:da. - pose proof (decompose_app_notApp _ _ _ da). - rewrite decompose_app_mkApps in da. depelim wf. destruct t => //. - destruct t0 => //. - intros [= -> -> ->]. - exists args. noconf da. split; auto. f_equal. rewrite -H0 in H. - depelim wf. - destruct t => //. simpl in H2. noconf H2. reflexivity. - intros. simpl in H0. noconf H0. - exists []. split; auto. -Qed. *) -Lemma trans_build_branches_type ind mdecl idecl args u p brtys : - (* (ST.on_inductive (ST.lift_typing ST.typing) Σ (inductive_mind ind) mdecl) -> - (ST.on_ind_body (ST.lift_typing ST.typing) Σ (inductive_mind ind) mdecl (inductive_ind ind) idecl) -> - inductive_ind ind < #|ind_bodies (trans_minductive_body mdecl)| -> *) - map_option_out (ST.build_branches_type ind mdecl idecl args u p) - = Some brtys -> - map_option_out - (build_branches_type ind (trans_minductive_body mdecl) - (trans_one_ind_body idecl) (map trans args) u - (trans p)) - = Some (map (on_snd trans) brtys). -Proof. -Admitted. -(* Will likely change with the change of representation of cases *) -(* - intros onmind onind indlt. - pose proof (ST.onConstructors onind) as onc. - unfold ST.build_branches_type. - unfold build_branches_type. - rewrite mapi_map. - eapply All2_map_option_out_mapi_Some_spec. eapply onc. - intros i [[id ty] argn] [nargs br] s oncs. - simpl. - destruct ST.instantiate_params eqn:ipars => //. - pose proof ipars as ipars'. - apply trans_instantiate_params in ipars. - rewrite trans_subst trans_inds trans_subst_instance_constr in ipars. - rewrite [map _ _]trans_local_subst_instance_context trans_ind_params - trans_ind_bodies in ipars. - - rewrite trans_ind_params trans_ind_bodies. - rewrite ipars. - assert (wft : S.wf t). eapply wf_instantiate_params. 4:eapply ipars'. 1-3:admit. - pose proof (trans_decompose_prod_assum [] t wft). - destruct (AstUtils.decompose_prod_assum [] t) eqn:da'. - rewrite H. - destruct chop eqn:eqchop. - intros [= -> <-]. - destruct (chop _ (decompose_app (trans t0)).2) eqn:c'. - f_equal. f_equal. - rewrite [ty]oncs.(ST.cstr_eq) in ipars. - rewrite trans_it_mkProd_or_LetIn subst_instance_constr_it_mkProd_or_LetIn - subst_it_mkProd_or_LetIn in ipars. len in ipars. - rewrite closed_ctx_subst in ipars. - rewrite [map _ _]trans_ind_params. admit. - apply instantiate_params_spec in ipars. - rewrite trans_it_mkProd_or_LetIn. f_equal. - rewrite trans_mkApps map_length trans_lift. f_equal. - rewrite map_app /= trans_mkApps /= map_app trans_to_extended_list. - assert (l1 = map trans l /\ l2 = map trans l0) as [-> ->]. - { simpl in H. - move: ipars. - rewrite trans_it_mkProd_or_LetIn subst_instance_constr_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. - rewrite /expand_lets expand_lets_it_mkProd_or_LetIn. len. - rewrite subst_it_mkProd_or_LetIn. - rewrite trans_mkApps. - rewrite /ST.cstr_concl_head. cbn -[subst]. - rewrite trans_ind_bodies. len. - rewrite trans_ind_bodies_length trans_ind_params_length. - rewrite map_app trans_to_extended_list trans_ind_params trans_cshape_args_length. - rewrite (subst_cstr_concl_head ind u (trans_minductive_body mdecl)) //. - rewrite expand_lets_k_mkApps subst_mkApps /=. - intros eqit. - rewrite eqit in H. - rewrite decompose_prod_assum_it_mkProd // in H. - apply is_ind_app_head_mkApps. - injection H. clear H. rewrite app_nil_r. - intros eqind _. - apply (f_equal decompose_app) in eqind. - destruct (decompose_app (trans t0)) eqn:dt0. - simpl in *. - rewrite decompose_app_mkApps // in eqind. noconf eqind. - - noconf H. - move: H. - - rewrite !map_app map_map_compose chop_n_app. len. - rewrite context_assumptions_map. now rewrite onmind.(ST.onNpars). - destruct AstUtils.decompose_prod_assum eqn:da'. - rewrite trans_it_mkProd_or_LetIn trans_mkApps. len. - simpl in H. rewrite H. - - - - reflexivity. - - - - - - f_equal. f_equal. rewrite map_app. - rewrite trans_to_extended_list. f_equal. - - - - len. - - - apply instantiate_params_make_context_subst in ipars as [ctx' [ty'' [s' [dass [makes eq]]]]]. - rewrite eq. - eapply make_context_subst_spec in makes. - rewrite List.rev_involutive in makes. - - - - move: (trans_decompose_prod_assum [] t wft). - destruct oncs. simpl in cstr_eq. - rewrite trans_inds in ipars. - rewrite trans_subst_instance_constr in ipars. - intros [= -> <-]. - - destruct AstUtils.decompose_prod_assum eqn:dp => -> /=. - destruct (AstUtils.decompose_app t0) eqn:da'. simpl. - destruct chop as [params argsl] eqn:ceq. - - rewrite (chop_map _ _ _ _ _ ceq). - intros [= ->]. f_equal. unfold on_snd. simpl. f_equal. subst br. - rewrite trans_it_mkProd_or_LetIn trans_mkApps map_app /= trans_mkApps /= map_app. - now rewrite trans_to_extended_list trans_lift map_length. + induction ctx as [|[na [b|] ty] ctx]; simpl; auto; lia. Qed. -*) -Lemma trans_build_case_predicate_type ind mdecl idecl params u ps : - build_case_predicate_type ind (trans_minductive_body mdecl) - (trans_one_ind_body idecl) (map trans params) u ps - = option_map trans (ST.build_case_predicate_type ind mdecl idecl params u ps). -Admitted. - -(* Lemma trans_types_of_case (Σ : S.global_env) ind mdecl idecl args p u pty indctx pctx ps btys : *) -(* S.wf p -> S.wf pty -> S.wf (S.ind_type idecl) -> *) -(* All S.wf args -> *) -(* ST.wf Σ -> *) -(* ST.declared_inductive Σ mdecl ind idecl -> *) -(* ST.types_of_case ind mdecl idecl args u p pty = Some (indctx, pctx, ps, btys) -> *) -(* types_of_case ind (trans_minductive_body mdecl) (trans_one_ind_body idecl) *) -(* (map trans args) u (trans p) (trans pty) = *) -(* Some (trans_local indctx, trans_local pctx, ps, map (on_snd trans) btys). *) -(* Proof. *) -(* intros wfp wfpty wfdecl wfargs wfΣ Hidecl. *) -(* pose proof (on_declared_inductive wfΣ Hidecl) as [onmind onind]. *) -(* apply ST.onParams in onmind as Hparams. *) -(* (* Maybe have a lemma for this we do it all the time *) *) -(* assert (wc : Forall wf_decl (UnivSubst.subst_instance_context u (S.ind_params mdecl))). *) -(* { assert (h : Forall wf_decl (S.ind_params mdecl)). *) -(* { eapply typing_all_wf_decl ; revgoals. *) -(* - apply ST.onParams in onmind. *) -(* unfold ST.on_context in onmind. *) -(* eassumption. *) -(* - simpl. assumption. *) -(* } *) -(* clear - h. induction h. 1: constructor. *) -(* simpl. constructor. 2: assumption. *) -(* destruct x as [na [bo|] ty]. *) -(* all: unfold map_decl. all: unfold wf_decl in *. all: simpl in *. *) -(* all: intuition eauto with wf. *) -(* } *) -(* assert (closedparams : Closed.closed_ctx (Ast.ind_params mdecl)). *) -(* { eapply closed_wf_local ; eauto. eauto. } *) -(* assert (wfparams : All wf_decl (Ast.ind_params mdecl)). *) -(* { apply Forall_All. eapply typing_all_wf_decl ; eauto. simpl. eauto. } *) -(* unfold ST.types_of_case, types_of_case. simpl. *) -(* match goal with *) -(* | |- context [ ST.instantiate_params ?p ?a ?t ] => *) -(* pose proof (trans_instantiate_params p a t) as ht ; *) -(* case_eq (ST.instantiate_params p a t) *) -(* end. *) -(* 2: discriminate. *) -(* intros ity e. *) -(* rewrite e in ht. specialize ht with (4 := eq_refl). *) -(* change (map trans_decl) with trans_local in ht. *) -(* rewrite trans_subst_instance_constr in ht. *) -(* rewrite trans_local_subst_instance_context in ht. *) -(* rewrite ht. *) -(* all: auto using Forall_All with wf. *) -(* apply wf_instantiate_params in e as wfity. *) -(* all: auto with wf. *) -(* pose proof (trans_destArity [] ity wfity) as e'. *) -(* destruct ST.destArity as [[ctx s] | ]. 2: discriminate. *) -(* rewrite e'. *) -(* pose proof (trans_destArity [] pty wfpty) as e''. *) -(* destruct ST.destArity as [[ctx' s'] | ]. 2: discriminate. *) -(* simpl in e''. rewrite e''. *) -(* pose proof (ST.onConstructors onind) as onc. *) -(* assert ( *) -(* hb : *) -(* forall brtys, *) -(* map_option_out (ST.build_branches_type ind mdecl idecl args u p) *) -(* = Some brtys -> *) -(* map_option_out *) -(* (build_branches_type ind (trans_minductive_body mdecl) *) -(* (trans_one_ind_body idecl) (map trans args) u *) -(* (trans p)) *) -(* = Some (map (on_snd trans) brtys) *) -(* ). *) -(* { intro brtys. *) -(* unfold ST.build_branches_type, build_branches_type. *) -(* unfold trans_one_ind_body. simpl. rewrite -> mapi_map. *) -(* unfold ST.on_constructors in onc. *) -(* eapply All2_map_option_out_mapi_Some_spec. *) -(* - eapply onc. *) -(* - intros i [[id t] n] [t0 ar] z. *) -(* unfold on_snd. simpl. *) -(* intros [ont [cs ?]]. simpl in *. *) -(* unfold ST.on_type in ont. simpl in ont. *) -(* destruct ont. *) -(* unfold ST.instantiate_params, instantiate_params. *) -(* destruct ST.instantiate_params_subst eqn:he. 2: discriminate. *) -(* destruct p0 as [s0 ty]. *) -(* apply instantiate_params_subst_make_context_subst in he as he'. *) -(* destruct he' as [ctx'' hctx'']. *) -(* eapply trans_instantiate_params_subst in he. *) -(* 2: eapply All_rev. *) -(* all: auto using Forall_All with wf. *) -(* simpl in he. *) -(* rewrite map_rev in he. *) -(* rewrite trans_subst in he. *) -(* + auto using Forall_All with wf. *) -(* + apply wf_subst_instance_constr. *) -(* now eapply typing_wf in t2. *) -(* + rewrite trans_subst_instance_constr trans_inds in he. *) -(* change (map trans_decl) with trans_local in he. *) -(* rewrite trans_local_subst_instance_context in he. *) -(* rewrite he. *) - -(* rewrite List.rev_length map_length in hctx''. *) - -(* (* apply PCUICSubstitution.instantiate_params_subst_make_context_subst *) -(* in he as [ctx''' [hs0 hdecomp]]. *) -(* rewrite List.rev_length map_length in hdecomp. *) -(* unfold trans_local in hdecomp. *) -(* rewrite map_length in hdecomp. *) *) -(* (* rewrite !Template.UnivSubst.subst_instance_constr_it_mkProd_or_LetIn *) -(* in hdecomp. *) *) - - -(* (* apply PCUICSubstitution.instantiate_params_subst_make_context_subst in Heq. *) *) -(* (* destruct Heq as [ctx''' [Hs0 Hdecomp]]. *) *) -(* (* rewrite List.rev_length map_length in Hdecomp. *) *) -(* (* rewrite <- trans_subst_instance_constr in Hdecomp. *) *) -(* (* rewrite !Template.UnivSubst.subst_instance_constr_it_mkProd_or_LetIn in Hdecomp. *) *) -(* (* rewrite !trans_it_mkProd_or_LetIn in Hdecomp. *) *) -(* (* assert (#|Template.Ast.ind_params mdecl| = *) *) -(* (* #|PCUICTyping.subst_context *) *) -(* (* (inds (inductive_mind ind) u (map trans_one_ind_body (Template.Ast.ind_bodies mdecl))) 0 *) *) -(* (* (map trans_decl (Template.UnivSubst.subst_instance_context u (Template.Ast.ind_params mdecl)))|). *) *) -(* (* now rewrite PCUICSubstitution.subst_context_length map_length Template.UnivSubst.subst_instance_context_length. *) *) -(* (* rewrite H1 in Hdecomp. *) *) -(* (* rewrite PCUICSubstitution.subst_it_mkProd_or_LetIn in Hdecomp. *) *) -(* (* rewrite decompose_prod_n_assum_it_mkProd in Hdecomp. *) *) -(* (* injection Hdecomp. intros <- <-. clear Hdecomp. *) *) - -(* (* subst cshape_concl_head. destruct Hctx''. *) *) - -(* (* admit. admit. admit. admit. congruence. *) *) -(* (* revert H1. destruct map_option_out. intros. *) *) -(* (* specialize (H1 _ eq_refl). rewrite H1. *) *) -(* (* congruence. *) *) -(* (* intros. discriminate. *) *) - -(* admit. *) -(* } *) -(* match goal with *) -(* | |- context [ map_option_out ?t ] => *) -(* destruct (map_option_out t) eqn: e1 *) -(* end. 2: discriminate. *) -(* specialize hb with (1 := eq_refl). *) -(* rewrite hb. *) -(* intro h. apply some_inj in h. *) -(* inversion h. subst. *) -(* reflexivity. *) -(* Admitted. *) - -Hint Constructors S.wf : wf. +Hint Constructors Template.Ast.wf : wf. Hint Resolve Template.TypingWf.typing_wf : wf. -Lemma mkApps_trans_wf U l : S.wf (S.tApp U l) -> exists U' V', trans (S.tApp U l) = tApp U' V'. +Lemma mkApps_trans_wf U l : Template.Ast.wf (Template.Ast.tApp U l) -> exists U' V', trans (Template.Ast.tApp U l) = tApp U' V'. Proof. simpl. induction l using rev_ind. intros. inv H. congruence. intros. rewrite map_app. simpl. exists (mkApps (trans U) (map trans l)), (trans x). @@ -773,7 +389,7 @@ Qed. Derive Signature for SEq.eq_term_upto_univ_napp. -Lemma leq_term_mkApps {cf} Σ ϕ t u t' u' : +Lemma leq_term_mkApps {cf} ϕ t u t' u' : eq_term Σ ϕ t t' -> All2 (eq_term Σ ϕ) u u' -> leq_term Σ ϕ (mkApps t u) (mkApps t' u'). Proof. @@ -788,21 +404,21 @@ Proof. now apply eq_term_eq_term_napp. Qed. -Lemma eq_term_upto_univ_App `{checker_flags} Σ Re Rle f f' napp : +Lemma eq_term_upto_univ_App `{checker_flags} Re Rle f f' napp : eq_term_upto_univ_napp Σ Re Rle napp f f' -> isApp f = isApp f'. Proof. inversion 1; reflexivity. Qed. -Lemma eq_term_upto_univ_mkApps `{checker_flags} Σ Re Rle f l f' l' : +Lemma eq_term_upto_univ_mkApps `{checker_flags} Re Rle f l f' l' : eq_term_upto_univ_napp Σ Re Rle #|l| f f' -> All2 (eq_term_upto_univ Σ Re Re) l l' -> eq_term_upto_univ Σ Re Rle (mkApps f l) (mkApps f' l'). Proof. induction l in f, f', l' |- *; intro e; inversion_clear 1. - assumption. - - pose proof (eq_term_upto_univ_App _ _ _ _ _ _ e). + - pose proof (eq_term_upto_univ_App _ _ _ _ _ e). case_eq (isApp f). + intro X; rewrite X in H0. destruct f; try discriminate. @@ -816,8 +432,75 @@ Proof. * assumption. Qed. +End Translation. +(* + +Section Trans_Global. + Context (Σ : Ast.Env.global_env). + Notation Σ' := (trans_global_decls Σ). + + Lemma forall_decls_declared_constant cst decl : + ST.declared_constant Σ cst decl -> + declared_constant (trans_global_decls Σ) cst (trans_constant_body Σ' decl). + Proof. + unfold declared_constant, ST.declared_constant. + induction Σ => //; try discriminate. + case: a => // /= k b. + unfold eq_kername; destruct kername_eq_dec; subst; auto. + - move => [=] ->. simpl. f_equal. f_equal. + + Qed. + + Lemma forall_decls_declared_minductive cst decl : + ST.declared_minductive Σ cst decl -> + declared_minductive (trans_global_decls Σ) cst (trans_minductive_body decl). + Proof. + unfold declared_minductive, ST.declared_minductive. + induction Σ => //; try discriminate. + case: a => // /= k b. + unfold eq_kername; destruct kername_eq_dec; subst; auto. + - by move => [=] ->. + Qed. + + Lemma forall_decls_declared_inductive Σ ind mdecl decl : + ST.declared_inductive Σ ind mdecl decl -> + declared_inductive (trans_global_decls Σ) (trans_minductive_body mdecl) (trans_one_ind_body ind decl). + Proof. + unfold declared_inductive, ST.declared_inductive. + move=> [decl' Hnth]. + pose proof (forall_decls_declared_minductive _ _ _ decl'). + eexists. eauto. destruct decl'; simpl in *. + red in H. destruct mdecl; simpl. + by rewrite nth_error_map Hnth. + Qed. + + Lemma forall_decls_declared_constructor Σ cst mdecl idecl decl : + ST.declared_constructor Σ cst mdecl idecl decl -> + declared_constructor (trans_global_decls Σ) cst (trans_minductive_body mdecl) (trans_one_ind_body idecl) + (fun '(x, y, z) => (x, trans y, z)) decl). + Proof. + unfold declared_constructor, ST.declared_constructor. + move=> [decl' Hnth]. + pose proof (forall_decls_declared_inductive _ _ _ _ decl'). split; auto. + destruct idecl; simpl. + by rewrite nth_error_map Hnth. + Qed. + + Lemma forall_decls_declared_projection Σ cst mdecl idecl decl : + ST.declared_projection Σ cst mdecl idecl decl -> + declared_projection (trans_global_decls Σ) cst (trans_minductive_body mdecl) (trans_one_ind_body idecl) + ((fun '(x, y) => (x, trans y)) decl). + Proof. + unfold declared_constructor, ST.declared_constructor. + move=> [decl' [Hnth Hnpar]]. + pose proof (forall_decls_declared_inductive _ _ _ _ decl'). split; auto. + destruct idecl; simpl. + by rewrite nth_error_map Hnth. + Qed. +End Trans_Global. + Lemma trans_lookup Σ cst : - lookup_env (trans_global_decls Σ) cst = option_map trans_global_decl (Ast.lookup_env Σ cst). + lookup_env (trans_global_decls Σ) cst = option_map (trans_global_decl Σ) (Ast.Env.lookup_env Σ cst). Proof. cbn in *. induction Σ. @@ -844,7 +527,7 @@ Proof. -- eapply Alli_impl. exact onI. eauto. intros. refine {| ST.ind_indices := X1.(ST.ind_indices); ST.ind_arity_eq := X1.(ST.ind_arity_eq); - ST.ind_cshapes := X1.(ST.ind_cshapes) |}. + ST.ind_cunivs := X1.(ST.ind_cunivs) |}. --- apply ST.onArity in X1. unfold on_type in *; simpl in *. now eapply X. --- pose proof X1.(ST.onConstructors) as X11. red in X11. @@ -852,14 +535,14 @@ Proof. simpl. intros. destruct X2 as [? ? ? ?]; unshelve econstructor; eauto. * apply X; eauto. * clear -X0 X on_cargs. revert on_cargs. - generalize (ST.cshape_args y), (ST.cshape_sorts y). + generalize (ST.cstr_args y), (ST.cdecl_sorts y). induction c; destruct l; simpl; auto; destruct a as [na [b|] ty]; simpl in *; auto; split; intuition eauto. * clear -X0 X on_cindices. revert on_cindices. - generalize (List.rev (SL.lift_context #|ST.cshape_args y| 0 (ST.ind_indices X1))). - generalize (ST.cshape_indices y). + generalize (List.rev (SL.lift_context #|ST.cstr_args y| 0 (ST.ind_indices X1))). + generalize (ST.cstr_indices y). induction 1; simpl; constructor; auto. --- simpl; intros. pose (ST.onProjections X1 H0). simpl in *; auto. --- destruct X1. simpl. unfold ST.check_ind_sorts in *. @@ -882,9 +565,9 @@ Lemma typing_wf_wf {cf}: Proof. intros Σ. eapply on_global_env_impl. clear. - intros Σ Γ t S. + intros Σ Γ t Template.Ast. red. unfold ST.lift_typing. - intros ong. destruct S. + intros ong. destruct Template.Ast. * intros ty. now eapply typing_wf. * intros [s ty]. exists s. now eapply typing_wf in ty. @@ -921,15 +604,13 @@ Proof. destruct Nat.leb => //. Qed. -Ltac tc := typeclasses eauto. - (* TODO update Template Coq's eq_term to reflect PCUIC's cumulativity *) Lemma trans_eq_term_upto_univ {cf} : forall Σ Re Rle t u napp, RelationClasses.subrelation Re Rle -> ST.wf Σ -> - S.wf t -> - S.wf u -> + Template.Ast.wf t -> + Template.Ast.wf u -> SEq.eq_term_upto_univ_napp Σ Re Rle napp t u -> eq_term_upto_univ_napp (trans_global_decls Σ) Re Rle napp (trans t) (trans u). Proof. @@ -938,7 +619,7 @@ Proof. all: invs e; cbn. all: try solve [ constructor ; auto ]. all: repeat (match goal with - | H : S.wf (_ _) |- _ => apply wf_inv in H; simpl in H + | H : Template.Ast.wf (_ _) |- _ => apply wf_inv in H; simpl in H | H : _ /\ _ |- _ => destruct H end). all: try solve [ @@ -983,8 +664,8 @@ Proof. now eapply ih end ]. - assert (wl : All (S.wf ∘ snd) l) by solve_all. - assert (wbrs' : All (S.wf ∘ snd) brs') by solve_all. + assert (wl : All (Template.Ast.wf ∘ snd) l) by solve_all. + assert (wbrs' : All (Template.Ast.wf ∘ snd) brs') by solve_all. pose proof (All2_All_mix_left X X2) as h1. simpl in h1. pose proof (All2_All_mix_left wl h1) as h2. pose proof (All2_All_mix_right wbrs' h2) as h3. @@ -998,16 +679,16 @@ Proof. assert ( w1 : All (fun def => - S.wf (dtype def) /\ - S.wf (dbody def) + Template.Ast.wf (dtype def) /\ + Template.Ast.wf (dbody def) ) m ). { solve_all. } assert ( w2 : All (fun def => - S.wf (dtype def) /\ - S.wf (dbody def)) mfix' + Template.Ast.wf (dtype def) /\ + Template.Ast.wf (dbody def)) mfix' ). { solve_all. } pose proof (All2_All_mix_left X X0) as h1. simpl in h1. @@ -1023,12 +704,12 @@ Proof. - constructor. assert ( w1 : - All (fun def => S.wf (dtype def) /\ S.wf (dbody def)) m + All (fun def => Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def)) m ). { by eapply Forall_All. } assert ( w2 : - All (fun def => S.wf (dtype def) /\ S.wf (dbody def)) mfix' + All (fun def => Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def)) mfix' ). { by eapply Forall_All. } pose proof (All2_All_mix_left X X0) as h1. simpl in h1. @@ -1045,7 +726,7 @@ Qed. Lemma trans_leq_term {cf} Σ ϕ T U : ST.wf Σ -> - S.wf T -> S.wf U -> SEq.leq_term Σ ϕ T U -> + Template.Ast.wf T -> Template.Ast.wf U -> SEq.leq_term Σ ϕ T U -> leq_term (trans_global_decls Σ) ϕ (trans T) (trans U). Proof. intros HT HU H. @@ -1054,7 +735,7 @@ Qed. Lemma trans_eq_term {cf} Σ φ t u : ST.wf Σ -> - S.wf t -> S.wf u -> SEq.eq_term Σ φ t u -> + Template.Ast.wf t -> Template.Ast.wf u -> SEq.eq_term Σ φ t u -> eq_term (trans_global_decls Σ) φ (trans t) (trans u). Proof. intros HT HU H. @@ -1064,8 +745,8 @@ Qed. Lemma trans_eq_term_list {cf}: forall Σ φ l l', ST.wf Σ -> - List.Forall S.wf l -> - List.Forall S.wf l' -> + List.Forall Template.Ast.wf l -> + List.Forall Template.Ast.wf l' -> All2 (SEq.eq_term Σ φ) l l' -> All2 (eq_term (trans_global_decls Σ) φ) (List.map trans l) (List.map trans l'). Proof. @@ -1079,12 +760,12 @@ Proof. intuition auto using trans_eq_term. Qed. -(* Lemma wf_mkApps t u : S.wf (S.mkApps t u) -> List.Forall S.wf u. *) +(* Lemma wf_mkApps t u : Template.Ast.wf (Template.Ast.mkApps t u) -> List.Forall Template.Ast.wf u. *) (* Proof. *) (* induction u in t |- *; simpl. *) (* - intuition. *) (* - intros H; destruct t; try solve [inv H; intuition auto]. *) -(* specialize (IHu (S.tApp t (l ++ [a]))). *) +(* specialize (IHu (Template.Ast.tApp t (l ++ [a]))). *) (* forward IHu. *) (* induction u; trivial. *) (* simpl. rewrite <- app_assoc. simpl. apply H. *) @@ -1110,7 +791,7 @@ Proof. Qed. Lemma trans_isLambda t : - S.wf t -> isLambda (trans t) = Ast.isLambda t. + Template.Ast.wf t -> isLambda (trans t) = Ast.isLambda t. Proof. destruct 1; cbnr. destruct u; [contradiction|]. cbn. @@ -1119,7 +800,7 @@ Proof. Qed. Lemma trans_unfold_fix mfix idx narg fn : - List.Forall (fun def : def Tterm => S.wf (dtype def) /\ S.wf (dbody def)) mfix -> + List.Forall (fun def : def Tterm => Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def)) mfix -> ST.unfold_fix mfix idx = Some (narg, fn) -> unfold_fix (map (map_def trans trans) mfix) idx = Some (narg, trans fn). Proof. @@ -1138,7 +819,7 @@ Proof. Qed. Lemma trans_unfold_cofix mfix idx narg fn : - List.Forall (fun def : def Tterm => S.wf (dtype def) /\ S.wf (dbody def)) mfix -> + List.Forall (fun def : def Tterm => Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def)) mfix -> ST.unfold_cofix mfix idx = Some (narg, fn) -> unfold_cofix (map (map_def trans trans) mfix) idx = Some (narg, trans fn). Proof. @@ -1195,7 +876,7 @@ Hint Resolve wf_wf_decl_pred : wf. Lemma trans_red1 {cf} Σ Γ T U : ST.wf Σ -> List.Forall wf_decl Γ -> - S.wf T -> + Template.Ast.wf T -> ST.red1 Σ Γ T U -> red1 (map (on_snd trans_global_decl) Σ) (trans_local Γ) (trans T) (trans U). Proof. @@ -1236,7 +917,7 @@ Proof. eapply red_cofix_proj; eauto. apply trans_unfold_cofix; eauto with wf. - - rewrite trans_subst_instance_constr. econstructor. + - rewrite trans_subst_instance. econstructor. apply (forall_decls_declared_constant _ c decl H). destruct decl. now simpl in *; subst cst_body. @@ -1261,7 +942,7 @@ Proof. apply red1_mkApps_l. apply app_red_r. auto. inv H2. specialize (IHX X0). simpl. intros. - eapply (IHX (S.tApp M1 [hd])). + eapply (IHX (Template.Ast.tApp M1 [hd])). - constructor. apply IHX. constructor; hnf; simpl; auto. auto. - constructor. induction X; simpl; repeat constructor. apply p; auto. now inv Hwf. @@ -1373,7 +1054,7 @@ Qed. Lemma trans_cumul {cf} (Σ : Ast.global_env_ext) Γ T U : ST.wf Σ -> List.Forall wf_decl Γ -> - S.wf T -> S.wf U -> ST.cumul Σ Γ T U -> + Template.Ast.wf T -> Template.Ast.wf U -> ST.cumul Σ Γ T U -> trans_global Σ ;;; trans_local Γ |- trans T <= trans U. Proof. intros wfΣ. @@ -1392,7 +1073,7 @@ Definition Tlift_typing (P : Template.Ast.global_env_ext -> Tcontext -> Tterm -> fun Σ Γ t T => match T with | Some T => P Σ Γ t T - | None => { s : Universe.t & P Σ Γ t (S.tSort s) } + | None => { s : Universe.t & P Σ Γ t (Template.Ast.tSort s) } end. Definition TTy_wf_local {cf : checker_flags} Σ Γ := ST.All_local_env (ST.lift_typing ST.typing Σ) Γ. @@ -1453,7 +1134,7 @@ Axiom cofix_guard_trans : ST.cofix_guard Σ Γ mfix -> cofix_guard (trans_global Σ) (trans_local Γ) (map (map_def trans trans) mfix). -Notation Swf_fix def := (S.wf (dtype def) /\ S.wf (dbody def)). +Notation Swf_fix def := (Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def)). Lemma trans_subst_context s k Γ : trans_local (SL.subst_context s k Γ) = subst_context (map trans s) k (trans_local Γ). @@ -1477,7 +1158,7 @@ Proof. Qed. Lemma trans_decompose_app {t ind u l} : - S.wf t -> + Template.Ast.wf t -> AstUtils.decompose_app t = (Ast.tInd ind u, l) -> ∑ l', decompose_app (trans t) = (tInd ind u, l'). Proof. @@ -1557,7 +1238,7 @@ Proof. Qed. Lemma map_option_out_check_one_fix {mfix} : - Forall (fun def => (S.wf (dtype def) /\ S.wf (dbody def))) mfix -> + Forall (fun def => (Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def))) mfix -> 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. @@ -1584,7 +1265,7 @@ Proof. Qed. Lemma map_option_out_check_one_cofix {mfix} : - Forall (fun def => (S.wf (dtype def) /\ S.wf (dbody def))) mfix -> + Forall (fun def => (Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def))) mfix -> 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. @@ -1598,11 +1279,11 @@ Lemma trans_check_rec_kind {Σ k f} : Proof. unfold ST.check_recursivity_kind, check_recursivity_kind. rewrite trans_lookup. - destruct S.lookup_env as [[]|] => //. + destruct Template.Ast.lookup_env as [[]|] => //. Qed. Lemma trans_wf_fixpoint Σ mfix : - Forall (fun def => (S.wf (dtype def) /\ S.wf (dbody def))) mfix -> + Forall (fun def => (Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def))) mfix -> ST.wf_fixpoint Σ mfix -> wf_fixpoint (trans_global_decls Σ) (map (map_def trans trans) mfix). Proof. @@ -1615,7 +1296,7 @@ Proof. Qed. Lemma trans_wf_cofixpoint Σ mfix : - Forall (fun def => (S.wf (dtype def) /\ S.wf (dbody def))) mfix -> + Forall (fun def => (Template.Ast.wf (dtype def) /\ Template.Ast.wf (dbody def))) mfix -> ST.wf_cofixpoint Σ mfix -> wf_cofixpoint (trans_global_decls Σ) (map (map_def trans trans) mfix). Proof. @@ -1641,20 +1322,22 @@ Proof. unfold ST.consistent_instance_ext, consistent_instance_ext. rewrite global_ext_levels_trans global_ext_constraints_trans trans_global_decl_universes. trivial. -Qed. +Qed.*) Theorem template_to_pcuic {cf} : ST.env_prop (fun Σ Γ t T => - wf (trans_global Σ).1 -> - typing (trans_global Σ) (trans_local Γ) (trans t) (trans T)). -Proof. - apply (ST.typing_ind_env (fun Σ Γ t T => - wf (trans_global Σ).1 -> - typing (trans_global Σ) (trans_local Γ) (trans t) (trans T) - )%type). + let Σ' := trans_global Σ in + wf Σ' -> + typing Σ' (trans_local Σ' Γ) (trans Σ' t) (trans Σ' T)) + (fun Σ Γ _ => + let Σ' := trans_global Σ in + wf_local Σ' (trans_local Σ' Γ)). +Proof. + apply ST.typing_ind_env. all: simpl. all: intros. all: auto. +(* all: try solve [ econstructor; eauto with trans ]. - rewrite trans_lift. @@ -1691,10 +1374,10 @@ Proof. * econstructor; eauto. reflexivity. * simpl in p. destruct (TypingWf.typing_wf _ wfΣ _ _ _ typrod) as [wfAB _]. - intros wfS. + intros wfTemplate.Ast. econstructor; eauto. + exists s; eauto. eapply p; eauto. - + change (tProd na (trans A) (trans B)) with (trans (S.tProd na A B)). + + change (tProd na (trans A) (trans B)) with (trans (Template.Ast.tProd na A B)). apply trans_cumul; auto with trans. eapply Forall_impl. eapply TypingWf.typing_all_wf_decl; eauto. intros. auto. @@ -1711,27 +1394,27 @@ Proof. apply X2. * apply X2. - - rewrite trans_subst_instance_constr. + - rewrite trans_subst_instance. pose proof (forall_decls_declared_constant _ _ _ H). replace (trans (Template.Ast.cst_type decl)) with (cst_type (trans_constant_body decl)) by (destruct decl; reflexivity). constructor; eauto with trans. - now apply (trans_consistent_instance_ext _ (S.ConstantDecl decl)). + now apply (trans_consistent_instance_ext _ (Template.Ast.ConstantDecl decl)). - - rewrite trans_subst_instance_constr. + - rewrite trans_subst_instance. pose proof (forall_decls_declared_inductive _ _ _ _ isdecl). replace (trans (Template.Ast.ind_type idecl)) with (ind_type (trans_one_ind_body idecl)) by (destruct idecl; reflexivity). eapply type_Ind; eauto. eauto with trans. - now apply (trans_consistent_instance_ext _ (S.InductiveDecl mdecl)). + now apply (trans_consistent_instance_ext _ (Template.Ast.InductiveDecl mdecl)). - pose proof (forall_decls_declared_constructor _ _ _ _ _ isdecl). unfold ST.type_of_constructor in *. rewrite trans_subst. - rewrite trans_subst_instance_constr. + rewrite trans_subst_instance. rewrite trans_inds. simpl. eapply refine_type. econstructor; eauto with trans. - now apply (trans_consistent_instance_ext _ (S.InductiveDecl mdecl)). + now apply (trans_consistent_instance_ext _ (Template.Ast.InductiveDecl mdecl)). unfold type_of_constructor. simpl. f_equal. f_equal. destruct cdecl as [[id t] p]; simpl; auto. @@ -1758,7 +1441,7 @@ Proof. destruct (typing_wf _ wfΣ _ _ _ X1) as [wfc wfind]. eapply wf_mkApps_inv in wfind; auto. rewrite trans_subst; auto with wf. - simpl. rewrite map_rev. rewrite trans_subst_instance_constr. + simpl. rewrite map_rev. rewrite trans_subst_instance. eapply (type_Proj _ _ _ _ _ _ _ (arity, trans ty)). eauto. rewrite trans_mkApps in X2; auto. rewrite map_length. destruct mdecl; auto. @@ -1813,13 +1496,14 @@ Proof. now eapply TypingWf.typing_wf in a0. -- destruct decl; reflexivity. - - assert (S.wf B). + - assert (Template.Ast.wf B). { now apply typing_wf in X2. } eapply type_Cumul; eauto. eapply trans_cumul; eauto with trans. clear X. apply typing_all_wf_decl in wfΓ; auto. eapply typing_wf in X0; eauto. destruct X0. auto. -Qed. + *) +Admitted. Lemma Alli_map {A B} (P : nat -> B -> Type) n (f : A -> B) l : Alli (fun n x => P n (f x)) n l -> @@ -1828,7 +1512,7 @@ Proof. induction 1; constructor; auto. Qed. -Lemma trans_arities_context m : trans_local (Ast.arities_context (Ast.ind_bodies m)) = +(*Lemma trans_arities_context m : trans_local (Ast.arities_context (Ast.ind_bodies m)) = arities_context (map trans_one_ind_body (Ast.ind_bodies m)). Proof. rewrite /trans_local /Ast.arities_context rev_map_spec map_rev map_map_compose @@ -1838,7 +1522,7 @@ Qed. Lemma trans_lift_context n k Γ : lift_context n k (trans_local Γ) = trans_local (LiftSubst.lift_context n k Γ). Proof. - rewrite /lift_context /LiftSubst.lift_context /fold_context /Ast.fold_context. + rewrite /lift_context /LiftSubst.lift_context /fold_context_k /Ast.fold_context_k. rewrite /trans_local map_rev map_mapi -List.map_rev mapi_map. f_equal. apply mapi_ext. intros ? [na [b|] ty]; simpl; rewrite /trans_decl /= /map_decl; simpl; f_equal; now rewrite trans_lift. @@ -1890,7 +1574,7 @@ Proof. -- eapply Alli_map. eapply Alli_impl. exact onI. eauto. intros. unshelve refine {| ind_indices := trans_local X1.(ST.ind_indices); ind_sort := X1.(ST.ind_sort); - ind_cshapes := map trans_constructor_shape X1.(ST.ind_cshapes) |}. + ind_cunivs := map trans_constructor_shape X1.(ST.ind_cunivs) |}. --- simpl; rewrite X1.(ST.ind_arity_eq). now rewrite !trans_it_mkProd_or_LetIn. --- apply ST.onArity in X1. unfold on_type in *; simpl in *. @@ -1901,7 +1585,7 @@ Proof. simpl. intros [[? ?] ?] cs onc. destruct onc; unshelve econstructor; eauto. + simpl. unfold trans_local. rewrite context_assumptions_map. now rewrite cstr_args_length. - + simpl; unfold cdecl_type, ST.cdecl_type in cstr_eq |- *; simpl in *. + + simpl; unfold cstr_type, ST.cstr_type in cstr_eq |- *; simpl in *. rewrite cstr_eq. rewrite !trans_it_mkProd_or_LetIn. autorewrite with len. f_equal. f_equal. rewrite !trans_mkApps //. @@ -1909,14 +1593,14 @@ Proof. now rewrite /trans_local !map_length. rewrite map_app /=. f_equal. rewrite /trans_local !map_length. - unfold TemplateEnvironment.to_extended_list_k. + unfold Env.to_extended_list_k. now rewrite trans_reln. - + unfold cdecl_type, ST.cdecl_type in on_ctype |- *; simpl in *. + + unfold cstr_type, ST.cstr_type in on_ctype |- *; simpl in *. red. move: (X (Σ, Ast.ind_universes m) (Ast.arities_context (Ast.ind_bodies m)) t None). now rewrite trans_arities_context. + clear -X0 IHX0 X on_cargs. revert on_cargs. simpl. - generalize (ST.cshape_args cs), (ST.cshape_sorts cs). + generalize (ST.cstr_args cs), (ST.cdecl_sorts cs). have foo := (X (Σ, udecl) _ _ _ X0). rewrite -trans_arities_context. induction c; destruct l; simpl; auto; @@ -1934,24 +1618,24 @@ Proof. revert on_cindices. rewrite trans_lift_context /trans_local -map_rev. simpl. rewrite {2}/trans_local map_length. - generalize (List.rev (LiftSubst.lift_context #|ST.cshape_args cs| 0 (ST.ind_indices X1))). - generalize (ST.cshape_indices cs). + generalize (List.rev (LiftSubst.lift_context #|ST.cstr_args cs| 0 (ST.ind_indices X1))). + generalize (ST.cstr_indices cs). rewrite -trans_arities_context. induction 1; simpl; constructor; auto; have foo := (X (Σ, Ast.ind_universes m) _ _ _ X0); specialize (foo (Ast.app_context (Ast.app_context (Ast.arities_context (Ast.ind_bodies m)) - (Ast.ind_params m)) (ST.cshape_args cs))). + (Ast.ind_params m)) (ST.cstr_args cs))). rewrite /trans_local !map_app in foo. now apply (foo i (Some t)). now rewrite (trans_subst_telescope [i] 0) in IHon_cindices. now rewrite (trans_subst_telescope [b] 0) in IHon_cindices. + clear -IHX0 on_ctype_positive. - unfold ST.cdecl_type in *. unfold cdecl_type. simpl in *. + unfold ST.cstr_type in *. unfold cstr_type. simpl in *. change [] with (map trans_decl []). revert on_ctype_positive. generalize (@nil Ast.context_decl). induction 1; simpl. rewrite trans_mkApps. simpl. subst headrel. - assert (#|PCUICEnvironment.ind_bodies (trans_minductive_body m)| = #|TemplateEnvironment.ind_bodies m|) as <-. + assert (#|PCUICEnvironment.ind_bodies (trans_minductive_body m)| = #|Env.ind_bodies m|) as <-. now rewrite /trans_minductive_body /= map_length. assert (#|ctx| = #|map trans_decl ctx|) as ->. now rewrite map_length. eapply positive_cstr_concl. @@ -1973,9 +1657,10 @@ Proof. admit. -- admit. Admitted. - +*) Lemma template_to_pcuic_env {cf} Σ : Template.Typing.wf Σ -> wf (trans_global_decls Σ). Proof. + (* intros Hu. eapply trans_on_global_env; eauto. simpl; intros. epose proof (ST.env_prop_typing _ template_to_pcuic _ X Γ). @@ -1987,10 +1672,12 @@ Proof. - eapply X2; eauto. - destruct X0 as [s Hs]. exists s. eapply (X2 _ (Ast.tSort s)); eauto. -Qed. +Qed.*) +Admitted. Lemma template_to_pcuic_env_ext {cf} Σ : Template.Typing.wf_ext Σ -> wf_ext (trans_global Σ). Proof. + (* intros [u Hu]. split. now apply template_to_pcuic_env. destruct Hu as [? [? [? ?]]]. @@ -1999,15 +1686,17 @@ Proof. red in H2 |- *. rewrite -global_ext_constraints_trans in H2. apply H2. -Qed. +Qed.*) +Admitted. Theorem template_to_pcuic_typing {cf} Σ Γ t T : ST.wf Σ.1 -> ST.typing Σ Γ t T -> - typing (trans_global Σ) (trans_local Γ) (trans t) (trans T). + let Σ' := trans_global Σ in + typing Σ' (trans_local Σ'.1 Γ) (trans Σ'.1 t) (trans Σ'.1 T). Proof. intros wf ty. - apply (ST.env_prop_typing _ template_to_pcuic _ wf); auto. + apply (ST.env_prop_typing template_to_pcuic); auto. now eapply ST.typing_wf_local. now apply template_to_pcuic_env. Qed. diff --git a/replace.sh b/replace.sh new file mode 100644 index 000000000..670e966e4 --- /dev/null +++ b/replace.sh @@ -0,0 +1,10 @@ +#/bin/bash +SED=`which gsed || which sed` +echo $1 +echo $2 + +# ${SED} -i -E -e \ +# "s/declared_projection ((\(.*\))|[^ ]*) ((\(.*\))|[^ ]*) ((\(.*\))|[^ ]*) ((\(.*\))|[^ ]*)([\)| ->])/declared_projection \1 \7 \3 \5\9/g" \ +# */*/*.v + +${SED} -i -e "s/${1}/${2}/g" */*/*.v \ No newline at end of file diff --git a/safechecker/_CoqProject.in b/safechecker/_CoqProject.in index 29115f2f4..ded44483c 100644 --- a/safechecker/_CoqProject.in +++ b/safechecker/_CoqProject.in @@ -2,7 +2,6 @@ theories/PCUICErrors.v theories/PCUICSafeReduce.v -theories/PCUICEqualityDec.v theories/PCUICSafeConversion.v theories/PCUICWfReduction.v theories/PCUICWfEnv.v diff --git a/safechecker/_PluginProject.in b/safechecker/_PluginProject.in index 870755842..1de1f4396 100644 --- a/safechecker/_PluginProject.in +++ b/safechecker/_PluginProject.in @@ -14,14 +14,10 @@ src/eqdepFacts.ml # From template src/ssrbool.ml src/ssrbool.mli -src/monad_utils.ml -src/monad_utils.mli src/uGraph0.ml src/uGraph0.mli src/wGraph.ml src/wGraph.mli -src/environmentTyping.mli -src/environmentTyping.ml src/typing0.mli src/typing0.ml @@ -33,8 +29,8 @@ src/pCUICAst.ml src/pCUICAst.mli src/pCUICAstUtils.ml src/pCUICAstUtils.mli -src/pCUICLiftSubst.ml -src/pCUICLiftSubst.mli +src/pCUICCases.mli +src/pCUICCases.ml # src/eqDecInstances.ml # src/eqDecInstances.mli src/pCUICInduction.mli @@ -47,10 +43,6 @@ src/pCUICReduction.ml src/pCUICReduction.mli src/pCUICTyping.ml src/pCUICTyping.mli -src/pCUICUnivSubst.ml -src/pCUICUnivSubst.mli -src/pCUICCumulativity.mli -src/pCUICCumulativity.ml src/pCUICPosition.mli src/pCUICPosition.ml src/pCUICNormal.mli diff --git a/safechecker/src/metacoq_safechecker_plugin.mlpack b/safechecker/src/metacoq_safechecker_plugin.mlpack index 0868323b5..0b36b304d 100644 --- a/safechecker/src/metacoq_safechecker_plugin.mlpack +++ b/safechecker/src/metacoq_safechecker_plugin.mlpack @@ -1,4 +1,3 @@ -Monad_utils MSetWeakList EqdepFacts Utils @@ -6,7 +5,6 @@ Utils Ssrbool WGraph UGraph0 -EnvironmentTyping Typing0 Reflect @@ -16,10 +14,9 @@ Relation Relation_Properties PCUICPrimitive PCUICAst +PCUICCases PCUICAstUtils PCUICInduction -PCUICUnivSubst -PCUICLiftSubst PCUICReflect PCUICEquality PCUICTyping @@ -30,7 +27,6 @@ PCUICNormal PCUICPosition PCUICPretty TemplateToPCUIC -PCUICCumulativity PCUICUnivSubst PCUICErrors diff --git a/safechecker/theories/PCUICErrors.v b/safechecker/theories/PCUICErrors.v index 6136f62fb..28a55a281 100644 --- a/safechecker/theories/PCUICErrors.v +++ b/safechecker/theories/PCUICErrors.v @@ -30,19 +30,35 @@ Inductive ConversionError := | ProdNotConvertibleAnn (Γ1 : context) (na : aname) (A1 B1 : term) (Γ2 : context) (na' : aname) (A2 B2 : term) + +| ContextNotConvertibleAnn + (Γ : context) (decl : context_decl) + (Γ' : context) (decl' : context_decl) +| ContextNotConvertibleType + (Γ : context) (decl : context_decl) + (Γ' : context) (decl' : context_decl) +| ContextNotConvertibleBody + (Γ : context) (decl : context_decl) + (Γ' : context) (decl' : context_decl) +| ContextNotConvertibleLength | CaseOnDifferentInd (Γ1 : context) - (ind : inductive) (par : nat) (p c : term) (brs : list (nat × term)) + (ci : case_info) (p : predicate term) (c : term) (brs : list (branch term)) (Γ2 : context) - (ind' : inductive) (par' : nat) (p' c' : term) (brs' : list (nat × term)) + (ci' : case_info) (p' : predicate term) (c' : term) (brs' : list (branch term)) -| CaseBranchNumMismatch - (ind : inductive) (par : nat) - (Γ : context) (p c : term) (brs1 : list (nat × term)) - (m : nat) (br : term) (brs2 : list (nat × term)) - (Γ' : context) (p' c' : term) (brs1' : list (nat × term)) - (m' : nat) (br' : term) (brs2' : list (nat × term)) +| CasePredParamsUnequalLength + (Γ1 : context) + (ci : case_info) (p : predicate term) (c : term) (brs : list (branch term)) + (Γ2 : context) + (ci' : case_info) (p' : predicate term) (c' : term) (brs' : list (branch term)) + +| CasePredUnequalUniverseInstances + (Γ1 : context) + (ci : case_info) (p : predicate term) (c : term) (brs : list (branch term)) + (Γ2 : context) + (ci' : case_info) (p' : predicate term) (c' : term) (brs' : list (branch term)) | DistinctStuckProj (Γ : context) (p : projection) (c : term) @@ -103,7 +119,8 @@ Inductive type_error := | UndeclaredConstant (c : kername) | UndeclaredInductive (c : inductive) | UndeclaredConstructor (c : inductive) (i : nat) -| NotCumulSmaller (G : universes_graph) (Γ : context) (t u t' u' : term) (e : ConversionError) +| NotCumulSmaller (le : bool) + (G : universes_graph) (Γ : context) (t u t' u' : term) (e : ConversionError) | NotConvertible (G : universes_graph) (Γ : context) (t u : term) | NotASort (t : term) | NotAProduct (t t' : term) @@ -127,7 +144,7 @@ Definition print_universes_graph (G : universes_graph) := let levels := LevelSet.elements G.1.1 in let edges := wGraph.EdgeSet.elements G.1.2 in string_of_list print_level levels - ^ "\n" ^ string_of_list print_edge edges. + ^ nl ^ string_of_list print_edge edges. Definition string_of_conv_pb (c : conv_pb) : string := match c with @@ -136,7 +153,17 @@ Definition string_of_conv_pb (c : conv_pb) : string := end. Definition print_term Σ Γ t := - print_term Σ Γ true false t. + let ids := fresh_names Σ [] Γ in + print_term Σ true ids true false t. + +Definition print_context_decl Σ Γ (decl : context_decl) : string := + fresh_name Σ [] (binder_name (decl_name decl)) (Some (decl_type decl)) + ^ " : " + ^ print_term Σ Γ (decl_type decl) + ^ match decl_body decl with + | Some body => " := " ^ print_term Σ Γ body + | None => "" + end. Fixpoint string_of_conv_error Σ (e : ConversionError) : string := match e with @@ -147,99 +174,117 @@ Fixpoint string_of_conv_error Σ (e : ConversionError) : string := "Constant " ^ string_of_kername c ^ " common in both terms is not found in the environment." | LambdaNotConvertibleAnn Γ1 na A1 t1 Γ2 na' A2 t2 => - "When comparing\n" ^ print_term Σ Γ1 (tLambda na A1 t1) ^ - "\nand\n" ^ print_term Σ Γ2 (tLambda na' A2 t2) ^ - "\nbinding annotations are not convertible\n" + "When comparing" ^ nl ^ print_term Σ Γ1 (tLambda na A1 t1) ^ + nl ^ "and" ^ nl ^ print_term Σ Γ2 (tLambda na' A2 t2) ^ + nl ^ "binding annotations are not convertible" ^ nl | LambdaNotConvertibleTypes Γ1 na A1 t1 Γ2 na' A2 t2 e => - "When comparing\n" ^ print_term Σ Γ1 (tLambda na A1 t1) ^ - "\nand\n" ^ print_term Σ Γ2 (tLambda na' A2 t2) ^ - "\ntypes are not convertible:\n" ^ + "When comparing" ^ nl ^ print_term Σ Γ1 (tLambda na A1 t1) ^ + nl ^ "and" ^ nl ^ print_term Σ Γ2 (tLambda na' A2 t2) ^ + nl ^ "types are not convertible:" ^ nl ^ string_of_conv_error Σ e | ProdNotConvertibleAnn Γ1 na A1 B1 Γ2 na' A2 B2 => - "When comparing\n" ^ print_term Σ Γ1 (tProd na A1 B1) ^ - "\nand\n" ^ print_term Σ Γ2 (tProd na' A2 B2) ^ - "\nbinding annotations are not convertible:\n" + "When comparing" ^ nl ^ print_term Σ Γ1 (tProd na A1 B1) ^ + nl ^ "and" ^ nl ^ print_term Σ Γ2 (tProd na' A2 B2) ^ + nl ^ "binding annotations are not convertible:" ^ nl | ProdNotConvertibleDomains Γ1 na A1 B1 Γ2 na' A2 B2 e => - "When comparing\n" ^ print_term Σ Γ1 (tProd na A1 B1) ^ - "\nand\n" ^ print_term Σ Γ2 (tProd na' A2 B2) ^ - "\ndomains are not convertible:\n" ^ + "When comparing" ^ nl ^ print_term Σ Γ1 (tProd na A1 B1) ^ + nl ^ "and" ^ nl ^ print_term Σ Γ2 (tProd na' A2 B2) ^ + nl ^ "domains are not convertible:" ^ nl ^ string_of_conv_error Σ e - | CaseOnDifferentInd Γ ind par p c brs Γ' ind' par' p' c' brs' => - "The two stuck pattern-matching\n" ^ - print_term Σ Γ (tCase (ind, par) p c brs) ^ - "\nand\n" ^ print_term Σ Γ' (tCase (ind', par') p' c' brs') ^ - "\nare done on distinct inductive types." - | CaseBranchNumMismatch - ind par Γ p c brs1 m br brs2 Γ' p' c' brs1' m' br' brs2' => - "The two stuck pattern-matching\n" ^ - print_term Σ Γ (tCase (ind, par) p c (brs1 ++ (m,br) :: brs2)) ^ - "\nand\n" ^ - print_term Σ Γ' (tCase (ind, par) p' c' (brs1' ++ (m',br') :: brs2')) ^ - "\nhave a mistmatch in the branch number " ^ string_of_nat #|brs1| ^ - "\nthe number of parameters do not coincide\n" ^ - print_term Σ Γ br ^ - "\nhas " ^ string_of_nat m ^ " parameters while\n" ^ - print_term Σ Γ br' ^ - "\nhas " ^ string_of_nat m' ^ "." + | CaseOnDifferentInd Γ ci p c brs Γ' ci' p' c' brs' => + "The two stuck pattern-matches" ^ nl ^ + print_term Σ Γ (tCase ci p c brs) ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tCase ci' p' c' brs') ^ + nl ^ "are done on distinct inductive types." + | CasePredParamsUnequalLength Γ ci p c brs Γ' ci' p' c' brs' => + "The predicates of the two stuck pattern-matches" ^ nl ^ + print_term Σ Γ (tCase ci p c brs) ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tCase ci' p' c' brs') ^ + nl ^ "have an unequal number of parameters." + | CasePredUnequalUniverseInstances Γ ci p c brs Γ' ci' p' c' brs' => + "The predicates of the two stuck pattern-matches" ^ nl ^ + print_term Σ Γ (tCase ci p c brs) ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tCase ci' p' c' brs') ^ + nl ^ "have unequal universe instances." + | ContextNotConvertibleAnn Γ decl Γ' decl' => + "When comparing the declarations" ^ nl ^ + print_context_decl Σ Γ decl ^ nl ^ + "and" ^ nl ^ + print_context_decl Σ Γ' decl' ^ nl ^ + "the binder annotations are not equal" + | ContextNotConvertibleType Γ decl Γ' decl' => + "When comparing the declarations" ^ nl ^ + print_context_decl Σ Γ decl ^ nl ^ + "and" ^ nl ^ + print_context_decl Σ Γ' decl' ^ nl ^ + "the types are not convertible" + | ContextNotConvertibleBody Γ decl Γ' decl' => + "When comparing the declarations" ^ nl ^ + print_context_decl Σ Γ decl ^ nl ^ + "and" ^ nl ^ + print_context_decl Σ Γ' decl' ^ nl ^ + "the bodies are not convertible" + | ContextNotConvertibleLength => "The contexts have unequal length" + | DistinctStuckProj Γ p c Γ' p' c' => - "The two stuck projections\n" ^ + "The two stuck projections" ^ nl ^ print_term Σ Γ (tProj p c) ^ - "\nand\n" ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tProj p' c') ^ - "\nare syntactically different." + nl ^ "are syntactically different." | CannotUnfoldFix Γ mfix idx Γ' mfix' idx' => - "The two fixed-points\n" ^ + "The two fixed-points" ^ nl ^ print_term Σ Γ (tFix mfix idx) ^ - "\nand\n" ^ print_term Σ Γ' (tFix mfix' idx') ^ - "\ncorrespond to syntactically distinct terms that can't be unfolded." + nl ^ "and" ^ nl ^ print_term Σ Γ' (tFix mfix' idx') ^ + nl ^ "correspond to syntactically distinct terms that can't be unfolded." | FixRargMismatch idx Γ u mfix1 mfix2 Γ' v mfix1' mfix2' => - "The two fixed-points\n" ^ + "The two fixed-points" ^ nl ^ print_term Σ Γ (tFix (mfix1 ++ u :: mfix2) idx) ^ - "\nand\n" ^ print_term Σ Γ' (tFix (mfix1' ++ v :: mfix2') idx) ^ - "\nhave a mismatch in the function number " ^ string_of_nat #|mfix1| ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tFix (mfix1' ++ v :: mfix2') idx) ^ + nl ^ "have a mismatch in the function number " ^ string_of_nat #|mfix1| ^ ": arguments " ^ string_of_nat u.(rarg) ^ " and " ^ string_of_nat v.(rarg) ^ "are different." | FixMfixMismatch idx Γ mfix Γ' mfix' => - "The two fixed-points\n" ^ + "The two fixed-points" ^ nl ^ print_term Σ Γ (tFix mfix idx) ^ - "\nand\n" ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tFix mfix' idx) ^ - "\nhave a different number of mutually defined functions." + nl ^ "have a different number of mutually defined functions." | DistinctCoFix Γ mfix idx Γ' mfix' idx' => - "The two cofixed-points\n" ^ + "The two cofixed-points" ^ nl ^ print_term Σ Γ (tCoFix mfix idx) ^ - "\nand\n" ^ print_term Σ Γ' (tCoFix mfix' idx') ^ - "\ncorrespond to syntactically distinct terms." + nl ^ "and" ^ nl ^ print_term Σ Γ' (tCoFix mfix' idx') ^ + nl ^ "correspond to syntactically distinct terms." | CoFixRargMismatch idx Γ u mfix1 mfix2 Γ' v mfix1' mfix2' => - "The two co-fixed-points\n" ^ + "The two co-fixed-points" ^ nl ^ print_term Σ Γ (tCoFix (mfix1 ++ u :: mfix2) idx) ^ - "\nand\n" ^ print_term Σ Γ' (tCoFix (mfix1' ++ v :: mfix2') idx) ^ - "\nhave a mismatch in the function number " ^ string_of_nat #|mfix1| ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tCoFix (mfix1' ++ v :: mfix2') idx) ^ + nl ^ "have a mismatch in the function number " ^ string_of_nat #|mfix1| ^ ": arguments " ^ string_of_nat u.(rarg) ^ " and " ^ string_of_nat v.(rarg) ^ "are different." | CoFixMfixMismatch idx Γ mfix Γ' mfix' => - "The two co-fixed-points\n" ^ + "The two co-fixed-points" ^ nl ^ print_term Σ Γ (tCoFix mfix idx) ^ - "\nand\n" ^ + nl ^ "and" ^ nl ^ print_term Σ Γ' (tCoFix mfix' idx) ^ - "\nhave a different number of mutually defined functions." + nl ^ "have a different number of mutually defined functions." | StackHeadError leq Γ1 t1 args1 u1 l1 Γ2 t2 u2 l2 e => - "TODO stackheaderror\n" ^ + "TODO stackheaderror" ^ nl ^ string_of_conv_error Σ e | StackTailError leq Γ1 t1 args1 u1 l1 Γ2 t2 u2 l2 e => - "TODO stacktailerror\n" ^ + "TODO stacktailerror" ^ nl ^ string_of_conv_error Σ e | StackMismatch Γ1 t1 args1 l1 Γ2 t2 l2 => - "Convertible terms\n" ^ + "Convertible terms" ^ nl ^ print_term Σ Γ1 t1 ^ - "\nand\n" ^ print_term Σ Γ2 t2 ^ + nl ^ "and" ^ nl ^ print_term Σ Γ2 t2 ^ "are convertible/convertible (TODO) but applied to a different number" ^ " of arguments." | HeadMismatch leq Γ1 t1 Γ2 t2 => - "Terms\n" ^ + "Terms" ^ nl ^ print_term Σ Γ1 t1 ^ - "\nand\n" ^ print_term Σ Γ2 t2 ^ - "\ndo not have the same head when comparing for " ^ + nl ^ "and" ^ nl ^ print_term Σ Γ2 t2 ^ + nl ^ "do not have the same head when comparing for " ^ string_of_conv_pb leq end. @@ -251,21 +296,26 @@ Definition string_of_type_error Σ (e : type_error) : string := | UndeclaredConstant c => "Undeclared constant " ^ string_of_kername c | UndeclaredInductive c => "Undeclared inductive " ^ string_of_kername (inductive_mind c) | UndeclaredConstructor c i => "Undeclared inductive " ^ string_of_kername (inductive_mind c) - | NotCumulSmaller G Γ t u t' u' e => "Terms are not <= for cumulativity:\n" ^ - print_term Σ Γ t ^ "\nand:\n" ^ print_term Σ Γ u ^ - "\nafter reduction:\n" ^ - print_term Σ Γ t' ^ "\nand:\n" ^ print_term Σ Γ u' ^ - "\nerror:\n" ^ string_of_conv_error Σ e ^ - "\nin universe graph:\n" ^ print_universes_graph G - | NotConvertible G Γ t u => "Terms are not convertible:\n" ^ - print_term Σ Γ t ^ "\nand:\n" ^ print_term Σ Γ u ^ - "\nin universe graph:\n" ^ print_universes_graph G - | NotASort t => "Not a sort" - | NotAProduct t t' => "Not a product" + | NotCumulSmaller le G Γ t u t' u' e => "Types are not " ^ + (if le then "<= for cumulativity:" ^ nl + else "convertible:" ^ nl) ^ + print_term Σ Γ t ^ nl ^ "and:" ^ nl ^ print_term Σ Γ u ^ + nl ^ "after reduction:" ^ nl ^ + print_term Σ Γ t' ^ nl ^ "and:" ^ nl ^ print_term Σ Γ u' ^ + nl ^ "error:" ^ nl ^ string_of_conv_error Σ e ^ + nl ^ "in universe graph:" ^ nl ^ print_universes_graph G ^ nl ^ + " and context: " ^ nl ^ snd (print_context Σ [] Γ) + | NotConvertible G Γ t u => "Terms are not convertible:" ^ nl ^ + print_term Σ Γ t ^ nl ^ "and:" ^ nl ^ print_term Σ Γ u ^ + nl ^ "in universe graph:" ^ nl ^ print_universes_graph G ^ nl ^ + " and context: " ^ nl ^ snd (print_context Σ [] Γ) + | NotASort t => "Not a sort: " ^ print_term Σ [] t + | NotAProduct t t' => "Not a product" ^ print_term Σ [] t ^ nl ^ + "(after reducing to " ^ print_term Σ [] t' | NotAnArity t => print_term Σ [] t ^ " is not an arity" - | NotAnInductive t => "Not an inductive" + | NotAnInductive t => "Not an inductive: " ^ print_term Σ [] t | IllFormedFix m i => "Ill-formed recursive definition" - | UnsatisfiedConstraints c => "Unsatisfied constraints" + | UnsatisfiedConstraints c => "Unsatisfied constraints" | Msg s => "Msg: " ^ s end. @@ -326,4 +376,4 @@ Definition wrap_error {A} Σ (id : string) (check : typing_result A) : EnvCheck match check with | Checked a => CorrectDecl a | TypeError e => EnvError Σ (IllFormedDecl id e) - end. \ No newline at end of file + end. diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index fef3c99dd..39b79d79b 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -1,18 +1,18 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils uGraph. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils - PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICNormal PCUICSR + PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICTyping PCUICNormal PCUICSR PCUICGeneration PCUICReflect PCUICEquality PCUICInversion PCUICValidity PCUICWeakening PCUICPosition PCUICCumulativity PCUICSafeLemmata PCUICSN PCUICPretty PCUICArities PCUICConfluence PCUICSize PCUICContextConversion PCUICConversion PCUICWfUniverses - PCUICGlobalEnv + PCUICGlobalEnv PCUICEqualityDec (* Used for support lemmas *) PCUICInductives PCUICWfUniverses PCUICContexts PCUICSubstitution PCUICSpine PCUICInductiveInversion PCUICClosed PCUICUnivSubstitution PCUICWeakeningEnv. -From MetaCoq.SafeChecker Require Import PCUICSafeReduce PCUICErrors PCUICEqualityDec +From MetaCoq.SafeChecker Require Import PCUICSafeReduce PCUICErrors PCUICSafeConversion PCUICWfReduction PCUICWfEnv PCUICTypeChecker. From Equations Require Import Equations. @@ -285,6 +285,15 @@ Section CheckEnv. Definition infer_type_wf_env (Σ : wf_env_ext) Γ (wfΓ : ∥ wf_local Σ Γ ∥) t : typing_result (∑ s, ∥ Σ ;;; Γ |- t : tSort s ∥) := infer_type_wf_ext Σ (wf_env_ext_wf Σ) Σ (wf_env_ext_graph_wf Σ) Γ wfΓ t. + Definition check_context_wf_ext (Σ : global_env_ext) (wfΣ : ∥ wf_ext Σ ∥) + (G : universes_graph) (HG : is_graph_of_uctx G (global_ext_uctx Σ)) (Γ : context) : typing_result (∥ wf_local Σ Γ ∥) := + @check_context cf Σ (let 'sq wfΣ := wfΣ in sq wfΣ.1) + (let 'sq wfΣ := wfΣ in sq wfΣ.2) G HG + (@infer_wf_ext Σ wfΣ G HG) Γ. + + Definition check_context_wf_env (Σ : wf_env_ext) (Γ : context) : typing_result (∥ wf_local Σ Γ ∥) := + @check_context_wf_ext Σ (wf_env_ext_wf Σ) Σ (wf_env_ext_graph_wf Σ) Γ. + Definition wfnil {Σ : global_env_ext} : ∥ wf_local Σ [] ∥ := sq localenv_nil. Notation " ' pat <- m ;; f " := (bind m (fun pat => f)) (pat pattern, right associativity, at level 100, m at next level). @@ -341,7 +350,7 @@ Section CheckEnv. Next Obligation. destruct Σ as [Σ wfΣ G wfG]; simpl in *. sq. split; auto. split; auto. - eapply PCUICValidity.validity_term in checkty; auto. + eapply PCUICValidity.validity in checkty; auto. Qed. Program Fixpoint infer_sorts_local_ctx (Σ : wf_env_ext) Γ Δ (wfΓ : ∥ wf_local Σ Γ ∥) : @@ -370,7 +379,7 @@ Section CheckEnv. Next Obligation. destruct Σ as [Σ wfΣ G wfG]; simpl in *. sq. split; auto. split; auto. - eapply PCUICValidity.validity_term in checkty; auto. + eapply PCUICValidity.validity in checkty; auto. Qed. Definition cumul_decl Σ Γ (d d' : context_decl) : Type := cumul_decls Σ Γ Γ d d'. @@ -395,140 +404,41 @@ Section CheckEnv. destruct Σ. sq. simpl. apply wf_env_ext_graph_wf0. Qed. - Definition wt_decl (Σ : global_env_ext) Γ d := - match d with - | {| decl_body := Some b; decl_type := ty |} => - welltyped Σ Γ ty /\ welltyped Σ Γ b - | {| decl_body := None; decl_type := ty |} => - welltyped Σ Γ ty - end. - - Lemma inv_wf_local (Σ : global_env_ext) Γ d : - wf_local Σ (Γ ,, d) -> - wf_local Σ Γ * wt_decl Σ Γ d. - Proof. - intros wfd; depelim wfd; split; simpl; pcuic. - now exists t. - Qed. - - Program Definition check_cumul_decl (Σ : wf_env_ext) Γ d d' : wt_decl Σ Γ d -> wt_decl Σ Γ d' -> typing_result (∥ cumul_decls Σ Γ Γ d d' ∥) := - match d, d' return wt_decl Σ Γ d -> wt_decl Σ Γ d' -> typing_result _ with - | {| decl_name := na; decl_body := Some b; decl_type := ty |}, - {| decl_name := na'; decl_body := Some b'; decl_type := ty' |} => - fun wtd wtd' => - eqna <- check_eq_true (eqb_binder_annot na na') (Msg "Binder annotations do not match") ;; - cumb <- wf_env_conv Σ Γ b b' _ _ ;; - cumt <- wf_env_cumul Σ Γ ty ty' _ _ ;; - ret (let 'sq cumb := cumb in - let 'sq cumt := cumt in - sq _) - | {| decl_name := na; decl_body := None; decl_type := ty |}, - {| decl_name := na'; decl_body := None; decl_type := ty' |} => - fun wtd wtd' => - eqna <- check_eq_true (eqb_binder_annot na na') (Msg "Binder annotations do not match") ;; - cumt <- wf_env_cumul Σ Γ ty ty' wtd wtd' ;; - ret (let 'sq cumt := cumt in sq _) - | _, _ => - fun wtd wtd' => raise (Msg "While checking cumulativity of contexts: declarations do not match") - end. + Program Definition wf_env_check_cumul_decl (Σ : wf_env_ext) Γ d d' := + @check_cumul_decl _ Σ (wf_env_ext_sq_wf Σ) _ Σ _ Γ d d'. Next Obligation. - constructor; pcuics. now apply eqb_binder_annot_spec. + destruct Σ; sq; simpl. apply wf_env_ext_wf0. Qed. Next Obligation. - constructor; pcuics. now apply eqb_binder_annot_spec. - Qed. - - Lemma cumul_ctx_rel_close Σ Γ Δ Δ' : - cumul_ctx_rel Σ Γ Δ Δ' -> - cumul_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). - Proof. - induction 1; pcuic. + destruct Σ. sq. simpl. apply wf_env_ext_graph_wf0. Qed. - + Lemma wf_ext_wf_p1 (Σ : global_env_ext) (wfΣ : wf_ext Σ) : wf Σ.1. Proof. apply wfΣ. Qed. Hint Resolve wf_ext_wf_p1 : pcuic. - Lemma context_cumulativity_welltyped Σ (wfΣ : wf_ext Σ) Γ Γ' t : - welltyped Σ Γ t -> - cumul_context Σ Γ' Γ -> - wf_local Σ Γ' -> - welltyped Σ Γ' t. - Proof. - intros [s Hs] cum wfΓ'; exists s; eapply context_cumulativity; pcuics. + Program Fixpoint wf_env_check_cumul_ctx (Σ : wf_env_ext) Γ Δ Δ' + (wfΔ : ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : ∥ wf_local Σ (Γ ,,, Δ') ∥) : + typing_result (∥ cumul_ctx_rel Σ Γ Δ Δ' ∥) := + @check_cumul_ctx _ Σ (wf_env_ext_sq_wf Σ) _ Σ _ Γ Δ Δ' wfΔ wfΔ'. + Next Obligation. + destruct Σ as [? [?] ? ?]. sq; simpl. apply w. Qed. - - Lemma context_cumulativity_wt_decl Σ (wfΣ : wf_ext Σ) Γ Γ' d : - wt_decl Σ Γ d -> - cumul_context Σ Γ' Γ -> - wf_local Σ Γ' -> - wt_decl Σ Γ' d. - Proof. - destruct d as [na [b|] ty]; simpl; - intuition pcuics; eapply context_cumulativity_welltyped; pcuics. + Next Obligation. + destruct Σ. sq. simpl. apply wf_env_ext_graph_wf0. Qed. - - Lemma cumul_decls_irrel_sec Σ (wfΣ : wf_ext Σ) Γ Γ' d d' : - cumul_decls Σ Γ Γ d d' -> - cumul_decls Σ Γ Γ' d d'. - Proof. - intros cum; depelim cum; intros; constructor; auto. + + Program Fixpoint wf_env_check_conv_ctx (Σ : wf_env_ext) Γ Δ Δ' + (wfΔ : ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : ∥ wf_local Σ (Γ ,,, Δ') ∥) : + typing_result (∥ conv_context_rel Σ Γ Δ Δ' ∥) := + @check_conv_ctx _ Σ (wf_env_ext_sq_wf Σ) _ Σ _ Γ Δ Δ' wfΔ wfΔ'. + Next Obligation. + destruct Σ as [? [?] ? ?]. sq; simpl. apply w. Qed. - - Lemma cumul_ctx_rel_cons {Σ Γ Δ Δ' d d'} (c : cumul_ctx_rel Σ Γ Δ Δ') (p : cumul_decls Σ (Γ,,, Δ) (Γ ,,, Δ') d d') : - cumul_ctx_rel Σ Γ (Δ ,, d) (Δ' ,, d'). - Proof. - destruct d as [na [b|] ty], d' as [na' [b'|] ty']; try constructor; auto. - depelim p. depelim p. + Next Obligation. + destruct Σ. sq. simpl. apply wf_env_ext_graph_wf0. Qed. - - Program Fixpoint check_cumul_ctx (Σ : wf_env_ext) Γ Δ Δ' - (wfΔ : ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : ∥ wf_local Σ (Γ ,,, Δ') ∥) : - typing_result (∥ cumul_ctx_rel Σ Γ Δ Δ' ∥) := - match Δ, Δ' with - | [], [] => ret (sq (ctx_rel_nil _)) - | decl :: Δ, decl' :: Δ' => - cctx <- check_cumul_ctx Σ Γ Δ Δ' _ _ ;; - cdecl <- check_cumul_decl Σ (Γ ,,, Δ) decl decl' _ _ ;; - ret _ - | _, _ => raise (Msg "While checking cumulativity of contexts: contexts have not the same length") - end. - Next Obligation. - sq; now depelim wfΔ. - Qed. - Next Obligation. - sq; now depelim wfΔ'. - Qed. - Next Obligation. - sq. - depelim wfΔ; simpl. - destruct l; eexists; eauto. - destruct l; split; eexists; eauto. - Qed. - Next Obligation. - destruct Σ as [Σ [wfext] G isG]. - sq. - assert(cumul_context Σ (Γ ,,, Δ) (Γ ,,, Δ')). - now apply cumul_ctx_rel_close. - simpl in *. eapply inv_wf_local in wfΔ as [wfΔ wfd]. - eapply inv_wf_local in wfΔ' as [wfΔ' wfd']. - eapply context_cumulativity_wt_decl. 3:eassumption. all:pcuics. - Qed. - Next Obligation. - destruct Σ as [Σ [wfext] G isG]. - sq; simpl in *. - eapply inv_wf_local in wfΔ as [wfΔ wfd]. - eapply inv_wf_local in wfΔ' as [wfΔ' wfd']. - apply cumul_ctx_rel_cons. auto. - eapply cumul_decls_irrel_sec; pcuics. - Qed. - Next Obligation. - split. intros. intros []. congruence. intros []; congruence. - Qed. - Next Obligation. - split. intros. intros []. congruence. intros []; congruence. - Qed. - + Program Definition check_eq_term le (Σ : wf_env_ext) t u : typing_result (∥ compare_term le Σ Σ t u ∥) := check <- check_eq_true (if le then leqb_term Σ Σ t u else eqb_term Σ Σ t u) (Msg "Terms are not equal") ;; ret _. @@ -560,16 +470,18 @@ Section CheckEnv. end. Next Obligation. eapply eqb_binder_annot_spec in eqna. - now constructor; simpl. + constructor; auto. red in leqty. + destruct le; auto. Qed. Next Obligation. eapply eqb_binder_annot_spec in eqna. - now constructor; simpl. + constructor; auto. red in cumt. + destruct le; auto. Qed. - + Program Fixpoint check_leq_context (le : bool) (Σ : wf_env_ext) Γ Δ : typing_result (∥ eq_context le Σ Σ Γ Δ ∥) := match Γ, Δ with - | [], [] => ret (sq All2_nil) + | [], [] => ret (sq All2_fold_nil) | decl :: Γ, decl' :: Δ => cctx <- check_leq_context le Σ Γ Δ ;; cdecl <- check_eq_decl le Σ decl decl' ;; @@ -654,18 +566,18 @@ Section CheckEnv. End MonadMapi. Definition check_constructor_spec (Σ : wf_env_ext) (ind : nat) (mdecl : mutual_inductive_body) - (d : ((ident × term) × nat)) (cs : constructor_shape) := - isType Σ (arities_context mdecl.(ind_bodies)) d.1.2 * - (d.1.2 = + (cdecl : constructor_body) (cs : constructor_univs) := + isType Σ (arities_context mdecl.(ind_bodies)) (cstr_type cdecl) * + (cstr_type cdecl = it_mkProd_or_LetIn - (mdecl.(ind_params) ,,, cs.(cshape_args)) - (mkApps (tRel (#|mdecl.(ind_params) ,,, cs.(cshape_args)| + (#|ind_bodies mdecl| - ind))) - (to_extended_list_k mdecl.(ind_params) #|cs.(cshape_args)| ++ - cs.(cshape_indices)))) * + (mdecl.(ind_params) ,,, cdecl.(cstr_args)) + (mkApps (tRel (#|mdecl.(ind_params) ,,, cdecl.(cstr_args)| + (#|ind_bodies mdecl| - ind))) + (to_extended_list_k mdecl.(ind_params) #|cdecl.(cstr_args)| ++ + cdecl.(cstr_indices)))) * (sorts_local_ctx (lift_typing typing) Σ - (arities_context mdecl.(ind_bodies) ,,, ind_params mdecl) cs.(cshape_args) - cs.(cshape_sorts)) * - (d.2 = context_assumptions cs.(cshape_args)). + (arities_context mdecl.(ind_bodies) ,,, ind_params mdecl) cdecl.(cstr_args) + cs) * + (cstr_arity cdecl = context_assumptions cdecl.(cstr_args)). Program Definition isRel_n n (t : term) : typing_result (t = tRel n) := match t with @@ -727,33 +639,31 @@ Section CheckEnv. Program Definition check_constructor (Σ : wf_env_ext) (ind : nat) (mdecl : mutual_inductive_body) (wfar : ∥ wf_ind_types Σ mdecl ∥) (wfpars : ∥ wf_local Σ (ind_params mdecl) ∥) - (d : ((ident × term) × nat)) : + (cdecl : constructor_body) : - EnvCheck (∑ cs : constructor_shape, ∥ check_constructor_spec Σ ind mdecl d cs ∥) := + EnvCheck (∑ cs : constructor_univs, ∥ check_constructor_spec Σ ind mdecl cdecl cs ∥) := - '(s; Hs) <- wrap_error Σ ("While checking type of constructor: " ^ d.1.1) - (infer_type_wf_env Σ (arities_context mdecl.(ind_bodies)) _ d.1.2) ;; - match decompose_prod_n_assum [] #|mdecl.(ind_params)| d.1.2 with + '(s; Hs) <- wrap_error Σ ("While checking type of constructor: " ^ cdecl.(cstr_name)) + (infer_type_wf_env Σ (arities_context mdecl.(ind_bodies)) _ cdecl.(cstr_type)) ;; + match decompose_prod_n_assum [] #|mdecl.(ind_params)| cdecl.(cstr_type) with | Some (params, concl) => - eqpars <- wrap_error Σ d.1.1 + eqpars <- wrap_error Σ cdecl.(cstr_name) (check_eq_true (eqb params mdecl.(ind_params)) (Msg "Constructor parameters do not match the parameters of the mutual declaration"));; let '(args, concl) := decompose_prod_assum [] concl in - eqargs <- wrap_error Σ d.1.1 - (check_eq_true (eqb (context_assumptions args) d.2) + eqargs <- wrap_error Σ cdecl.(cstr_name) + (check_eq_true (eqb (context_assumptions args) cdecl.(cstr_arity)) (Msg "Constructor arguments do not match the argument number of the declaration"));; - '(conclargs; Hargs) <- wrap_error Σ d.1.1 + '(conclargs; Hargs) <- wrap_error Σ cdecl.(cstr_name) (decompose_cstr_concl mdecl ind args concl) ;; - eqbpars <- wrap_error Σ d.1.1 + eqbpars <- wrap_error Σ cdecl.(cstr_name) (check_eq_true (eqb (firstn mdecl.(ind_npars) conclargs) (to_extended_list_k mdecl.(ind_params) #|args|)) (Msg "Parameters in the conclusion of the constructor type do not match the inductive parameters")) ;; - '(cs; Hcs) <- wrap_error Σ d.1.1 + '(cs; Hcs) <- wrap_error Σ cdecl.(cstr_name) (infer_sorts_local_ctx Σ (arities_context mdecl.(ind_bodies) ,,, mdecl.(ind_params)) args _) ;; - ret ({| cshape_args := args; - cshape_indices := skipn mdecl.(ind_npars) conclargs; - cshape_sorts := cs |}; _) + ret (cs; _) | None => - raise (Σ.(wf_env_ext_env), IllFormedDecl d.1.1 (Msg "Not enough parameters in constructor type")) + raise (Σ.(wf_env_ext_env), IllFormedDecl cdecl.(cstr_name) (Msg "Not enough parameters in constructor type")) end. Next Obligation. @@ -776,17 +686,19 @@ Section CheckEnv. rename Heq_anonymous1 into dt. rename Heq_anonymous2 into dc. symmetry in dt. - eapply decompose_prod_n_assum_inv in dt; simpl in dt; subst t. + eapply decompose_prod_n_assum_inv in dt; simpl in dt; subst. destruct (eqb_spec params (ind_params mdecl)) => //. subst params. symmetry in dc. eapply PCUICSubstitution.decompose_prod_assum_it_mkProd_or_LetIn in dc. simpl in dc. subst concl0. rewrite it_mkProd_or_LetIn_app. do 3 f_equal. - f_equal. autorewrite with len. lia. + f_equal. autorewrite with len. + all:todo "case". + (* lia. rewrite -{1}(firstn_skipn (ind_npars mdecl) pat1). f_equal. revert eqbpars. elim: (eqb_spec (firstn (ind_npars mdecl) pat1) _) => //. revert eqargs. - elim: eqb_spec => //. + elim: eqb_spec => //. *) Qed. Fixpoint All_sigma {A B} {P : A -> B -> Type} {l : list A} (a : All (fun x => ∑ y : B, P x y) l) : @@ -808,11 +720,12 @@ Section CheckEnv. sq (All2_cons rxy all) end. - Program Definition constructor_shapes (Σ : wf_env_ext) (id : ident) (mdecl : mutual_inductive_body) + Program Definition check_constructors_univs + (Σ : wf_env_ext) (id : ident) (mdecl : mutual_inductive_body) (wfar : ∥ wf_ind_types Σ mdecl ∥) (wfpars : ∥ wf_local Σ (ind_params mdecl) ∥) (ind : nat) - (cstrs : list ((ident × term) × nat)) : EnvCheck (∑ cs : list constructor_shape, + (cstrs : list constructor_body) : EnvCheck (∑ cs : list constructor_univs, ∥ All2 (fun cstr cs => check_constructor_spec Σ ind mdecl cstr cs) cstrs cs ∥) := css <- monad_All (fun d => check_constructor Σ ind mdecl wfar wfpars d) cstrs ;; let '(cs; all2) := All_sigma css in @@ -857,38 +770,6 @@ Section CheckEnv. rewrite hnth. simpl. reflexivity. Qed. - Lemma ctx_inst_app {Σ : global_env_ext} (wfΣ : wf Σ) Γ args args' Δ Δ' : - forall dom : ctx_inst Σ Γ args Δ, - ctx_inst Σ Γ args' (subst_telescope (ctx_inst_sub dom) 0 Δ') -> - ctx_inst Σ Γ (args ++ args') (Δ ++ Δ'). - Proof. - induction Δ as [|[na [b|] ty] Δ] using PCUICContexts.ctx_length_ind in args, Δ' |- *; simpl; auto; len. - - intros ctx ctx'. depelim ctx; simpl in ctx'. - now rewrite subst_telescope_empty in ctx'. - - intros ctx ctx'. depelim ctx. simpl in *. - specialize (X (subst_telescope [b] 0 Δ) ltac:(now len) args). - len in X. - rewrite subst_app_telescope in ctx'. len in ctx'. - specialize (X _ ctx ctx'). - constructor. rewrite subst_telescope_app. - rewrite ctx_inst_subst_length in X. len in X. now len. - - intros ctx ctx'. depelim ctx. simpl in *. - specialize (X (subst_telescope [i] 0 Δ) ltac:(now len) inst). - rewrite subst_app_telescope in ctx'. len in ctx'. - specialize (X _ ctx ctx'). - constructor; auto. rewrite subst_telescope_app. - rewrite ctx_inst_subst_length in X. len in X. now len. - Qed. - - Lemma subst_context_subst_telescope s k Γ : - subst_context s k (List.rev Γ) = List.rev (subst_telescope 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'; len; lia_f_equal. - Qed. - Definition smash_telescope acc Γ := List.rev (smash_context acc (List.rev Γ)). @@ -897,20 +778,7 @@ Section CheckEnv. ctx_inst Σ Γ args Δ. Proof. rewrite /smash_telescope. - induction Δ as [|[na [b|] ty] Δ] using PCUICContexts.ctx_length_ind in args |- *; simpl; auto. - - rewrite smash_context_app smash_context_acc /= lift0_context lift0_id subst_empty subst_context_nil - app_nil_r -smash_context_subst subst_context_nil. - rewrite subst_context_subst_telescope. - intros ctx. eapply X in ctx. 2:now len. - now constructor. - - rewrite smash_context_app smash_context_acc /=. - rewrite subst_context_lift_id. rewrite List.rev_app_distr /=. - intros ctx. depelim ctx. - constructor; auto. - eapply X. now len. - rewrite -subst_context_subst_telescope. - rewrite subst_telescope_subst_context in ctx. - now rewrite -smash_context_subst /= subst_context_nil in ctx. + intros H. apply ctx_inst_smash in H. now rewrite List.rev_involutive in H. Qed. Lemma typing_spine_it_mkProd_or_LetIn_inv {Σ : global_env_ext} (wfΣ : wf Σ) Γ Δ s args s' : @@ -927,7 +795,7 @@ Section CheckEnv. revert X sp. move: (@smash_context_assumption_context [] Δ assumption_context_nil). move: (smash_context [] Δ) => {}Δ. - induction Δ using PCUICContexts.ctx_length_rev_ind in s, s', args |- *; simpl; + induction Δ using PCUICInduction.ctx_length_rev_ind in s, s', args |- *; simpl; rewrite ?it_mkProd_or_LetIn_app; intros ass wf sp; depelim sp; try constructor. * now eapply cumul_Sort_Prod_inv in c. @@ -944,7 +812,7 @@ Section CheckEnv. eapply All_local_env_app_inv in wf as [wfΓ wfr]. eapply All_local_env_app_inv in wfr as [wfd wfΓ0]. depelim wfd. destruct l as [? Hs]. - red. eapply type_Cumul'; pcuic. eapply conv_cumul. now symmetry. + eapply type_Cumul'; pcuic. eapply conv_cumul. now symmetry. rewrite subst_telescope_subst_context. eapply X. now len. pcuic. eapply substitution_wf_local; eauto. @@ -976,7 +844,7 @@ Section CheckEnv. pose proof (red_expand_let Γ na b ty T). forward X. apply wf. epose proof (weakening_conv _ (Γ ,, decl) [] Δ). - simpl in X0. len in X0. + simpl in X0. eapply X0. eauto. symmetry. eapply red_conv. apply X. simpl. @@ -1024,7 +892,7 @@ Section CheckEnv. typing_spine Σ (Γ ,,, Δ ,,, Δ') (it_mkProd_or_LetIn (lift_context #|Δ'| 0 Δ'') (tSort s)) args (tSort s'). Proof. - induction Δ using PCUICContexts.ctx_length_rev_ind in Γ, s, s', args, Δ' |- *; simpl; + induction Δ using PCUICInduction.ctx_length_rev_ind in Γ, s, s', args, Δ' |- *; simpl; rewrite ?it_mkProd_or_LetIn_app; intros wf cl sp. * rewrite app_context_nil_l in cl. len in sp. @@ -1039,8 +907,7 @@ Section CheckEnv. rewrite closedn_ctx_app in cl. move/andP:cl; rewrite closedn_ctx_app => [[/andP [cld clΓ0]] clΔ'']. simpl in *. len in clΔ''. - unfold closedn_ctx in cld. simpl in cld. rewrite andb_true_r /id in cld. - rewrite Nat.add_0_r in cld. + unfold closedn_ctx in cld. simpl in cld. epose proof (typing_spine_letin_inv' wfΣ Γ na b ty (Γ0 ,,, Δ') _ _ _). fold decl in X0. rewrite /lift_decl in X0. len in X0. @@ -1055,7 +922,7 @@ Section CheckEnv. specialize (X Γ0 ltac:(now len) (Γ ,, decl) Δ' s args s'). simpl in X. rewrite Nat.add_1_r in clΓ0 clΔ''. rewrite app_context_assoc in wf. specialize (X wf). - forward X. rewrite closedn_ctx_app clΓ0 /=. red. rewrite -clΔ''. lia_f_equal. + forward X. rewrite closedn_ctx_app clΓ0 /=. red. rewrite -clΔ''. simpl. lia_f_equal. len in X. rewrite app_context_assoc in sp. now specialize (X sp). rewrite app_context_assoc in wf. now eapply All_local_env_app_inv in wf as [? ?]. @@ -1067,8 +934,7 @@ Section CheckEnv. rewrite closedn_ctx_app in cl. move/andP:cl; rewrite closedn_ctx_app => [[/andP [cld clΓ0]] clΔ'']. simpl in *. len in clΔ''. - unfold closedn_ctx in cld. simpl in cld. rewrite andb_true_r /id in cld. - rewrite Nat.add_0_r in cld. + unfold closedn_ctx in cld. simpl in cld. rewrite to_extended_list_k_app in sp. simpl in sp. epose proof (typing_spine_prod_inv wfΣ Γ na ty (Γ0 ,,, Δ') _ _ _). fold decl in X0. @@ -1084,7 +950,7 @@ Section CheckEnv. specialize (X Γ0 ltac:(now len) (Γ ,, decl) Δ' s args s'). simpl in X. rewrite Nat.add_1_r in clΓ0 clΔ''. rewrite app_context_assoc in wf. specialize (X wf). - forward X. rewrite closedn_ctx_app clΓ0 /=. red. rewrite -clΔ''. lia_f_equal. + forward X. rewrite closedn_ctx_app clΓ0 /=. red. rewrite -clΔ'' /=. lia_f_equal. len in X. rewrite app_context_assoc in sp. now specialize (X sp). rewrite app_context_assoc in wf. now eapply All_local_env_app_inv in wf as [? ?]. @@ -1401,11 +1267,11 @@ Section CheckEnv. intros [= eq]. set (vcstrs := ConstraintSet.union _ _) in *. subst univs. simpl. - subst u u'. len. + subst u u'. autorewrite with len. repeat (split; auto). - rewrite forallb_map /level_var_instance. rewrite [mapi_rec _ _ _]mapi_unfold forallb_unfold /= //. - intros x Hx. apply In_Var_global_ext_poly. len. lia. + intros x Hx. apply In_Var_global_ext_poly. len. - destruct wfext as [onΣ onu]. simpl in *. destruct onu as [_ [_ [_ sat]]]. do 2 red in sat. @@ -1434,7 +1300,7 @@ Section CheckEnv. rewrite !subst_instance_level_lift //. - rewrite /level_var_instance. rewrite [mapi_rec _ _ _]mapi_unfold forallb_unfold /= //. - intros x Hx. apply In_Var_global_ext_poly. len. lia. + intros x Hx. apply In_Var_global_ext_poly. len. - destruct wfext as [onΣ onu]. simpl in *. destruct onu as [_ [_ [_ sat]]]. do 2 red in sat. @@ -1477,7 +1343,7 @@ Section CheckEnv. Next Obligation. destruct Σ as [Σ wfΣ G' wfG']; simpl in *. sq. constructor; auto. - eapply validity_term in wfty. apply wfty. auto. + eapply validity in wfty. apply wfty. Qed. Next Obligation. destruct Σ as [Σ wfΣ G' wfG']; simpl in *. @@ -1485,9 +1351,9 @@ Section CheckEnv. Qed. Definition wt_indices Σ mdecl indices cs := - wf_local Σ (ind_arities mdecl,,, ind_params mdecl,,, cs.(cshape_args)) * - ctx_inst Σ (ind_arities mdecl,,, ind_params mdecl,,, cs.(cshape_args)) - (cs.(cshape_indices)) (List.rev (lift_context #|cs.(cshape_args)| 0 indices)). + wf_local Σ (ind_arities mdecl,,, ind_params mdecl,,, cs.(cstr_args)) * + ctx_inst Σ (ind_arities mdecl,,, ind_params mdecl,,, cs.(cstr_args)) + (cs.(cstr_indices)) (List.rev (lift_context #|cs.(cstr_args)| 0 indices)). Lemma ctx_inst_wt Σ Γ s Δ : ctx_inst Σ Γ s Δ -> @@ -1497,17 +1363,18 @@ Section CheckEnv. now exists t. Qed. + (* Now in PCUIC *) Lemma type_smash {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ t T} : Σ ;;; Γ ,,, Δ |- t : T -> Σ ;;; Γ ,,, smash_context [] Δ |- expand_lets Δ t : expand_lets Δ T. Proof. revert Γ t T. - induction Δ as [|[na [b|] ty] Δ] using ctx_length_rev_ind; simpl; auto. - - intros. now rewrite! PCUICCanonicity.expand_lets_nil. + induction Δ as [|[na [b|] ty] Δ] using PCUICInduction.ctx_length_rev_ind; simpl; auto. + - intros. now rewrite! expand_lets_nil. - intros Γ t T h. rewrite !smash_context_app_def !expand_lets_vdef. eapply X. now len. - eapply substitution; eauto. + eapply PCUICSubstitution.substitution; eauto. 2:{ now rewrite app_context_assoc in h. } rewrite -{1}(subst_empty 0 b). repeat constructor. rewrite !subst_empty. @@ -1532,21 +1399,19 @@ Section CheckEnv. cumul_ctx_rel Σ Γ Δ Δ'. Proof. intros H. - eapply context_relation_app in H as [cumΓ cumΔs]; auto. - eapply context_relation_length in H. len in H. lia. + eapply All2_fold_app_inv in H as [cumΓ cumΔs]; auto. + eapply All2_fold_length in H. len in H. lia. Qed. Lemma eq_decl_eq_decl_upto (Σ : global_env_ext) x y : eq_decl true Σ Σ x y -> - eq_decl_upto Σ (eq_universe Σ) (leq_universe Σ) x y. + eq_decl_upto_gen Σ (eq_universe Σ) (leq_universe Σ) x y. Proof. - destruct x, y; simpl; constructor; simpl in *; auto. - destruct X as [[eqann H1] H2]; simpl in *. repeat split; auto. - destruct decl_body, decl_body0; simpl in *; try constructor; auto. - destruct X as [[eqann H1] H2]; simpl in *. repeat split; auto. + intros []; constructor; intuition auto. cbn. constructor. + cbn. constructor; auto. Qed. - Lemma eq_decl_upto_refl (Σ : global_env_ext) x : eq_decl_upto Σ (eq_universe Σ) (leq_universe Σ) x x. + Lemma eq_decl_upto_refl (Σ : global_env_ext) x : eq_decl_upto_gen Σ (eq_universe Σ) (leq_universe Σ) x x. Proof. destruct x as [na [b|] ty]; constructor; simpl; auto. split; constructor; reflexivity. reflexivity. @@ -1560,17 +1425,18 @@ Section CheckEnv. apply cumul_ctx_rel_close'. apply eq_context_upto_univ_cumul_context. apply All2_eq_context_upto. - eapply All2_app. - eapply All2_impl; eauto. + eapply All2_app. red in eqc. + eapply All2_fold_All2; eauto. + eapply All2_fold_impl; eauto. intros; now eapply eq_decl_eq_decl_upto. eapply All2_refl. intros. simpl. eapply (eq_decl_upto_refl Σ). Qed. Lemma wt_cstrs {Σ : wf_env_ext} {n mdecl cstrs cs} : ∥ All2 - (fun (cstr : (ident × term) × nat) (cs0 : constructor_shape) => + (fun (cstr : constructor_body) (cs0 : constructor_univs) => check_constructor_spec Σ n mdecl cstr cs0) cstrs cs ∥ -> - ∥ All (fun cstr => welltyped Σ (arities_context mdecl.(ind_bodies)) cstr.1.2) cstrs ∥. + ∥ All (fun cstr => welltyped Σ (arities_context mdecl.(ind_bodies)) (cstr_type cstr)) cstrs ∥. Proof. intros; sq. solve_all. simpl. @@ -1585,9 +1451,9 @@ Section CheckEnv. (hnth : nth_error mdecl.(ind_bodies) n = Some idecl) (heq : ∥ ∑ inds, idecl.(ind_type) = it_mkProd_or_LetIn (mdecl.(ind_params) ,,, indices) (tSort inds) ∥) : ∥ All2 - (fun (cstr : (ident × term) × nat) (cs0 : constructor_shape) => + (fun (cstr :constructor_body) (cs0 : constructor_univs) => check_constructor_spec Σ (S n) mdecl cstr cs0) cstrs cs ∥ -> - ∥ All (fun cs => wt_indices Σ mdecl indices cs) cs ∥. + ∥ All (fun cs => wt_indices Σ mdecl indices cs) cstrs ∥. Proof. destruct Σ as [Σ wfΣ G wfG]; simpl in *. destruct wfΣ. intros; sq. @@ -1604,8 +1470,8 @@ Section CheckEnv. eapply inversion_Rel in Hf as [decl [wfctx [Hnth cum]]]; auto. rewrite nth_error_app_ge in Hnth. lia. split. now rewrite app_context_assoc in wfctx. - replace (#|ind_params mdecl,,, cshape_args y| + (#|ind_bodies mdecl| - S n) - - #|ind_params mdecl,,, cshape_args y|) with (#|ind_bodies mdecl| - S n) in Hnth by lia. + replace (#|ind_params mdecl,,, cstr_args x| + (#|ind_bodies mdecl| - S n) - + #|ind_params mdecl,,, cstr_args x|) with (#|ind_bodies mdecl| - S n) in Hnth by lia. pose proof (nth_error_Some_length hnth). rewrite nth_error_rev in hnth => //. eapply nth_error_arities_context in hnth. rewrite Hnth in hnth. @@ -1658,12 +1524,12 @@ Section CheckEnv. syntactically the heads. *) check_args <- wrap_error wfext.(@wf_env_ext_env cf) (string_of_kername id) (check_leq_context true wfext - (subst_instance_context u (expand_lets_ctx (ind_params mdecl) (smash_context [] (cshape_args cs)))) - (subst_instance_context u' (expand_lets_ctx (ind_params mdecl) (smash_context [] (cshape_args cs))))) ;; + (subst_instance u (expand_lets_ctx (ind_params mdecl) (smash_context [] (cstr_args cs)))) + (subst_instance u' (expand_lets_ctx (ind_params mdecl) (smash_context [] (cstr_args cs))))) ;; check_indices <- wrap_error wfext.(@wf_env_ext_env cf) (string_of_kername id) (check_leq_terms false wfext - (map (subst_instance_constr u ∘ expand_lets (ind_params mdecl ,,, cs.(cshape_args))) (cshape_indices cs)) - (map (subst_instance_constr u' ∘ expand_lets (ind_params mdecl ,,, cs.(cshape_args))) (cshape_indices cs))) ;; + (map (subst_instance u ∘ expand_lets (ind_params mdecl ,,, cs.(cstr_args))) (cstr_indices cs)) + (map (subst_instance u' ∘ expand_lets (ind_params mdecl ,,, cs.(cstr_args))) (cstr_indices cs))) ;; ret _ | None => False_rect _ _ end @@ -1722,14 +1588,18 @@ Section CheckEnv. (n : nat) (idecl : one_inductive_body) (indices : context) (hnth : nth_error mdecl.(ind_bodies) n = Some idecl) (heq : ∥ ∑ inds, idecl.(ind_type) = it_mkProd_or_LetIn (mdecl.(ind_params) ,,, indices) (tSort inds) ∥) - : EnvCheck (∑ cs : list constructor_shape, + : EnvCheck (∑ cs : list constructor_univs, ∥ on_constructors (lift_typing typing) Σ mdecl n idecl indices (ind_ctors idecl) cs ∥) := - '(cs; Hcs) <- constructor_shapes Σ (string_of_kername id) mdecl wfar wfpars (S n) idecl.(ind_ctors) ;; + '(cs; Hcs) <- check_constructors_univs Σ (string_of_kername id) mdecl wfar + wfpars (S n) idecl.(ind_ctors) ;; posc <- wrap_error Σ (string_of_kername id) - (monad_All_All (fun x px => @check_positive_cstr Σ (wf_env_ext_sq_wf Σ) mdecl n (arities_context mdecl.(ind_bodies)) x.1.2 _ []) - idecl.(ind_ctors) (wt_cstrs Hcs)) ;; - var <- monad_All_All (fun cs px => check_cstr_variance Σ0 mdecl id indices mdeclvar cs _ _) cs + (monad_All_All (fun x px => + @check_positive_cstr Σ (wf_env_ext_sq_wf Σ) mdecl n + (arities_context mdecl.(ind_bodies)) (cstr_type x) _ []) + idecl.(ind_ctors) (wt_cstrs (cs:=cs) Hcs)) ;; + var <- monad_All_All (fun cs px => check_cstr_variance Σ0 mdecl id indices mdeclvar cs _ _) + idecl.(ind_ctors) (get_wt_indices wfar wfpars n idecl indices hnth heq Hcs) ;; ret (cs; _). @@ -1741,34 +1611,38 @@ Section CheckEnv. subst Σ; simpl in *. unfold check_constructor_spec in Hcs; simpl in *. sq. solve_all. eapply All2_impl; eauto. simpl. - intros. destruct X as [[posc [[[isTy eq] sorts] eq']] [[wfargs wtinds] wfvar]]. + intros. + destruct X as [[wtinds [wfvar posc]] [[[isTy eq]] eq']]. assert(wf_local (Σ0.(wf_env_env), ind_universes mdecl) (ind_params mdecl,,, indices)). { eapply nth_error_all in wfar; eauto. simpl in wfar. - destruct heq as [s Hs]. rewrite Hs in wfar. + todo "case". } + (* destruct isTy as [s' Hs]. rewrite Hs in wfar. eapply isType_it_mkProd_or_LetIn_wf_local in wfar. - now rewrite app_context_nil_l in wfar. auto. } + now rewrite app_context_nil_l in wfar. auto. } *) econstructor => //. - unfold cdecl_type. rewrite eq. + rewrite eq. rewrite it_mkProd_or_LetIn_app. autorewrite with len. lia_f_equal. + todo "case". Qed. - Definition check_projections_type (Σ : wf_env_ext) (mind : kername) (mdecl : mutual_inductive_body) - (i : nat) (idecl : one_inductive_body) (indices : context) (cs : list constructor_shape) := + Definition check_projections_type (Σ : wf_env_ext) (mind : kername) + (mdecl : mutual_inductive_body) (i : nat) (idecl : one_inductive_body) + (indices : context) := ind_projs idecl <> [] -> - match cs return Type with + match idecl.(ind_ctors) return Type with | [cs] => on_projections mdecl mind i idecl indices cs | _ => False end. Program Definition check_projection (Σ : wf_env_ext) (mind : kername) (mdecl : mutual_inductive_body) (i : nat) (idecl : one_inductive_body) (indices : context) - (cs : constructor_shape) - (oncs : ∥ on_constructors (lift_typing typing) Σ mdecl i idecl indices idecl.(ind_ctors) [cs] ∥) + (cdecl : constructor_body) (cs : constructor_univs) + (oncs : ∥ on_constructors (lift_typing typing) Σ mdecl i idecl indices [cdecl] [cs] ∥) (k : nat) (p : ident × term) (hnth : nth_error idecl.(ind_projs) k = Some p) - (heq : #|idecl.(ind_projs)| = context_assumptions cs.(cshape_args)) - : typing_result (∥ on_projection mdecl mind i cs k p ∥) := - let Γ := smash_context [] (cs.(cshape_args) ++ ind_params mdecl) in - match nth_error Γ (context_assumptions (cs.(cshape_args)) - S k) with + (heq : #|idecl.(ind_projs)| = context_assumptions cdecl.(cstr_args)) + : typing_result (∥ on_projection mdecl mind i cdecl k p ∥) := + let Γ := smash_context [] (cdecl.(cstr_args) ++ ind_params mdecl) in + match nth_error Γ (context_assumptions (cdecl.(cstr_args)) - S k) with | Some decl => let u := abstract_instance (ind_universes mdecl) in let ind := {| inductive_mind := mind; inductive_ind := i |} in @@ -1797,15 +1671,15 @@ Section CheckEnv. Program Definition check_projections_cs (Σ : wf_env_ext) (mind : kername) (mdecl : mutual_inductive_body) (i : nat) (idecl : one_inductive_body) (indices : context) - (cs : constructor_shape) - (oncs : ∥ on_constructors (lift_typing typing) Σ mdecl i idecl indices idecl.(ind_ctors) [cs] ∥) : - typing_result (∥ on_projections mdecl mind i idecl indices cs ∥) := + (cdecl : constructor_body) (cs : constructor_univs) + (oncs : ∥ on_constructors (lift_typing typing) Σ mdecl i idecl indices [cdecl] [cs] ∥) : + typing_result (∥ on_projections mdecl mind i idecl indices cdecl ∥) := check_indices <- check_eq_true (eqb [] indices) (Msg "Primitive records cannot have indices") ;; check_elim <- check_eq_true (eqb (ind_kelim idecl) IntoAny) (Msg "Primitive records must be eliminable to Type");; - check_length <- check_eq_true (eqb #|idecl.(ind_projs)| (context_assumptions cs.(cshape_args))) + check_length <- check_eq_true (eqb #|idecl.(ind_projs)| (context_assumptions cdecl.(cstr_args))) (Msg "Invalid number of projections") ;; check_projs <- monad_Alli_nth idecl.(ind_projs) - (fun n p hnth => check_projection Σ mind mdecl i idecl indices cs oncs n p hnth (eqb_eq _ _ check_length)) ;; + (fun n p hnth => check_projection Σ mind mdecl i idecl indices cdecl cs oncs n p hnth (eqb_eq _ _ check_length)) ;; ret _. Next Obligation. @@ -1814,20 +1688,25 @@ Section CheckEnv. eapply eqb_eq in check_indices; subst indices. eapply eqb_eq in check_elim. eapply eqb_eq in check_length. constructor => //. - now rewrite H. + todo "case". + (* now rewrite H. *) Qed. Program Definition check_projections (Σ : wf_env_ext) (mind : kername) (mdecl : mutual_inductive_body) - (i : nat) (idecl : one_inductive_body) (indices : context) (cs : list constructor_shape) : + (i : nat) (idecl : one_inductive_body) (indices : context) (cs : list constructor_univs) : ∥ on_constructors (lift_typing typing) Σ mdecl i idecl indices idecl.(ind_ctors) cs ∥ -> - typing_result (∥ check_projections_type Σ mind mdecl i idecl indices cs ∥) := + typing_result (∥ check_projections_type Σ mind mdecl i idecl indices ∥) := match ind_projs idecl with | [] => fun _ => ret _ | _ => - match cs with - | [ cs ] => fun oncs => ccs <- check_projections_cs Σ mind mdecl i idecl indices cs oncs ;; + match idecl.(ind_ctors) as x, cs return + ∥ on_constructors (lift_typing typing) Σ mdecl i idecl indices x cs ∥ -> + typing_result (∥ check_projections_type Σ mind mdecl i idecl indices ∥) + with + | [ cdecl ], [ cs ] => fun oncs => + ccs <- check_projections_cs Σ mind mdecl i idecl indices cdecl cs oncs ;; ret _ - | _ => fun oncs => raise (Msg "Projections can only be declared for an inductive type with a single constructor") + | _, _ => fun oncs => raise (Msg "Projections can only be declared for an inductive type with a single constructor") end end. Next Obligation. @@ -1836,13 +1715,15 @@ Section CheckEnv. Qed. Next Obligation. sq. red. intros. auto. + todo "case". + (* destruct ind_ctors => //. *) Qed. - Definition checkb_constructors_smaller (G : universes_graph) (cs : list constructor_shape) (ind_sort : Universe.t) := - List.forallb (fun cs => List.forallb (fun argsort => check_leqb_universe G argsort ind_sort) cs.(cshape_sorts)) cs. + Definition checkb_constructors_smaller (G : universes_graph) (cs : list constructor_univs) (ind_sort : Universe.t) := + List.forallb (List.forallb (fun argsort => check_leqb_universe G argsort ind_sort)) cs. Lemma check_constructors_smallerP (Σ : wf_env_ext) cs ind_sort : - Forall (fun cs => Forall (wf_universe Σ) cs.(cshape_sorts)) cs -> wf_universe Σ ind_sort -> + Forall (fun cs => Forall (wf_universe Σ) cs) cs -> wf_universe Σ ind_sort -> ∥ reflect (check_constructors_smaller Σ cs ind_sort) (checkb_constructors_smaller Σ cs ind_sort) ∥. Proof. unfold check_constructors_smaller, checkb_constructors_smaller. @@ -1870,11 +1751,11 @@ Section CheckEnv. Qed. Definition wf_cs_sorts (Σ : wf_env_ext) cs := - Forall (fun cs => Forall (wf_universe Σ) cs.(cshape_sorts)) cs. + Forall (fun cs => Forall (wf_universe Σ) cs) cs. Program Definition do_check_ind_sorts (Σ : wf_env_ext) (params : context) (wfparams : ∥ wf_local Σ params ∥) (kelim : allowed_eliminations) (indices : context) - (cs : list constructor_shape) + (cs : list constructor_univs) (wfcs : wf_cs_sorts Σ cs) (ind_sort : Universe.t) (wfi : wf_universe Σ ind_sort): @@ -1949,8 +1830,8 @@ Section CheckEnv. '(exist wfext eq) <- make_wf_env_ext Σ id univs0 ;; checkctx <- wrap_error wfext.(@wf_env_ext_env cf) (string_of_kername id) (check_leq_context true wfext - (subst_instance_context u (expand_lets_ctx (ind_params mdecl) (smash_context [] indices))) - (subst_instance_context u' (expand_lets_ctx (ind_params mdecl) (smash_context [] indices)))) ;; + (subst_instance u (expand_lets_ctx (ind_params mdecl) (smash_context [] indices))) + (subst_instance u' (expand_lets_ctx (ind_params mdecl) (smash_context [] indices)))) ;; ret _ | None => False_rect _ _ end @@ -2007,16 +1888,17 @@ Section CheckEnv. | Some (ctx, s) => fun eq => ret ((ctx, s); _) | None => fun _ => raise (NotAnArity idecl.(ind_type)) end eq_refl)) ;; - let '(indices, params) := split_at (#|ctxinds.1| - #|mdecl.(ind_params)|) ctxinds.1 in + let '(_, params) := split_at (#|ctxinds.1| - #|mdecl.(ind_params)|) ctxinds.1 in eqpars <- wrap_error Σ id (check_eq_true (eqb params mdecl.(ind_params)) (Msg "Inductive arity parameters do not match the parameters of the mutual declaration"));; - '(cs; oncstrs) <- (check_constructors Σ0 Σ mind mdecl pf wfars wfpars mdeclvar i idecl indices hnth _) ;; - onprojs <- wrap_error Σ ("Checking projections of " ^ id) - (check_projections Σ mind mdecl i idecl indices cs oncstrs) ;; + '(cs; oncstrs) <- (check_constructors Σ0 Σ mind mdecl pf wfars wfpars mdeclvar i idecl idecl.(ind_indices) hnth _) ;; + onprojs <- wrap_error Σ ("Checking projections of " ^ id) + (check_projections Σ mind mdecl i idecl idecl.(ind_indices) cs oncstrs) ;; onsorts <- wrap_error Σ ("Checking universes of " ^ id) - (do_check_ind_sorts Σ mdecl.(ind_params) wfpars idecl.(ind_kelim) indices cs _ ctxinds.2 _) ;; - onindices <- (check_indices Σ0 mdecl mind _ mdeclvar indices _) ;; + (do_check_ind_sorts Σ mdecl.(ind_params) wfpars idecl.(ind_kelim) + idecl.(ind_indices) cs _ ctxinds.2 _) ;; + onindices <- (check_indices Σ0 mdecl mind _ mdeclvar idecl.(ind_indices) _) ;; ret (let 'sq wfars := wfars in let 'sq wfext := Σ.(wf_env_ext_wf) in let 'sq oncstrs := oncstrs in @@ -2024,12 +1906,11 @@ Section CheckEnv. let 'sq onindices := onindices in let 'sq onsorts := onsorts in (sq - {| ind_indices := indices; ind_sort := ctxinds.2; - ind_arity_eq := _; onArity := _; - ind_cshapes := cs; + {| ind_arity_eq := _; onArity := _; + ind_cunivs := cs; onConstructors := oncstrs; onProjections := onprojs; - ind_sorts := onsorts; + (* ind_sorts := onsorts; *) onIndices := _ |})). Next Obligation. symmetry in eq. @@ -2041,14 +1922,17 @@ Section CheckEnv. sq. exists t0. destruct (eqb_spec params (ind_params mdecl)); [|discriminate]. subst params. rewrite split_at_firstn_skipn in Heq_anonymous. noconf Heq_anonymous. - rewrite {1}H. now rewrite [_ ,,, _]firstn_skipn. + rewrite {1}H. + todo "case". + (* now rewrite [_ ,,, _]firstn_skipn. *) Qed. Next Obligation. destruct Σ as [Σ wfΣ G wfG]; simpl in *. sq. red. simpl. red in X. solve_all. destruct X. - now eapply sorts_local_ctx_wf_sorts in on_cargs. + todo "case". + (* now eapply sorts_local_ctx_wf_sorts in on_cargs. *) Qed. Next Obligation. @@ -2071,10 +1955,12 @@ Section CheckEnv. destruct (eqb_spec params (ind_params mdecl)); [|discriminate]. subst params. red in Hs. rewrite split_at_firstn_skipn in Heq_anonymous1. noconf Heq_anonymous1. - rewrite {1}H; autorewrite with len. rewrite [_ ,,, _]firstn_skipn. + rewrite {1}H; autorewrite with len. + todo "case". + (* rewrite [_ ,,, _]firstn_skipn. rewrite X0 in Hs. eapply PCUICSpine.inversion_it_mkProd_or_LetIn in Hs; eauto. - eapply typing_wf_local in Hs. now rewrite app_context_nil_l in Hs. + eapply typing_wf_local in Hs. now rewrite app_context_nil_l in Hs.*) Qed. Next Obligation. @@ -2084,10 +1970,11 @@ Section CheckEnv. destruct wfars as [s Hs]. red in Hs. rewrite split_at_firstn_skipn in Heq_anonymous1. noconf Heq_anonymous1. rewrite p H; autorewrite with len. simpl. - rewrite List.skipn_length. + todo "case". + (*rewrite List.skipn_length. replace (#|l0| - (#|l0| - (#|l0| - #|ind_params mdecl|))) with (#|l0| - #|ind_params mdecl|) by lia. rewrite -it_mkProd_or_LetIn_app. - rewrite /app_context firstn_skipn. reflexivity. + rewrite /app_context firstn_skipn. reflexivity.*) Qed. Next Obligation. @@ -2100,7 +1987,11 @@ Section CheckEnv. Next Obligation. destruct Σ as [Σ wfΣ G wfG]; simpl in *. subst Σ; simpl in *. - now apply onindices. + todo "case". + (* now apply onindices. *) + Qed. + Next Obligation. + todo "case". Qed. Program Definition check_wf_decl (Σ0 : wf_env) (Σ : global_env_ext) HΣ HΣ' G HG @@ -2117,10 +2008,10 @@ Section CheckEnv. wf_env_ext_graph := G; wf_env_ext_graph_wf := HG |} in let id := string_of_kername kn in check_var <- wrap_error Σ id (check_eq_true (check_variance mdecl.(ind_universes) mdecl.(ind_variance)) (Msg "variance"));; - check_pars <- wrap_error Σ id (check_context HΣ HΣ' G HG (ind_params mdecl)) ;; - check_npars <- wrap_error Σ id (check_eq_nat (context_assumptions (ind_params mdecl)) - (ind_npars mdecl) - (Msg "wrong number of parameters")) ;; + check_pars <- wrap_error Σ id (check_context_wf_env wfΣ (ind_params mdecl)) ;; + check_npars <- wrap_error Σ id + (check_eq_nat (context_assumptions (ind_params mdecl)) + (ind_npars mdecl) (Msg "wrong number of parameters")) ;; onarities <- check_ind_types wfΣ mdecl ;; check_bodies <- monad_Alli_nth mdecl.(ind_bodies) (fun i oib Hoib => check_one_ind_body Σ0 wfΣ kn mdecl eq check_pars onarities check_var i oib Hoib);; ret (Build_on_inductive_sq check_bodies check_pars check_npars check_var) @@ -2200,8 +2091,9 @@ Section CheckEnv. red in i. unfold gc_of_uctx in i; simpl in i. assert (eq: monomorphic_constraints_decl g = constraints_of_udecl (universes_decl_of_decl g)). { - destruct g. destruct c, cst_universes; try discriminate; reflexivity. - destruct m, ind_universes; try discriminate; reflexivity. } + destruct g. + destruct c, cst_universes0; try discriminate; reflexivity. + destruct m, ind_universes0; try discriminate; reflexivity. } rewrite eq; clear eq. case_eq (gc_of_constraints (global_constraints Σ)); [|intro HH; rewrite HH in i; cbn in i; contradiction i]. @@ -2211,8 +2103,8 @@ Section CheckEnv. subst G. unfold global_ext_levels; simpl. assert (eq: monomorphic_levels_decl g = levels_of_udecl (universes_decl_of_decl g)). { - destruct g. destruct c, cst_universes; try discriminate; reflexivity. - destruct m, ind_universes; try discriminate; reflexivity. } + destruct g. destruct c, cst_universes0; try discriminate; reflexivity. + destruct m, ind_universes0; try discriminate; reflexivity. } rewrite eq. simpl. rewrite add_uctx_make_graph. apply graph_eq; try reflexivity. simpl. now rewrite H1. @@ -2222,12 +2114,12 @@ Section CheckEnv. split; sq. 2: constructor; tas. unfold global_uctx; simpl. assert (eq1: monomorphic_levels_decl g = LevelSet.empty). { - destruct g. destruct c, cst_universes; try discriminate; reflexivity. - destruct m, ind_universes; try discriminate; reflexivity. } + destruct g. destruct c, cst_universes0; try discriminate; reflexivity. + destruct m, ind_universes0; try discriminate; reflexivity. } rewrite eq1; clear eq1. assert (eq1: monomorphic_constraints_decl g = ConstraintSet.empty). { - destruct g. destruct c, cst_universes; try discriminate; reflexivity. - destruct m, ind_universes; try discriminate; reflexivity. } + destruct g. destruct c, cst_universes0; try discriminate; reflexivity. + destruct m, ind_universes0; try discriminate; reflexivity. } rewrite eq1; clear eq1. now rewrite LevelSet_union_empty CS_union_empty. Qed. diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index f19d4c291..abece47cb 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -5,9 +5,9 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICReflect PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICGlobalEnv PCUICCumulativity PCUICEquality PCUICConversion PCUICSafeLemmata PCUICNormal PCUICInversion PCUICReduction PCUICPosition - PCUICPrincipality PCUICContextConversion PCUICSN PCUICUtils PCUICWeakening - PCUICConvCumInversion. -From MetaCoq.SafeChecker Require Import PCUICEqualityDec PCUICErrors PCUICSafeReduce. + PCUICPrincipality PCUICContextConversion PCUICSN PCUICUtils PCUICWfUniverses + PCUICWeakening PCUICConvCumInversion PCUICEqualityDec. +From MetaCoq.SafeChecker Require Import PCUICErrors PCUICSafeReduce. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. @@ -18,6 +18,12 @@ Set Default Goal Selector "!". Module PSR := PCUICSafeReduce. +Instance red_brs_refl Σ Γ: CRelationClasses.Reflexive (@red_brs Σ Γ). +Proof. + intros brs. + eapply All2_same; unfold on_Trel; split; reflexivity. +Qed. + (** * Conversion for PCUIC without fuel Following PCUICSafeReduce, we derive a fuel-free implementation of @@ -496,7 +502,7 @@ Section Conversion. intros (?&isr) islam. destruct t; cbn in *; try easy. unfold zipp in isr. - destruct π; cbn in *; try easy. + destruct π as [|[]]; cbn in *; try easy. destruct (decompose_stack π) in isr. destruct isr as [isr]. depelim isr; rewrite mkApps_tApp in *; try solve [solve_discr]. @@ -519,7 +525,7 @@ Section Conversion. end. Lemma zipp_stack_cat_decompose_stack t π π' : - zipp t (π +++ (decompose_stack π').2) = zipp t π. + zipp t (π ++ (decompose_stack π').2) = zipp t π. Proof. rewrite zipp_stack_cat; auto. destruct decompose_stack eqn:decomp. @@ -527,7 +533,7 @@ Section Conversion. Qed. Lemma zipc_decompose_stack_empty t π : - (decompose_stack π).2 = ε -> + (decompose_stack π).2 = [] -> zipc t π = zipp t π. Proof. destruct decompose_stack eqn:decomp. @@ -574,19 +580,19 @@ Section Conversion. match goal with | [H: context[decompose_stack (appstack ?l ?ρ)] |- _] => (rewrite (decompose_stack_appstack l ρ) in H; cbn in H) || fail 2 - | [H: context[stack_context (?π +++ ?π')] |- _] => + | [H: context[stack_context (?π ++ ?π')] |- _] => (rewrite (stack_context_stack_cat π' π) in H; cbn in H) || fail 2 - | [H: (decompose_stack ?π).2 = ε, H': context[stack_context ?π] |- _] => + | [H: (decompose_stack ?π).2 = [], H': context[stack_context ?π] |- _] => (rewrite <- (stack_context_decompose π), H in H'; cbn in H') || fail 2 - | [H: (decompose_stack ?π).2 = ε, H': context[zipc ?t ?π] |- _] => + | [H: (decompose_stack ?π).2 = [], H': context[zipc ?t ?π] |- _] => (rewrite (zipc_decompose_stack_empty t π H) in H'; cbn in H') || fail 2 | [H: context[stack_context (decompose_stack ?π).2] |- _] => (rewrite (stack_context_decompose π) in H; cbn in H) || fail 2 - | [H: context[zipp ?t (?π +++ (decompose_stack ?π').2)] |- _] => + | [H: context[zipp ?t (?π ++ (decompose_stack ?π').2)] |- _] => (rewrite (zipp_stack_cat_decompose_stack t π π') in H; cbn in H) || fail 2 | [H: context[zipc ?t (appstack ?args ?π)] |- _] => (rewrite (@zipc_appstack t args π) in H; cbn in H) || fail 2 - | [H: context[zipc ?t (?π +++ ?π')] |- _] => + | [H: context[zipc ?t (?π ++ ?π')] |- _] => (rewrite (zipc_stack_cat t π π') in H; cbn in H) || fail 2 | [H: context[zip (mkApps ?t (decompose_stack ?π).1, decompose_stack ?π).2] |- _] => unfold zip in H @@ -600,19 +606,19 @@ Section Conversion. | [|- context[decompose_stack (appstack ?l ?ρ)]] => (rewrite (decompose_stack_appstack l ρ); cbn) || fail 2 - | [|- context[stack_context (?π +++ ?π')]] => + | [|- context[stack_context (?π ++ ?π')]] => (rewrite (stack_context_stack_cat π' π); cbn) || fail 2 - | [H: (decompose_stack ?π).2 = ε |- context[stack_context ?π]] => + | [H: (decompose_stack ?π).2 = [] |- context[stack_context ?π]] => (rewrite <- (stack_context_decompose π), H; cbn) || fail 2 - | [H: (decompose_stack ?π).2 = ε |- context[zipc ?t ?π]] => + | [H: (decompose_stack ?π).2 = [] |- context[zipc ?t ?π]] => (rewrite (zipc_decompose_stack_empty t π H); cbn) || fail 2 | [|- context[stack_context (decompose_stack ?π).2]] => (rewrite (stack_context_decompose π); cbn) || fail 2 - | [|- context[zipp ?t (?π +++ (decompose_stack ?π').2)]] => + | [|- context[zipp ?t (?π ++ (decompose_stack ?π').2)]] => (rewrite (zipp_stack_cat_decompose_stack t π π'); cbn) || fail 2 | [|- context[zipc ?t (appstack ?args ?π)]] => (rewrite (@zipc_appstack t args π); cbn) || fail 2 - | [|- context[zipc ?t (?π +++ ?π')]] => + | [|- context[zipc ?t (?π ++ ?π')]] => (rewrite (zipc_stack_cat t π π'); cbn) || fail 2 | [|- context[zip (mkApps ?t (decompose_stack ?π).1, decompose_stack ?π).2]] => unfold zip @@ -711,10 +717,14 @@ 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 Σ hΣ (Γ ,,, stack_context π1) t1 (appstack args1 ε) _) := { + with inspect (reduce_stack RedFlags.nodelta Σ hΣ + (Γ ,,, stack_context π1) + t1 (appstack args1 []) _) := { | @exist (t1',π1') eq1 - with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context π2) t2 (appstack args2 ε) _) := { - | @exist (t2',π2') eq2 => isconv_prog leq t1' (π1' +++ ρ1) t2' (π2' +++ ρ2) aux + with inspect (reduce_stack RedFlags.nodelta Σ hΣ + (Γ ,,, stack_context π2) + t2 (appstack args2 []) _) := { + | @exist (t2',π2') eq2 => isconv_prog leq t1' (π1' ++ ρ1) t2' (π2' ++ ρ2) aux } } } @@ -731,13 +741,13 @@ Section Conversion. Next Obligation. simpl_reduce_stack. eapply red_welltyped ; try assumption ; revgoals. - - constructor. zip fold. eapply red_context. simpl_stacks. eassumption. + - constructor. zip fold. eapply red_context_zip. simpl_stacks. eassumption. - cbn. simpl_stacks. assumption. Qed. Next Obligation. simpl_reduce_stack. eapply red_welltyped ; try assumption ; revgoals. - - constructor. zip fold. eapply red_context. simpl_stacks. eassumption. + - constructor. zip fold. eapply red_context_zip. simpl_stacks. eassumption. - cbn. simpl_stacks. assumption. Qed. Next Obligation. @@ -862,9 +872,10 @@ Section Conversion. unfold_one_fix Γ mfix idx π h with inspect (unfold_fix mfix idx) := { | @exist (Some (arg, fn)) eq1 with inspect (decompose_stack_at π arg) := { - | @exist (Some (l, c, θ)) eq2 with inspect (reduce_stack RedFlags.default Σ hΣ (Γ ,,, stack_context θ) c ε _) := { + | @exist (Some (l, c, θ)) eq2 with inspect (reduce_stack RedFlags.default Σ hΣ + (Γ ,,, stack_context θ) c [] _) := { | @exist (cred, ρ) eq3 with construct_viewc cred := { - | view_construct ind n ui := Some (fn, appstack l (App (zipc (tConstruct ind n ui) ρ) θ)) ; + | view_construct ind n ui := Some (fn, appstack l (App_l (zipc (tConstruct ind n ui) ρ) :: θ)) ; | view_other t h := None } } ; @@ -1006,7 +1017,7 @@ Section Conversion. end. rewrite <- e1 in r1. cbn in r1. rewrite <- e1 in hd. cbn in hd. - do 2 zip fold. constructor. eapply red_context. + do 2 zip fold. constructor. eapply red_context_zip. eapply trans_red. - eapply red_app_r. exact r1. - repeat lazymatch goal with @@ -1127,7 +1138,7 @@ Section Conversion. cbn. apply welltyped_zipc_zipp in h; auto. rewrite <- (stack_context_decompose s0), decomp in wh. - change (App t0 s) with (appstack [t0] s) in *. + change (App_l t0 :: s) with (appstack [t0] s) in *. rewrite !decompose_stack_appstack. rewrite zipp_as_mkApps, !decompose_stack_appstack in h. destruct h as (ty&typ). @@ -1170,8 +1181,8 @@ Section Conversion. | prog_view_Prod na1 A1 B1 na2 A2 B2 : prog_view (tProd na1 A1 B1) (tProd na2 A2 B2) - | prog_view_Case ind par p c brs ind' par' p' c' brs' : - prog_view (tCase (ind, par) p c brs) (tCase (ind', par') p' c' brs') + | prog_view_Case ci p c brs ci' p' c' brs' : + prog_view (tCase ci p c brs) (tCase ci' p' c' brs') | prog_view_Proj p c p' c' : prog_view (tProj p c) (tProj p' c') @@ -1198,8 +1209,8 @@ Section Conversion. prog_viewc (tProd na1 A1 B1) (tProd na2 A2 B2) := prog_view_Prod na1 A1 B1 na2 A2 B2 ; - prog_viewc (tCase (ind, par) p c brs) (tCase (ind', par') p' c' brs') := - prog_view_Case ind par p c brs ind' par' p' c' brs' ; + prog_viewc (tCase ci p c brs) (tCase ci' p' c' brs') := + prog_view_Case ci p c brs ci' p' c' brs' ; prog_viewc (tProj p c) (tProj p' c') := prog_view_Proj p c p' c' ; @@ -1212,16 +1223,6 @@ Section Conversion. prog_viewc u v := prog_view_other u v I. - Lemma elimT (P : Type) (b : bool) : reflectT P b -> b -> P. - Proof. - intros []; auto. discriminate. - Defined. - - Lemma introT (P : Type) (b : bool) : reflectT P b -> P -> b. - Proof. - intros []; auto. - Defined. - Lemma welltyped_wf_local Γ t : welltyped Σ Γ t -> ∥ wf_local Σ Γ ∥. @@ -1275,22 +1276,20 @@ Section Conversion. Proof. now destruct l. Qed. Lemma conv_pb_relb_make_complete leq x y : - LevelSet.mem x (global_ext_levels Σ) -> - LevelSet.mem y (global_ext_levels Σ) -> + wf_universe_level Σ x -> + wf_universe_level Σ y -> conv_pb_rel leq (global_ext_constraints Σ) (Universe.make x) (Universe.make y) -> conv_pb_relb leq (Universe.make x) (Universe.make y). Proof. - intros memx memy r. + intros wfx wfy r. apply conv_pb_relb_complete; auto. - - intros ? ->%UnivExprSet.singleton_spec. - simpl. now apply LevelSet.mem_spec. - - intros ? ->%UnivExprSet.singleton_spec; simpl. - now apply LevelSet.mem_spec. + - intros ? ->%UnivExprSet.singleton_spec; auto. + - intros ? ->%UnivExprSet.singleton_spec; auto. Qed. Lemma eqb_universe_instance_complete u u' : - Forall (fun u => LevelSet.mem u (global_ext_levels Σ)) u -> - Forall (fun u => LevelSet.mem u (global_ext_levels Σ)) u' -> + wf_universe_instance Σ u -> + wf_universe_instance Σ u' -> R_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> eqb_universe_instance u u'. Proof. @@ -1309,8 +1308,8 @@ Section Conversion. Qed. Lemma compare_universe_variance_complete leq v u u' : - LevelSet.mem u (global_ext_levels Σ) -> - LevelSet.mem u' (global_ext_levels Σ) -> + wf_universe_level Σ u -> + wf_universe_level Σ u' -> R_universe_variance (eq_universe Σ) (conv_pb_rel leq Σ) v u u' -> compare_universe_variance (check_eqb_universe G) (conv_pb_relb leq) v u u'. Proof. @@ -1321,8 +1320,8 @@ Section Conversion. Qed. Lemma compare_universe_instance_variance_complete leq v u u' : - Forall (fun u => LevelSet.mem u (global_ext_levels Σ)) u -> - Forall (fun u => LevelSet.mem u (global_ext_levels Σ)) u' -> + wf_universe_instance Σ u -> + wf_universe_instance Σ u' -> R_universe_instance_variance (eq_universe Σ) (conv_pb_rel leq Σ) v u u' -> compare_universe_instance_variance (check_eqb_universe G) (conv_pb_relb leq) v u u'. Proof. @@ -1342,8 +1341,8 @@ Section Conversion. Qed. Lemma compare_global_instance_complete u v leq gr napp : - Forall (fun u => LevelSet.mem u (global_ext_levels Σ)) u -> - Forall (fun u => LevelSet.mem u (global_ext_levels Σ)) v-> + wf_universe_instance Σ u -> + wf_universe_instance Σ v -> R_global_instance Σ (eq_universe Σ) (conv_pb_rel leq Σ) gr napp u v -> compare_global_instance Σ (check_eqb_universe G) (conv_pb_relb leq) gr napp u v. Proof. @@ -1354,15 +1353,20 @@ Section Conversion. - apply eqb_universe_instance_complete; auto. Qed. - Lemma consistent_instance_ext_all_mem udecl u : + Lemma consistent_instance_ext_wf udecl u : consistent_instance_ext Σ udecl u -> - Forall (fun u => LevelSet.mem u (global_ext_levels Σ)) u. + wf_universe_instance Σ u. Proof. intros cons. unfold consistent_instance_ext, consistent_instance in *. - destruct udecl; [now destruct u|]. - destruct cons as (mems&_&_). - now apply forallb_Forall. + destruct udecl. + - destruct u; cbn in *; [|congruence]. + constructor. + - destruct cons as (mems&_&_). + apply forallb_Forall in mems. + eapply Forall_impl; eauto. + cbn. + intros ? ?%LevelSet.mem_spec; auto. Qed. Lemma welltyped_zipc_tConst_inv Γ c u π : @@ -1393,11 +1397,11 @@ Section Conversion. unfold_constants Γ leq c u π1 h1 c' u' π2 h2 ne hx aux with inspect (lookup_env Σ c') := { | @exist (Some (ConstantDecl {| cst_body := Some b |})) eq1 := - isconv_red leq (tConst c u) π1 (subst_instance_constr u' b) π2 aux ; + isconv_red leq (tConst c u) π1 (subst_instance u' b) π2 aux ; (* Inductive or not found *) | @exist _ eq1 with inspect (lookup_env Σ c) := { | @exist (Some (ConstantDecl {| cst_body := Some b |})) eq2 := - isconv_red leq (subst_instance_constr u b) π1 + isconv_red leq (subst_instance u b) π1 (tConst c' u') π2 aux ; (* Both Inductive or not found *) | @exist _ eq2 := no (NotFoundConstants c c') @@ -1481,98 +1485,227 @@ Section Conversion. apply welltyped_zipc_tConst_inv in h1 as (cst1&decl1&cons1). apply welltyped_zipc_tConst_inv in h2 as (cst2&decl2&cons2). eapply PCUICWeakeningEnv.declared_constant_inj in decl1; eauto; subst. - apply consistent_instance_ext_all_mem in cons1. - apply consistent_instance_ext_all_mem in cons2. + apply consistent_instance_ext_wf in cons1. + apply consistent_instance_ext_wf in cons2. eapply eqb_universe_instance_complete in r; auto. Qed. - - (* TODO (RE)MOVE *) - Lemma destArity_eq_term_upto_univ : - forall Re Rle Γ1 Γ2 t1 t2 Δ1 s1, - eq_term_upto_univ Σ Re Rle t1 t2 -> - eq_context_upto Σ Re Re Γ1 Γ2 -> - destArity Γ1 t1 = Some (Δ1, s1) -> - exists Δ2 s2, - destArity Γ2 t2 = Some (Δ2, s2) /\ - ∥ eq_context_upto Σ Re Re Δ1 Δ2 ∥ /\ - Rle s1 s2. + + Lemma All2i_length {A B} (P : nat -> A -> B -> Type) n l l' : + All2i P n l l' -> #|l| = #|l'|. Proof. - intros Re Rle Γ1 Γ2 t1 t2 Δ1 s1 ht hΓ e. - induction ht in Γ1, Γ2, Δ1, s1, hΓ, e |- *. - all: try discriminate e. - - simpl in *. inversion e. subst. - eexists _,_. intuition eauto. - constructor. assumption. - - simpl in *. - eapply IHht2 in e as h. - + eassumption. - + constructor. all: auto. - - simpl in *. - eapply IHht3 in e as h. - + eassumption. - + constructor. all: assumption. + induction 1; simpl; auto; lia. Qed. - Lemma welltyped_zipc_tCase_brs_length Γ p motive discr brs π : - welltyped Σ Γ (zipc (tCase p motive discr brs) π) -> - exists mib oib, declared_inductive Σ mib p.1 oib /\ #|brs| = #|ind_ctors oib|. + Lemma welltyped_zipc_tCase_brs_length Γ ci motive discr brs π : + welltyped Σ Γ (zipc (tCase ci motive discr brs) π) -> + exists mib oib, declared_inductive Σ ci mib oib /\ #|brs| = #|ind_ctors oib|. Proof. intros wf. zip fold in wf. apply welltyped_context in wf; [|assumption]. destruct hΣ. destruct wf as [ctyp typ]. - apply inversion_Case in typ as (?&?&?&?&?&?&?&?&?&?&?&?&?&?&?&?&?); auto. - exists x1, x2. + apply inversion_Case in typ as (mdecl&idecl&?&?&[]&?); auto. + exists mdecl, idecl. split; [easy|]. - apply All2_length in a as ->. - apply map_option_out_length in e2. - rewrite PCUICElimination.length_of_btys in e2. - congruence. + now apply All2i_length in brs_ty. + Qed. + + Equations (noeqns) isconv_context_aux + (Γ Γ' Δ Δ' : context) + (cc : ∥conv_context Σ Γ Γ'∥) + (check : + forall (leq : conv_pb) (Δh : context_hole) (t : term) (Δh' : context_hole) (t' : term), + Δ = fill_context_hole Δh t -> + Δ' = fill_context_hole Δh' t' -> + ∥conv_context_rel Σ Γ (context_hole_context Δh) (context_hole_context Δh')∥ -> + ConversionResult (conv_cum leq Σ (Γ,,, context_hole_context Δh) t t')) + (Δpre Δ'pre Δpost Δ'post : context) + (eq : Δ = Δpre ,,, Δpost) + (eq' : Δ' = Δ'pre ,,, Δ'post) : + ConversionResult (∥conv_context_rel Σ Γ Δpre Δ'pre∥) by struct Δpre := { + + isconv_context_aux Γ Γ' Δ Δ' cc check [] [] Δpost Δ'post eq eq' => yes; + + isconv_context_aux Γ Γ' Δ Δ' cc check + (mkdecl na bd ty :: Δpre) + (mkdecl na' bd' ty' :: Δ'pre) + Δpost Δ'post eq eq' + with isconv_context_aux + Γ Γ' Δ Δ' cc check Δpre Δ'pre + (Δpost ++ [mkdecl na bd ty]) + (Δ'post ++ [mkdecl na' bd' ty']) _ _ := { + + | Error ce not_conv_rest => no ce; + + | 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')); + + | exist true eq_binders + with check Conv + (Δpre, decl_hole_type na bd, Δpost) ty + (Δ'pre, decl_hole_type na' bd', Δ'post) ty' + _ _ conv_rest := { + + | Error ce not_conv_type => no (ContextNotConvertibleType + (Γ,,, Δpre) (mkdecl na bd ty) + (Γ',,, Δ'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 + (Δ'pre, decl_hole_body na' ty', Δ'post) body' + _ _ conv_rest := { + | Error ce not_conv_body => no (ContextNotConvertibleBody + (Γ,,, Δpre) (mkdecl na bd ty) + (Γ',,, Δ'pre) (mkdecl na' bd' ty')); + + | Success conv_body => yes + }; + + | None | None => yes; + + | _ | _ => no (ContextNotConvertibleBody + (Γ,,, Δpre) (mkdecl na bd ty) + (Γ',,, Δ'pre) (mkdecl na' bd' ty')) + } + } + } + }; + + isconv_context_aux Γ Γ' Δ Δ' cc check + Δpre Δ'pre Δpost Δ'post eq eq' => no ContextNotConvertibleLength + }. + Next Obligation. + constructor; constructor. + Qed. + Next Obligation. + destruct H as [H]; depelim H. + Qed. + Next Obligation. + destruct H as [H]; depelim H. + Qed. + Next Obligation. + unfold app_context. + rewrite <- app_assoc; auto. + Qed. + Next Obligation. + unfold app_context. + rewrite <- app_assoc; auto. + Qed. + Next Obligation. + destruct conv_rest as [conv_rest], conv_type as [conv_type], conv_body as [conv_body]. + constructor. + constructor; auto. + constructor; auto. + apply eqb_annot_spec; auto. + Qed. + Next Obligation. + destruct H as [H]. + contradiction not_conv_body. + depelim H. + depelim a. + constructor; auto. + Qed. + Next Obligation. + destruct H as [H]. + depelim H. + depelim a. + Qed. + Next Obligation. + destruct H as [H]. + depelim H. + depelim a. + Qed. + Next Obligation. + destruct conv_rest as [conv_rest], conv_type as [conv_type]. + constructor. + constructor; auto. + constructor; auto. + apply eqb_annot_spec; auto. + Qed. + Next Obligation. + destruct H as [H]. + contradiction not_conv_type. + depelim H. + constructor. + depelim a; auto. + Qed. + Next Obligation. + destruct H as [H]. + depelim H. + depelim a. + - apply eqb_annot_spec in e0; congruence. + - apply eqb_annot_spec in e0; congruence. + Qed. + Next Obligation. + destruct H as [H]. + contradiction not_conv_rest. + depelim H. + depelim a; constructor; auto. Qed. + Definition isconv_context + (Γ Γ' Δ Δ' : context) + (cc : ∥conv_context Σ Γ Γ'∥) + (check : + forall (leq : conv_pb) (Δh : context_hole) (t : term) (Δh' : context_hole) (t' : term), + Δ = fill_context_hole Δh t -> + Δ' = fill_context_hole Δh' t' -> + ∥conv_context_rel Σ Γ (context_hole_context Δh) (context_hole_context Δh')∥ -> + ConversionResult (conv_cum leq Σ (Γ,,, context_hole_context Δh) t t')) + : ConversionResult (∥conv_context_rel Σ Γ Δ Δ'∥) := + isconv_context_aux Γ Γ' Δ Δ' cc check Δ Δ' [] [] eq_refl eq_refl. + Equations isconv_branches (Γ : context) - (ind : inductive) (par : nat) - (p c : term) (brs1 brs2 : list (nat × term)) - (π : stack) (h : wtp Γ (tCase (ind, par) p c (brs1 ++ brs2)) π) - (p' c' : term) (brs1' brs2' : list (nat × term)) - (π' : stack) (h' : wtp Γ (tCase (ind, par) p' c' (brs1' ++ brs2')) π') + (ci : case_info) + (p : predicate term) (c : term) (brs1 brs2 : list (branch term)) + (π : stack) (h : wtp Γ (tCase ci p c (brs1 ++ brs2)) π) + (p' : predicate term) (c' : term) (brs1' brs2' : list (branch term)) + (π' : stack) (h' : wtp Γ (tCase ci p' c' (brs1' ++ brs2')) π') (hx : conv_stack_ctx Γ π π') - (h1 : ∥ All2 (fun u v => u.1 = v.1 × Σ ;;; Γ ,,, stack_context π |- u.2 = v.2) brs1 brs1' ∥) - (aux : Aux Term Γ (tCase (ind, par) p c (brs1 ++ brs2)) π (tCase (ind, par) p' c' (brs1' ++ brs2')) π' h') - : ConversionResult (∥ All2 (fun u v => u.1 = v.1 × Σ ;;; Γ ,,, stack_context π |- u.2 = v.2) brs2 brs2' ∥) + (h1 : ∥ conv_brs Σ (Γ ,,, stack_context π) brs1 brs1' ∥) + (aux : Aux Term Γ (tCase ci p c (brs1 ++ brs2)) π (tCase ci p' c' (brs1' ++ brs2')) π' h') + : ConversionResult (∥ conv_brs Σ (Γ ,,, stack_context π) brs2 brs2' ∥) by struct brs2 := - isconv_branches Γ ind par - p c brs1 ((m, br) :: brs2) π h - p' c' brs1' ((m', br') :: brs2') π' h' hx h1 aux - with inspect (eqb m m') := { - | @exist true eq1 + isconv_branches Γ ci + p c brs1 ({| bcontext := m; bbody := br |} :: brs2) π h + p' c' brs1' ({| bcontext := m'; bbody := br' |} :: brs2') π' h' hx h1 aux + with isconv_context (Γ,,, stack_context π) (Γ,,, stack_context π') m m' _ + (fun leq Δh t Δh' t' eq eq' cc => + isconv_red + leq + t (Case_branch ci p c (brs1, branch_hole_context Δh br, brs2) :: π) + t' (Case_branch ci p' c' (brs1', branch_hole_context Δh' br', brs2') :: π') aux) := { + + | Success cc with isconv_red_raw Conv - br (Case_brs (ind, par) p c m brs1 brs2 π) - br' (Case_brs (ind, par) p' c' m' brs1' brs2' π') - aux := { + br (Case_branch ci p c (brs1, branch_hole_body m, brs2) :: π) + br' (Case_branch ci p' c' (brs1', branch_hole_body m', brs2') :: π') aux := { | Success h2 - with isconv_branches Γ ind par - p c (brs1 ++ [(m,br)]) brs2 π _ - p' c' (brs1' ++ [(m', br')]) brs2' π' _ hx _ _ := { + with isconv_branches Γ ci + p c (brs1 ++ [{|bcontext := m; bbody := br|}]) brs2 π _ + p' c' (brs1' ++ [{| bcontext := m'; bbody := br'|}]) brs2' π' _ hx _ _ := { | Success h3 := yes ; | Error e h := no e } ; | Error e h := no e } ; - | @exist false eq1 := Error ( - CaseBranchNumMismatch ind par - (Γ ,,, stack_context π) p c brs1 m br brs2 - (Γ ,,, stack_context π') p' c' brs1' m' br' brs2' - ) _ + | Error e h := no e } ; - isconv_branches Γ ind par + isconv_branches Γ ci p c brs1 [] π h p' c' brs1' [] π' h' hx h1 aux := yes ; - isconv_branches Γ ind par + isconv_branches Γ ci p c brs1 brs2 π h p' c' brs1' brs2' π' h' hx h1 aux := False_rect _ _. Next Obligation. @@ -1603,24 +1736,73 @@ Section Conversion. Next Obligation. eapply R_positionR. all: simpl. 1: reflexivity. - rewrite <- app_nil_r. eapply positionR_poscat. + rewrite <- app_nil_r. + rewrite stack_position_cons. + eapply positionR_poscat. constructor. Qed. Next Obligation. - rewrite <- app_assoc. simpl. assumption. + destruct hΣ. + destruct hx as [hx]. + destruct cc as [cc']. + constructor. + apply conv_context_rel_app in cc'. + rewrite !app_context_assoc; auto. + apply conv_context_sym; auto. + eapply conv_context_trans; auto. + - apply conv_context_app_same. + apply conv_context_sym; auto. + eassumption. + - apply conv_context_sym; auto. Qed. Next Obligation. - rewrite <- app_assoc. simpl. assumption. + unfold zipp in h. + simpl in h. + rewrite app_context_assoc in h; auto. Qed. Next Obligation. - destruct h1 as [h1], h2 as [h2]. + unfold zipp in h; simpl in *. + rewrite app_context_assoc in h; tauto. + Qed. + Next Obligation. + eapply R_positionR. all: simpl. + 1: reflexivity. + rewrite stack_position_cons. + rewrite <- app_nil_r. + eapply positionR_poscat. + constructor. + Qed. + Next Obligation. + destruct hΣ. + destruct hx as [hx]. + destruct cc as [cc']. + constructor. + apply conv_context_rel_app in cc'. + rewrite !app_context_assoc; auto. + apply conv_context_sym; auto. + eapply conv_context_trans; auto. + - apply conv_context_app_same. + apply conv_context_sym; auto. + eassumption. + - apply conv_context_sym; auto. + Qed. + Next Obligation. + rewrite <- app_assoc; auto. + Qed. + Next Obligation. + rewrite <- app_assoc; auto. + Qed. + Next Obligation. + destruct cc as [cc], h1 as [h1], h2 as [h2]. constructor. apply All2_app. - assumption. - - constructor. 2: constructor. + - constructor. + 2: now constructor. simpl. - change (m =? m') with (eqb m m') in eq1. - destruct (eqb_spec m m'). 2: discriminate. - intuition eauto. + unfold zipp in h2. + split; auto. + simpl in *. + rewrite app_context_assoc in h2; auto. Qed. Next Obligation. unshelve eapply aux. all: try eassumption. @@ -1640,12 +1822,14 @@ Section Conversion. eapply proof_irrelevance. } rewrite <- e. assumption. - Qed. + Qed. Next Obligation. - destruct h1 as [h1], h2 as [h2], h3 as [h3]. - change (m =? m') with (eqb m m') in eq1. - destruct (eqb_spec m m'). 2: discriminate. - constructor. constructor. all: intuition eauto. + destruct cc as [cc], h2 as [h2], h3 as [h3]. + constructor. + constructor; auto. + unfold zipp in *; simpl in *. + split; auto. + rewrite app_context_assoc in h2; auto. Qed. Next Obligation. (* Contrapositive of previous obligation *) @@ -1657,31 +1841,31 @@ Section Conversion. apply h; clear h. destruct h1 as [h1], H as [h2]. constructor. inversion h2; clear h2. - destruct X as [_ h2]. apply h2. + destruct X as [_ h2]. simpl in h2. cbn. + now rewrite app_context_assoc. Qed. Next Obligation. - destruct H as [H]; inversion H. - destruct X as [eq_mm' _]. - change (m =? m') with (eqb m m') in eq1. - destruct (eqb_spec m m') as [|F]. 1: discriminate. - apply F, eq_mm'. + contradiction h. + destruct H as [H]. + depelim H. + destruct p0. + constructor; auto. Qed. - Equations isconv_branches' (Γ : context) - (ind : inductive) (par : nat) - (p c : term) (brs : list (nat × term)) - (π : stack) (h : wtp Γ (tCase (ind, par) p c brs) π) - (ind' : inductive) (par' : nat) - (p' c' : term) (brs' : list (nat × term)) - (π' : stack) (h' : wtp Γ (tCase (ind', par') p' c' brs') π') + (ci : case_info) + (p : predicate term) (c : term) (brs : list (branch term)) + (π : stack) (h : wtp Γ (tCase ci p c brs) π) + (ci' : case_info) + (p' : predicate term) (c' : term) (brs' : list (branch term)) + (π' : stack) (h' : wtp Γ (tCase ci' p' c' brs') π') (hx : conv_stack_ctx Γ π π') - (ei : ind = ind') (ep : par = par') - (aux : Aux Term Γ (tCase (ind, par) p c brs) π (tCase (ind', par') p' c' brs') π' h') - : ConversionResult (∥ All2 (fun u v => u.1 = v.1 × Σ ;;; Γ ,,, stack_context π |- u.2 = v.2) brs brs' ∥) := + (ei : ci = ci') + (aux : Aux Term Γ (tCase ci p c brs) π (tCase ci' p' c' brs') π' h') + : ConversionResult (∥ conv_brs Σ (Γ ,,, stack_context π) brs brs' ∥) := - isconv_branches' Γ ind par p c brs π h ind' par' p' c' brs' π' h' hx ei ep aux := - isconv_branches Γ ind par p c [] brs π _ p' c' [] brs' π' _ _ _ _. + isconv_branches' Γ ci p c brs π h ci' p' c' brs' π' h' hx eci aux := + isconv_branches Γ ci p c [] brs π _ p' c' [] brs' π' _ _ _ _. Next Obligation. constructor. constructor. Qed. @@ -1699,17 +1883,11 @@ Section Conversion. | IndFix => tFix | CoIndFix => tCoFix end. - - Definition mFix_mfix_ty fk := - match fk with - | IndFix => Fix_mfix_ty - | CoIndFix => CoFix_mfix_ty - end. - - Definition mFix_mfix_bd fk := + + Definition mFix_mfix fk := match fk with - | IndFix => Fix_mfix_bd - | CoIndFix => CoFix_mfix_bd + | IndFix => Fix + | CoIndFix => CoFix end. Definition mFixRargMismatch fk := @@ -1724,16 +1902,6 @@ Section Conversion. | CoIndFix => CoFixMfixMismatch end. - Lemma stack_context_mFix_mfix_bd : - forall fk na ty ra mfix1 mfix2 idx π, - stack_context (mFix_mfix_bd fk na ty ra mfix1 mfix2 idx π) = - stack_context π ,,, - fix_context_alt (map def_sig mfix1 ++ (na,ty) :: map def_sig mfix2). - Proof. - intros fk na ty ra mfix1 mfix2 idx π. - destruct fk. all: reflexivity. - Qed. - Equations isconv_fix_types (fk : fix_kind) (Γ : context) (idx : nat) (mfix1 mfix2 : mfixpoint term) (π : stack) @@ -1760,9 +1928,9 @@ Section Conversion. | @exist true eqann with isconv_red_raw Conv u.(dtype) - (mFix_mfix_ty fk u.(dname) u.(dbody) u.(rarg) mfix1 mfix2 idx π) + (mFix_mfix fk (mfix1, def_hole_type u.(dname) u.(dbody) u.(rarg), mfix2) idx :: π) v.(dtype) - (mFix_mfix_ty fk v.(dname) v.(dbody) v.(rarg) mfix1' mfix2' idx π') + (mFix_mfix fk (mfix1', def_hole_type v.(dname) v.(dbody) v.(rarg), mfix2') idx :: π') aux := { | Success h2 with @@ -1820,7 +1988,7 @@ Section Conversion. Next Obligation. eapply R_positionR. all: simpl. - destruct u. destruct fk. all: reflexivity. - - rewrite <- app_nil_r. destruct fk. + - rewrite <- app_nil_r, stack_position_cons. destruct fk. + eapply positionR_poscat. constructor. + eapply positionR_poscat. constructor. Qed. @@ -1845,7 +2013,7 @@ Section Conversion. change (true = eqb u.(rarg) v.(rarg)) in eq1. destruct (eqb_spec u.(rarg) v.(rarg)). 2: discriminate. symmetry in eqann. - apply (ssrbool.elimT (eq_binder_annot_reflect _ _)) in eqann. + apply eqb_binder_annot_spec in eqann. split; auto. destruct fk; simpl in *. all: intuition eauto. @@ -1879,7 +2047,7 @@ Section Conversion. change (true = eqb u.(rarg) v.(rarg)) in eq1. destruct (eqb_spec u.(rarg) v.(rarg)). 2: discriminate. symmetry in eqann. - apply (ssrbool.elimT (eq_binder_annot_reflect _ _)) in eqann. + apply eqb_binder_annot_spec in eqann. clear eq1. destruct fk. all: intuition eauto. @@ -1899,7 +2067,8 @@ Section Conversion. destruct H as [H]; inversion H; destruct X as [_ [eq_uv eqann]]. change (?ru =? ?rv) with (eqb ru rv) in eq1. symmetry in neqann. - pose proof (eq_binder_annot_reflect (dname u) (dname v)) as r. + (* would be simpler using ssr's move/ tactic *) + pose proof (eqb_annot_reflect (dname u) (dname v)) as r. now apply (ssrbool.elimF r neqann). Qed. Next Obligation. @@ -1922,6 +2091,15 @@ Section Conversion. all: constructor. all: assumption. Qed. + Lemma stack_entry_context_mFix_mfix_bd : + forall fk na ty ra mfix1 mfix2 idx, + stack_entry_context (mFix_mfix fk (mfix1, def_hole_body na ty ra, mfix2) idx) = + fix_context_alt (map def_sig mfix1 ++ (na,ty) :: map def_sig mfix2). + Proof. + intros fk na ty ra mfix1 mfix2 idx. + destruct fk. all: reflexivity. + Qed. + Equations isconv_fix_bodies (fk : fix_kind) (Γ : context) (idx : nat) (mfix1 mfix2 : mfixpoint term) (π : stack) (h : wtp Γ (mFix fk (mfix1 ++ mfix2) idx) π) @@ -1940,9 +2118,9 @@ Section Conversion. isconv_fix_bodies fk Γ idx mfix1 (u :: mfix2) π h mfix1' (v :: mfix2') π' h' hx h1 ha aux with isconv_red_raw Conv u.(dbody) - (mFix_mfix_bd fk u.(dname) u.(dtype) u.(rarg) mfix1 mfix2 idx π) + (mFix_mfix fk (mfix1, def_hole_body u.(dname) u.(dtype) u.(rarg), mfix2) idx :: π) v.(dbody) - (mFix_mfix_bd fk v.(dname) v.(dtype) v.(rarg) mfix1' mfix2' idx π') + (mFix_mfix fk (mfix1', def_hole_body v.(dname) v.(dtype) v.(rarg), mfix2') idx :: π') aux := { | Success h2 @@ -1986,7 +2164,7 @@ Section Conversion. Next Obligation. eapply R_positionR. all: simpl. - destruct u. destruct fk. all: reflexivity. - - rewrite <- app_nil_r. + - rewrite <- app_nil_r, stack_position_cons. destruct fk. + eapply positionR_poscat. constructor. + eapply positionR_poscat. constructor. @@ -1994,7 +2172,7 @@ Section Conversion. Next Obligation. destruct hΣ as [wΣ], ha as [ha], hx as [hx]. clear - wΣ ha hx. constructor. - rewrite 2!stack_context_mFix_mfix_bd. + rewrite 2!stack_entry_context_mFix_mfix_bd. change (dname u, dtype u) with (def_sig u). change (dname v, dtype v) with (def_sig v). repeat match goal with @@ -2251,11 +2429,11 @@ Section Conversion. now apply invert_type_mkApps_tProd in typ. Qed. - Lemma reduced_case_discriminee_whne Γ π ind par p c brs h : + Lemma reduced_case_discriminee_whne Γ π ci p c brs h : eqb_term (reduce_term RedFlags.default Σ hΣ (Γ,,, stack_context π) c h) c = true -> - isred_full Γ (tCase (ind, par) p c brs) π -> + isred_full Γ (tCase ci p c brs) π -> ∥whne RedFlags.default Σ (Γ,,, stack_context π) c∥. Proof. intros eq ir. @@ -2270,7 +2448,7 @@ Section Conversion. apply whnf_whne_nodelta_upgrade in eq; auto using sq. Qed. - Lemma inv_reduced_discriminees_case leq Γ π π' ind ind' par par' p p' c c' brs brs' h h' : + Lemma inv_reduced_discriminees_case leq Γ π π' ci ci' p p' c c' brs brs' h h' : conv_stack_ctx Γ π π' -> true = eqb_term (reduce_term RedFlags.default @@ -2278,16 +2456,16 @@ Section Conversion. true = eqb_term (reduce_term RedFlags.default Σ hΣ (Γ,,, stack_context π') c' h') c' -> - isred_full Γ (tCase (ind, par) p c brs) π -> - isred_full Γ (tCase (ind', par') p' c' brs') π' -> + isred_full Γ (tCase ci p c brs) π -> + isred_full Γ (tCase ci' p' c' brs') π' -> conv_cum leq Σ (Γ,,, stack_context π) - (zipp (tCase (ind, par) p c brs) π) - (zipp (tCase (ind', par') p' c' brs') π') -> - ∥(ind, par) = (ind', par') × - Σ;;; Γ,,, stack_context π |- p = p' × + (zipp (tCase ci p c brs) π) + (zipp (tCase ci' p' c' brs') π') -> + ∥ci = ci' × + conv_predicate Σ (Γ,,, stack_context π) p p' × Σ;;; Γ,,, stack_context π |- c = c' × - All2 (fun br br' => br.1 = br'.1 × (Σ;;; Γ,,, stack_context π |- br.2 = br'.2)) brs brs' × + conv_brs Σ (Γ,,, stack_context π) brs brs' × conv_terms Σ (Γ,,, stack_context π) (decompose_stack π).1 (decompose_stack π').1∥. Proof. intros [] c_is_red%eq_sym c'_is_red%eq_sym isr1 isr2 cc. @@ -2299,8 +2477,8 @@ Section Conversion. 2: eapply conv_context_sym; eauto. apply conv_cum_mkApps_inv in cc as [(conv_case&conv_args)]; eauto using whnf_mkApps. eapply conv_cum_tCase_inv in conv_case; eauto. - destruct conv_case as [([= <- <-]&?&?&?)]. - constructor; auto. + destruct conv_case as [(<-&?&?&?)]. + constructor; intuition auto. Qed. Lemma reduced_proj_body_whne Γ π p c h : @@ -2376,7 +2554,7 @@ Section Conversion. apply conv_cum_mkApps_inv in cc as [(conv_fix&conv_args)]; auto. 2: eapply whnf_conv_context; eauto. 2: eapply conv_context_sym; eauto. - apply conv_cum_tFix_inv in conv_fix as [(<-&?)]. + apply conv_cum_tFix_inv in conv_fix as [(<-&?)]; auto. constructor; split; [|split]; auto. eapply conv_terms_red_conv; eauto. Qed. @@ -2394,10 +2572,290 @@ Section Conversion. Proof. intros [?] cc. rewrite !zipp_as_mkApps in cc. + destruct hΣ. apply conv_cum_mkApps_inv in cc as [(conv_cofix&conv_args)]; auto. - apply conv_cum_tCoFix_inv in conv_cofix as [(<-&?)]. + apply conv_cum_tCoFix_inv in conv_cofix as [(<-&?)]; auto. constructor; split; [|split]; auto. Qed. + + Equations (noeqns) isconv_predicate_params_aux + (Γ : context) + (ci1 : case_info) + (p1 : predicate term) (c1 : term) (brs1 : list (branch term)) + (π1 : stack) + (h1 : wtp Γ (tCase ci1 p1 c1 brs1) π1) + (ci2 : case_info) + (p2 : predicate term) (c2 : term) (brs2 : list (branch term)) + (π2 : stack) (h2 : wtp Γ (tCase ci2 p2 c2 brs2) π2) + (hx : conv_stack_ctx Γ π1 π2) + (aux : Aux Term Γ (tCase ci1 p1 c1 brs1) π1 (tCase ci2 p2 c2 brs2) π2 h2) + (pre1 pre2 post1 post2 : list term) + (eq1 : p1.(pparams) = pre1 ++ post1) + (eq2 : p2.(pparams) = pre2 ++ post2) : + ConversionResult (∥conv_terms Σ (Γ,,, stack_context π1) post1 post2∥) := + 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 + with isconv_red_raw + Conv + t1 (Case_pred + ci1 + (pred_hole_params pre1 post1 p1.(puinst) p1.(pcontext) p1.(preturn)) + c1 brs1 :: π1) + t2 (Case_pred + 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 + } + }; + + isconv_predicate_params_aux + Γ ci1 p1 c1 brs1 π1 h1 ci2 p2 c2 brs2 π2 h2 hx aux + pre1 pre2 post1 post2 eq eq2 => no (CasePredParamsUnequalLength + (Γ,,, stack_context π1) ci1 p1 c1 brs1 + (Γ,,, stack_context π2) ci2 p2 c2 brs2). + Next Obligation. + constructor; constructor. + Qed. + Next Obligation. + destruct H as [H]. + depelim H. + Qed. + Next Obligation. + destruct H as [H]. + depelim H. + Qed. + Next Obligation. + destruct p1; auto. + Qed. + Next Obligation. + destruct p2; auto. + Qed. + Next Obligation. + apply R_positionR. all: simpl. + 1: destruct p1; cbn in *; subst; reflexivity. + rewrite stack_position_cons. + rewrite <- app_nil_r. + eapply positionR_poscat. + constructor. + Qed. + Next Obligation. + rewrite <- app_assoc; auto. + Qed. + Next Obligation. + rewrite <- app_assoc; auto. + Qed. + Next Obligation. + destruct conv_tm, conv_rest. + unfold zipp in X; simpl in *. + constructor; constructor; auto. + Qed. + Next Obligation. + contradiction not_conv_rest. + destruct H as [H]; depelim H. + constructor; auto. + Qed. + Next Obligation. + contradiction not_conv_term. + destruct H as [H]; depelim H. + constructor; auto. + Qed. + + Definition isconv_predicate_params + (Γ : context) + (ci1 : case_info) + (p1 : predicate term) (c1 : term) (brs1 : list (branch term)) + (π1 : stack) + (h1 : wtp Γ (tCase ci1 p1 c1 brs1) π1) + (ci2 : case_info) + (p2 : predicate term) (c2 : term) (brs2 : list (branch term)) + (π2 : stack) (h2 : wtp Γ (tCase ci2 p2 c2 brs2) π2) + (hx : conv_stack_ctx Γ π1 π2) + (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) + (p1 : predicate term) (c1 : term) (brs1 : list (branch term)) + (π1 : stack) + (h1 : wtp Γ (tCase ci1 p1 c1 brs1) π1) + (ci2 : case_info) + (p2 : predicate term) (c2 : term) (brs2 : list (branch term)) + (π2 : stack) (h2 : wtp Γ (tCase ci2 p2 c2 brs2) π2) + (hx : conv_stack_ctx Γ π1 π2) + (aux : Aux Term Γ (tCase ci1 p1 c1 brs1) π1 (tCase ci2 p2 c2 brs2) π2 h2) + : ConversionResult (∥conv_predicate Σ (Γ,,, stack_context π1) p1 p2∥) := + + isconv_predicate Γ ci1 p1 c1 brs1 π1 h1 ci2 p2 c2 brs2 π2 h2 hx aux + with isconv_predicate_params + Γ ci1 p1 c1 brs1 π1 h1 ci2 p2 c2 brs2 π2 h2 hx aux := { + + | Error ce not_conv_params => no ce; + + | Success conv_params + with inspect (eqb_universe_instance p1.(puinst) p2.(puinst)) := { + + | exist false not_eq_insts => no (CasePredUnequalUniverseInstances + (Γ,,, stack_context π1) ci1 p1 c1 brs1 + (Γ,,, stack_context π2) ci2 p2 c2 brs2); + + | exist true eq_insts + with isconv_context + (Γ,,, stack_context π1) (Γ,,, stack_context π2) + p1.(pcontext) p2.(pcontext) + hx + (fun leq Δh1 t1 Δh2 t2 eq1 eq2 ccr => + isconv_red + leq + t1 (Case_pred + ci1 + (pred_hole_context p1.(pparams) p1.(puinst) Δh1 p1.(preturn)) + c1 brs1 :: π1) + t2 (Case_pred + ci2 + (pred_hole_context p2.(pparams) p2.(puinst) Δh2 p2.(preturn)) + c2 brs2 :: π2) aux) := { + + | Error ce not_conv_ctx => no ce; + + | Success conv_ctx + with isconv_red_raw + Conv p1.(preturn) + (Case_pred ci1 (pred_hole_return p1.(pparams) p1.(puinst) p1.(pcontext)) + c1 brs1 :: π1) + p2.(preturn) + (Case_pred ci2 (pred_hole_return p2.(pparams) p2.(puinst) p2.(pcontext)) + c2 brs2 :: π2) + aux := { + + | Error ce not_conv_ret => no ce; + + | Success conv_ret => yes + } + } + } + }. + Next Obligation. + destruct p1; cbn in *; subst; auto. + Qed. + Next Obligation. + destruct p2; cbn in *; subst; auto. + Qed. + Next Obligation. + apply R_positionR. all: simpl. + 1: destruct p1; cbn in *; subst; reflexivity. + rewrite stack_position_cons. + rewrite <- app_nil_r. + eapply positionR_poscat. + constructor. + Qed. + Next Obligation. + destruct hΣ. + destruct hx as [hx]. + destruct ccr as [ccr]. + constructor. + apply conv_context_rel_app in ccr. + rewrite !app_context_assoc; auto. + apply conv_context_sym; auto. + eapply conv_context_trans; auto. + - apply conv_context_app_same. + apply conv_context_sym; auto. + eassumption. + - apply conv_context_sym; auto. + Qed. + Next Obligation. + unfold zipp in h; simpl in h. + rewrite app_context_assoc in h; auto. + Qed. + Next Obligation. + unfold zipp in h; simpl in h. + contradiction h. + rewrite app_context_assoc; auto. + Qed. + Next Obligation. + destruct p1; cbn in *; subst; auto. + Qed. + Next Obligation. + destruct p2; cbn in *; subst; auto. + Qed. + Next Obligation. + apply R_positionR. all: simpl. + 1: destruct p1; cbn in *; subst; reflexivity. + rewrite stack_position_cons. + rewrite <- app_nil_r. + eapply positionR_poscat. + constructor. + Qed. + Next Obligation. + destruct hΣ. + destruct hx as [hx]. + destruct conv_ctx as [ccr]. + constructor. + apply conv_context_rel_app in ccr. + rewrite !app_context_assoc; auto. + apply conv_context_sym; auto. + eapply conv_context_trans; auto. + - apply conv_context_app_same. + apply conv_context_sym; auto. + eassumption. + - apply conv_context_sym; auto. + Qed. + Next Obligation. + unfold zipp in conv_ret; simpl in conv_ret. + destruct conv_params as [conv_params], conv_ctx as [conv_ctx], conv_ret as [conv_ret]. + constructor. + split; auto. + apply eq_sym, eqb_universe_instance_spec in eq_insts. + split; auto. + split; auto. + rewrite app_context_assoc in conv_ret; auto. + Qed. + Next Obligation. + unfold zipp in not_conv_ret; simpl in not_conv_ret. + contradiction not_conv_ret. + rewrite app_context_assoc. + destruct H as [(?&?&?&?)]; constructor; auto. + Qed. + Next Obligation. + contradiction not_conv_ctx. + destruct H as [(?&?&?&?)]; constructor; auto. + Qed. + Next Obligation. + destruct hΣ. + zip fold in h1. + apply welltyped_context in h1 as (?&typ1); auto. + apply inversion_Case in typ1 as (?&?&?&?&[]&?); auto. + zip fold in h2. + clear aux. + apply welltyped_context in h2 as (?&typ2); auto. + apply inversion_Case in typ2 as (?&?&?&?&[]&?); auto. + apply consistent_instance_ext_wf in cons. + apply consistent_instance_ext_wf in cons0. + destruct H as [(?&?&?&?)]. + apply eqb_universe_instance_complete in r; auto. + congruence. + Qed. + Next Obligation. + contradiction not_conv_params. + destruct H as [(?&?&?&?)]; constructor; auto. + Qed. (* See https://github.com/coq/coq/blob/master/kernel/reduction.ml#L367 *) Opaque reduce_stack. @@ -2419,8 +2877,8 @@ Section Conversion. (* Unfold both constants at once *) | Error e h with inspect (lookup_env Σ c) := { | @exist (Some (ConstantDecl {| cst_body := Some body |})) eq3 := - isconv_red leq (subst_instance_constr u body) π1 - (subst_instance_constr u' body) π2 aux ; + isconv_red leq (subst_instance u body) π1 + (subst_instance u' body) π2 aux ; (* Inductive or not found *) | @exist _ _ := no (NotFoundConstant c) } @@ -2433,13 +2891,13 @@ Section Conversion. } ; | prog_view_Lambda na A1 t1 na' A2 t2 - with isconv_red_raw Conv A1 (Lambda_ty na t1 π1) - A2 (Lambda_ty na' t2 π2) aux := { + with isconv_red_raw Conv A1 (Lambda_ty na t1 :: π1) + A2 (Lambda_ty na' t2 :: π2) aux := { | Success h with inspect (eqb_binder_annot na na') := { | exist true _ := isconv_red leq - t1 (Lambda_tm na A1 π1) - t2 (Lambda_tm na' A2 π2) aux ; + t1 (Lambda_bd na A1 :: π1) + t2 (Lambda_bd na' A2 :: π2) aux ; | exist false e := no ( LambdaNotConvertibleAnn @@ -2455,12 +2913,12 @@ Section Conversion. } ; | prog_view_Prod na A1 B1 na' A2 B2 - with isconv_red_raw Conv A1 (Prod_l na B1 π1) A2 (Prod_l na' B2 π2) aux := { + with isconv_red_raw Conv A1 (Prod_l na B1 :: π1) A2 (Prod_l na' B2 :: π2) aux := { | Success h with inspect (eqb_binder_annot na na') := { | exist true _ := isconv_red leq - B1 (Prod_r na A1 π1) - B2 (Prod_r na' A2 π2) aux ; + B1 (Prod_r na A1 :: π1) + B2 (Prod_r na' A2 :: π2) aux ; | exist false e := no ( ProdNotConvertibleAnn @@ -2475,26 +2933,19 @@ Section Conversion. ) } ; - | prog_view_Case ind par p c brs ind' par' p' c' brs' + | prog_view_Case ci p c brs ci' p' c' brs' with inspect (reduce_term RedFlags.default Σ hΣ (Γ ,,, stack_context π1) c _) := { | @exist cred eq1 with inspect (eqb_term cred c) := { | @exist true eq2 with inspect (reduce_term RedFlags.default Σ hΣ (Γ ,,, stack_context π2) c' _) := { | @exist cred' eq3 with inspect (eqb_term cred' c') := { - | @exist true eq4 with inspect (eqb (ind, par) (ind', par')) := { - | @exist true eq5 with - isconv_red_raw Conv - p (Case_p (ind, par) c brs π1) - p' (Case_p (ind',par') c' brs' π2) - aux - := { - | Success h1 with - isconv_red_raw Conv - c (Case (ind, par) p brs π1) - c' (Case (ind', par') p' brs' π2) - aux - := { - | Success h2 with isconv_branches' Γ ind par p c brs π1 _ ind' par' p' c' brs' π2 _ _ _ _ aux := { - | Success h3 with isconv_args_raw leq (tCase (ind, par) p c brs) π1 (tCase (ind', par') p' c' brs') π2 aux := { + | @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 := { + | Success h1 with isconv_red_raw Conv + c (Case_discr ci p brs :: π1) + c' (Case_discr ci' p' brs' :: π2) aux := { + | Success h2 with isconv_branches' Γ ci p c brs π1 _ ci' p' c' brs' π2 _ _ _ aux := { + | Success h3 with isconv_args_raw leq (tCase ci p c brs) π1 (tCase ci' p' c' brs') π2 aux := { | Success h4 := yes ; | Error e h := no e } ; @@ -2507,21 +2958,21 @@ Section Conversion. | @exist false eq5 := no ( CaseOnDifferentInd - (Γ ,,, stack_context π1) ind par p c brs - (Γ ,,, stack_context π2) ind' par' p' c' brs' + (Γ ,,, stack_context π1) ci p c brs + (Γ ,,, stack_context π2) ci' p' c' brs' ) } ; | @exist false eq4 := isconv_red leq - (tCase (ind, par) p c brs) π1 - (tCase (ind', par') p' cred' brs') π2 + (tCase ci p c brs) π1 + (tCase ci' p' cred' brs') π2 aux } } ; | @exist false eq3 := isconv_red leq - (tCase (ind, par) p cred brs) π1 - (tCase (ind', par') p' c' brs') π2 + (tCase ci p cred brs) π1 + (tCase ci' p' c' brs') π2 aux } } ; @@ -2531,7 +2982,7 @@ Section Conversion. | @exist true eq3 with inspect (reduce_term RedFlags.default Σ hΣ (Γ ,,, stack_context π2) c' _) := { | @exist cred' eq2 with inspect (eqb_term cred' c') := { | @exist true eq4 with inspect (eqb p p') := { - | @exist true eq5 with isconv_red_raw Conv c (Proj p π1) c' (Proj p' π2) aux := { + | @exist true eq5 with isconv_red_raw Conv c (Proj p :: π1) c' (Proj p' :: π2) aux := { | Success h1 := isconv_args leq (tProj p c) π1 (tProj p' c') π2 aux ; | Error e h := no e } ; @@ -2561,18 +3012,18 @@ Section Conversion. with inspect (unfold_one_fix Γ mfix idx π1 _) := { | @exist (Some (fn, θ)) eq1 with inspect (decompose_stack θ) := { | @exist (l', θ') eq2 - with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context θ') fn (appstack l' ε) _) := { + with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context θ') fn (appstack l' []) _) := { | @exist (fn', ρ) eq3 := - isconv_prog leq fn' (ρ +++ θ') (tFix mfix' idx') π2 aux + isconv_prog leq fn' (ρ ++ θ') (tFix mfix' idx') π2 aux } } ; | _ with inspect (unfold_one_fix Γ mfix' idx' π2 _) := { | @exist (Some (fn, θ)) eq1 with inspect (decompose_stack θ) := { | @exist (l', θ') eq2 - with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context θ') fn (appstack l' ε) _) := { + with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context θ') fn (appstack l' []) _) := { | @exist (fn', ρ) eq3 := - isconv_prog leq (tFix mfix idx) π1 fn' (ρ +++ θ') aux + isconv_prog leq (tFix mfix idx) π1 fn' (ρ ++ θ') aux } } ; | _ with inspect (eqb idx idx') := { @@ -2674,6 +3125,7 @@ Section Conversion. Next Obligation. apply h; clear h. rewrite !zipp_as_mkApps in H. + destruct hΣ. apply conv_cum_mkApps_inv in H as [(?&?)]; eauto. - now constructor. - apply whnf_mkApps. @@ -2700,12 +3152,12 @@ Section Conversion. Next Obligation. unshelve eapply R_positionR. - reflexivity. - - simpl. rewrite <- app_nil_r. eapply positionR_poscat. constructor. + - simpl. rewrite <- app_nil_r, stack_position_cons. eapply positionR_poscat. constructor. Qed. Next Obligation. unshelve eapply R_positionR. - reflexivity. - - simpl. rewrite <- app_nil_r. eapply positionR_poscat. constructor. + - simpl. rewrite <- app_nil_r, stack_position_cons. eapply positionR_poscat. constructor. Qed. Next Obligation. destruct hx as [hx]. @@ -2748,7 +3200,7 @@ Section Conversion. simpl_stacks. destruct hΣ. apply Lambda_conv_cum_inv in H as (?&?&?); auto. - eapply (ssrbool.elimF (eq_binder_annot_reflect _ _)); tea. + eapply (ssrbool.elimF (eqb_annot_reflect _ _)) in e0; auto. Qed. Next Obligation. (* Contrapositive of previous obligation *) @@ -2766,12 +3218,12 @@ Section Conversion. Next Obligation. unshelve eapply R_positionR. - reflexivity. - - simpl. rewrite <- app_nil_r. eapply positionR_poscat. constructor. + - simpl. rewrite <- app_nil_r, stack_position_cons. eapply positionR_poscat. constructor. Qed. Next Obligation. unshelve eapply R_positionR. - simpl. reflexivity. - - simpl. rewrite <- app_nil_r. eapply positionR_poscat. constructor. + - simpl. rewrite <- app_nil_r, stack_position_cons. eapply positionR_poscat. constructor. Qed. Next Obligation. destruct hx as [hx]. @@ -2824,7 +3276,7 @@ Section Conversion. apply mkApps_Prod_nil in h2; auto. rewrite h1, h2 in H. apply Prod_conv_cum_inv in H as (?&?&?); auto. - eapply (ssrbool.elimF (eq_binder_annot_reflect _ _)); tea. + eapply (ssrbool.elimF (eqb_annot_reflect _ _)); tea. now unfold eqb_binder_annot. Qed. Next Obligation. @@ -2841,15 +3293,13 @@ Section Conversion. rewrite h1, h2 in H. apply Prod_conv_cum_inv in H as (?&?&_); auto. Qed. - (* tCase *) Next Obligation. destruct hΣ as [wΣ]. zip fold in h1. apply welltyped_context in h1 ; auto. simpl in h1. destruct h1 as [T h1]. apply inversion_Case in h1 as hh ; auto. - destruct hh as [uni [args [mdecl [idecl [ps [pty [btys - [? [? [? [? [? [? [ht0 [? ?]]]]]]]]]]]]]]]. + destruct hh as [mdecl [idecl [isdecl [indices [[] cum]]]]]. eexists. eassumption. Qed. Next Obligation. @@ -2858,32 +3308,18 @@ Section Conversion. zip fold in h2. apply welltyped_context in h2 ; auto. simpl in h2. destruct h2 as [T h2]. apply inversion_Case in h2 as hh ; auto. - destruct hh as [uni [args [mdecl [idecl [ps [pty [btys - [? [? [? [? [? [? [ht0 [? ?]]]]]]]]]]]]]]]. + destruct hh as [mdecl [idecl [isdecl [indices [[] cum]]]]]. eexists. eassumption. Qed. Next Obligation. eapply R_positionR. all: simpl. 1: reflexivity. - rewrite <- app_nil_r. - eapply positionR_poscat. constructor. - Qed. - Next Obligation. - eapply R_positionR. all: simpl. - 1: reflexivity. - rewrite <- app_nil_r. + rewrite <- app_nil_r, stack_position_cons. eapply positionR_poscat. constructor. Qed. Next Obligation. - change (eq_inductive ind ind') with (eqb ind ind') in eq5. - destruct (eqb_spec ind ind'). 2: discriminate. - assumption. - Qed. - Next Obligation. - change (eq_inductive ind ind') with (eqb ind ind') in eq5. - destruct (eqb_spec ind ind'). 2: discriminate. - change (Nat.eqb par par') with (eqb par par') in eq5. - destruct (eqb_spec par par'). 2: discriminate. + change (eq_dec_to_bool ci ci') with (eqb ci ci') in eq5. + destruct (eqb_spec ci ci'). 2: discriminate. assumption. Qed. Next Obligation. @@ -2898,36 +3334,33 @@ Section Conversion. pose proof hΣ as wΣ. destruct wΣ. eapply conv_conv_cum. constructor. - change (eq_inductive ind ind') with (eqb ind ind') in eq5. - destruct (eqb_spec ind ind'). 2: discriminate. - change (Nat.eqb par par') with (eqb par par') in eq5. - destruct (eqb_spec par par'). 2: discriminate. - subst. - eapply conv_Case. all: assumption. + change (eq_dec_to_bool ci ci') with (eqb ci ci') in eq5. + destruct (eqb_spec ci ci'). 2: discriminate. + subst. eapply conv_Case. all: tas. Qed. Next Obligation. apply h; clear h. - eapply inv_reduced_discriminees_case in H as [([= <- <-]&?&?&?&?)]; eauto. + eapply inv_reduced_discriminees_case in H as [(<-&?&?&?&?)]; eauto. constructor; auto. Qed. Next Obligation. apply h; cbn; clear h. - eapply inv_reduced_discriminees_case in H as [([= <- <-]&?&?&?&?)]; eauto. + eapply inv_reduced_discriminees_case in H as [(<-&?&?&?&?)]; eauto. constructor; auto. Qed. Next Obligation. apply h; cbn; clear h. - eapply inv_reduced_discriminees_case in H as [([= <- <-]&?&?&?&?)]; eauto. + eapply inv_reduced_discriminees_case in H as [(<-&?&?&?&?)]; eauto. constructor; auto. Qed. Next Obligation. apply h; cbn; clear h. - eapply inv_reduced_discriminees_case in H as [([= <- <-]&?&?&?&?)]; eauto. + eapply inv_reduced_discriminees_case in H as [(<-&?&?&?&?)]; eauto. constructor; auto. Qed. Next Obligation. - eapply inv_reduced_discriminees_case in H as [([= <- <-]&?&?&?&?)]; eauto. - rewrite eq_inductive_refl, Nat.eqb_refl in eq5. + eapply inv_reduced_discriminees_case in H as [(<-&?&?&?&?)]; eauto. + rewrite eq_dec_to_bool_refl in eq5. congruence. Qed. Next Obligation. @@ -2939,16 +3372,12 @@ Section Conversion. end. constructor. eapply red_zipc. - eapply red_case. - + reflexivity. - + assumption. - + clear. - induction brs' ; eauto. + eapply red_case_c; auto. Qed. Next Obligation. match goal with | |- context [ reduce_term ?f ?Σ ?hΣ ?Γ c' ?h ] => - destruct (reduce_stack_Req f Σ hΣ Γ c' ε h) as [e' | hr] + destruct (reduce_stack_Req f Σ hΣ Γ c' [] h) as [e' | hr] end. 1:{ exfalso. @@ -3001,6 +3430,7 @@ Section Conversion. apply red_case_c. exact r. Qed. + Next Obligation. eapply red_welltyped ; auto. - exact h1. @@ -3010,16 +3440,12 @@ Section Conversion. end. constructor. eapply red_zipc. - eapply red_case. - + reflexivity. - + assumption. - + clear. - induction brs ; eauto. + apply red_case_c; auto. Qed. Next Obligation. match goal with | |- context [ reduce_term ?f ?Σ ?hΣ ?Γ c ?h ] => - destruct (reduce_stack_Req f Σ hΣ Γ c ε h) as [e' | hr] + destruct (reduce_stack_Req f Σ hΣ Γ c [] h) as [e' | hr] end. 1:{ exfalso. @@ -3087,7 +3513,7 @@ Section Conversion. Next Obligation. eapply R_aux_positionR. all: simpl. - reflexivity. - - rewrite <- app_nil_r. apply positionR_poscat. constructor. + - rewrite <- app_nil_r, stack_position_cons. apply positionR_poscat. constructor. Qed. Next Obligation. unshelve eapply R_stateR. @@ -3136,7 +3562,7 @@ Section Conversion. Next Obligation. match goal with | |- context [ reduce_term ?f ?Σ ?hΣ ?Γ c' ?h ] => - destruct (reduce_stack_Req f Σ hΣ Γ c' ε h) as [e' | hr] + destruct (reduce_stack_Req f Σ hΣ Γ c' [] h) as [e' | hr] end. 1:{ exfalso. @@ -3209,7 +3635,7 @@ Section Conversion. Next Obligation. match goal with | |- context [ reduce_term ?f ?Σ ?hΣ ?Γ c ?h ] => - destruct (reduce_stack_Req f Σ hΣ Γ c ε h) as [e' | hr] + destruct (reduce_stack_Req f Σ hΣ Γ c [] h) as [e' | hr] end. 1:{ exfalso. @@ -3308,7 +3734,7 @@ Section Conversion. rewrite <- eq3 in r2. eapply R_cored. simpl. eapply red_cored_cored ; try eassumption. - apply red_context in r2. cbn in r2. + apply red_context_zip in r2. cbn in r2. rewrite zipc_stack_cat. pose proof (decompose_stack_eq _ _ _ (eq_sym eq2)). subst. rewrite zipc_appstack in r2. cbn in r2. @@ -3377,7 +3803,7 @@ Section Conversion. case_eq (decompose_stack ρ). intros l ξ e. rewrite e in d2. cbn in d2. subst. pose proof (red_welltyped _ hΣ h2 r1) as hh. - apply red_context in r2. + apply red_context_zip in r2. pose proof (decompose_stack_eq _ _ _ (eq_sym eq2)). subst. rewrite zipc_appstack in hh. cbn in r2. pose proof (red_welltyped _ hΣ hh (sq r2)) as hh'. @@ -3398,7 +3824,7 @@ Section Conversion. pose proof (decompose_stack_eq _ _ _ (eq_sym eq2)). subst. rewrite zipc_appstack in r2. cbn in r2. rewrite zipc_appstack. - do 2 zip fold. eapply red_context. + do 2 zip fold. eapply red_context_zip. assumption. Qed. Next Obligation. @@ -3543,16 +3969,16 @@ Section Conversion. Definition Aux' Γ t1 args1 l1 π1 t2 π2 h2 := forall u1 u2 ca1 a1 ρ2 - (h1' : wtp Γ u1 (coApp (mkApps t1 ca1) (appstack a1 π1))) + (h1' : wtp Γ u1 (App_r (mkApps t1 ca1) :: appstack a1 π1)) (h2' : wtp Γ u2 ρ2), let x := - mkpack Γ Reduction u1 (coApp (mkApps t1 ca1) (appstack a1 π1)) u2 ρ2 h2' + mkpack Γ Reduction u1 (App_r (mkApps t1 ca1) :: (appstack a1 π1)) u2 ρ2 h2' in let y := mkpack Γ Args (mkApps t1 args1) (appstack l1 π1) t2 π2 h2 in (S #|ca1| + #|a1| = #|args1| + #|l1|)%nat -> pzt x = pzt y /\ positionR (` (pps1 x)) (` (pps1 y)) -> - Ret Reduction Γ u1 (coApp (mkApps t1 ca1) (appstack a1 π1)) u2 ρ2. + Ret Reduction Γ u1 (App_r (mkApps t1 ca1) :: (appstack a1 π1)) u2 ρ2. Equations(noeqns) _isconv_args' (leq : conv_pb) (Γ : context) (t1 : term) (args1 : list term) @@ -3567,7 +3993,7 @@ Section Conversion. (aux : Aux' Γ t1 args1 l1 π1 t2 (appstack l2 π2) h2) : ConversionResult (∥conv_terms Σ (Γ,,, stack_context π1) l1 l2∥) by struct l1 := _isconv_args' leq Γ t1 args1 (u1 :: l1) π1 h1 hπ1 t2 (u2 :: l2) π2 h2 hπ2 hx aux - with aux u1 u2 args1 l1 (coApp t2 (appstack l2 π2)) _ _ _ _ Conv _ I I I := { + with aux u1 u2 args1 l1 (App_r t2 :: (appstack l2 π2)) _ _ _ _ Conv _ I I I := { | Success H1 with _isconv_args' leq Γ t1 (args1 ++ [u1]) l1 π1 _ _ (tApp t2 u2) l2 π2 _ _ _ _ := { | Success H2 := yes ; | Error e herr := @@ -3606,6 +4032,7 @@ Section Conversion. Qed. Next Obligation. split. 1: reflexivity. + rewrite !stack_position_cons. eapply positionR_poscat. constructor. Defined. Next Obligation. @@ -3623,16 +4050,17 @@ Section Conversion. - instantiate (1 := h2'). simpl. split. + rewrite <- mkApps_nested in eq. assumption. + subst x y. - rewrite 2!stack_position_appstack. + rewrite !stack_position_cons, !stack_position_appstack. rewrite <- !app_assoc. apply positionR_poscat. - assert (h' : forall n m, positionR (list_make n app_l ++ [app_r]) (list_make m app_l)). + assert (h' : forall n m, positionR (repeat app_l n ++ [app_r]) (repeat app_l m)). { clear. intro n. induction n ; intro m. - destruct m ; constructor. - destruct m. + constructor. + cbn. constructor. apply IHn. } - rewrite <- list_make_app_r. + simpl. + rewrite <- repeat_snoc. apply (h' #|a1| (S #|l1|)). Defined. Next Obligation. @@ -3718,18 +4146,20 @@ Section Conversion. Obligation Tactic := Tactics.program_simplify; CoreTactics.equations_simpl; try Tactics.program_solve_wf. - Equations unfold_one_case (Γ : context) (ind : inductive) (par : nat) - (p c : term) (brs : list (nat × term)) - (h : welltyped Σ Γ (tCase (ind, par) p c brs)) : option term := - unfold_one_case Γ ind par p c brs h - with inspect (reduce_stack RedFlags.default Σ hΣ Γ c ε _) := { + Equations unfold_one_case (Γ : context) (ci : case_info) + (p : predicate term) (c : term) (brs : list (branch term)) + (h : welltyped Σ Γ (tCase ci p c brs)) : option term := + unfold_one_case Γ ci p c brs h + with inspect (reduce_stack RedFlags.default Σ hΣ Γ c [] _) := { | @exist (cred, ρ) eq with cc_viewc cred := { | ccview_construct ind' n ui with inspect (decompose_stack ρ) := { - | @exist (args, ξ) eq' := Some (iota_red par n args brs) + | @exist (args, ξ) eq' with inspect (nth_error brs n) := { + | exist (Some br) eqbr := Some (iota_red ci.(ci_npar) args br) ; + | exist None eqbr := False_rect _ _ } } ; | ccview_cofix mfix idx with inspect (unfold_cofix mfix idx) := { | @exist (Some (narg, fn)) eq2 with inspect (decompose_stack ρ) := { - | @exist (args, ξ) eq' := Some (tCase (ind, par) p (mkApps fn args) brs) + | @exist (args, ξ) eq' := Some (tCase ci p (mkApps fn args) brs) } ; | @exist None eq2 := False_rect _ _ } ; @@ -3740,50 +4170,70 @@ Section Conversion. destruct hΣ as [wΣ]. cbn. destruct h as [T h]. apply inversion_Case in h ; auto. - destruct h as [uni [args [mdecl [idecl [ps [pty [btys - [? [? [? [? [? [? [ht0 [? ?]]]]]]]]]]]]]]]. + destruct h as [mdecl [idecl [isdecl [indices [[] cum]]]]]. eexists. eassumption. Qed. + Next Obligation. + simpl_reduce_stack. + destruct hΣ. + assert (r' : ∥ red Σ Γ (tCase ci p c brs) + (tCase ci p (mkApps (tConstruct ind' n ui) (decompose_stack ρ).1) brs) ∥). + { constructor. eapply red_case_c. eassumption. } + pose proof (red_welltyped _ hΣ h r') as h'. + destruct h'. + apply PCUICInductiveInversion.invert_Case_Construct in X0 as (?&?&?&?); auto. + congruence. + Qed. + Next Obligation. exfalso. simpl_reduce_stack. destruct h as (?&typ); auto. destruct hΣ. - apply inversion_Case in typ as (?&?&?&?&?&?&?&?&?&?&?&?&?&?&?&?&?); auto. - eapply PCUICSR.subject_reduction in t0; eauto. - apply PCUICValidity.inversion_mkApps in t0 as (?&?&?); auto. - apply inversion_CoFix in t0 as (?&?&?&?&?&?&?); auto. + apply inversion_Case in typ as [mdecl [idecl [isdecl [indices [[] cum]]]]]; auto. + eapply PCUICSR.subject_reduction in scrut_ty; eauto. + apply PCUICValidity.inversion_mkApps in scrut_ty as (?&typ&?); auto. + apply inversion_CoFix in typ as (?&?&?&?&?&?&?); auto. unfold unfold_cofix in eq2. - rewrite e3 in eq2. + rewrite e in eq2. congruence. Qed. Lemma unfold_one_case_cored : - forall Γ ind par p c brs h t, - Some t = unfold_one_case Γ ind par p c brs h -> - cored Σ Γ t (tCase (ind, par) p c brs). + forall Γ ci p c brs h t, + Some t = unfold_one_case Γ ci p c brs h -> + cored Σ Γ t (tCase ci p c brs). Proof. - intros Γ ind par p c brs h t e. + intros Γ ci p c brs h t e. revert e. - funelim (unfold_one_case Γ ind par p c brs h). + funelim (unfold_one_case Γ ci p c brs h). all: intros eq ; noconf eq. - - clear H H0. + - clear H H0 H1. simpl_reduce_stack. - assert (r' : ∥ red Σ Γ (tCase (ind, par) p c brs) - (tCase (ind, par) p (mkApps (tConstruct ind0 n ui) (decompose_stack s).1) brs) ∥). + assert (r' : ∥ red Σ Γ (tCase ci p c brs) + (tCase ci p (mkApps (tConstruct ind n ui) (decompose_stack s).1) brs) ∥). { constructor. eapply red_case_c. eassumption. } pose proof (red_welltyped _ hΣ h r') as h'. eapply Case_Construct_ind_eq in h' ; eauto. subst. eapply cored_red_cored. - + constructor. eapply red_iota. + + constructor. eapply red_iota. 1: now symmetry. + destruct h as (?&typ). + destruct r' as [r']. + destruct hΣ. + eapply PCUICSR.subject_reduction in typ; eauto. + apply PCUICInductiveInversion.invert_Case_Construct in typ as (?&?&?&?); auto. + rewrite H0 in e1; noconf e1. + rewrite skipn_length; lia. + eapply red_case_c. eassumption. - match type of eq with | _ = False_rect _ ?f => destruct f end. + - clear H H0. revert eq. + destruct unfold_one_case_obligations_obligation_3. - clear H H0 H1. simpl_reduce_stack. - assert (r' : ∥ red Σ Γ (tCase (ind, par) p c brs) - (tCase (ind, par) p (mkApps (tCoFix mfix idx) (decompose_stack s).1) brs) ∥). + assert (r' : ∥ red Σ Γ (tCase ci p c brs) + (tCase ci p (mkApps (tCoFix mfix idx) (decompose_stack s).1) brs) ∥). { constructor. eapply red_case_c. eassumption. } pose proof (red_welltyped _ hΣ h r') as h'. eapply cored_red_cored. @@ -3791,11 +4241,11 @@ Section Conversion. + eapply red_case_c. eassumption. Qed. - Lemma unfold_one_case_None Γ ind par p c brs h : - None = unfold_one_case Γ ind par p c brs h -> + Lemma unfold_one_case_None Γ ci p c brs h : + None = unfold_one_case Γ ci p c brs h -> ∥∑ c', red Σ Γ c c' × whne RedFlags.default Σ Γ c'∥. Proof. - funelim (unfold_one_case Γ ind par p c brs h); intros [=]. + funelim (unfold_one_case Γ ci p c brs h); intros [=]. - clear H. simpl_reduce_stack. destruct h as (?&typ); auto. @@ -3808,6 +4258,9 @@ Section Conversion. 2: eapply red_case_c; eauto. eapply whnf_case_arg_whne; eauto. now destruct t0. + - match type of H3 with + | _ = False_rect _ ?f => destruct f + end. - match type of H2 with | _ = False_rect _ ?f => destruct f end. @@ -3817,7 +4270,7 @@ Section Conversion. (h : welltyped Σ Γ (tProj p c)) : option term := unfold_one_proj Γ p c h with p := { - | (i, pars, narg) with inspect (reduce_stack RedFlags.default Σ hΣ Γ c ε _) := { + | (i, pars, narg) with inspect (reduce_stack RedFlags.default Σ hΣ Γ c [] _) := { | @exist (cred, ρ) eq with cc0_viewc cred := { | cc0view_construct ind' ui with inspect (decompose_stack ρ) := { | @exist (args, ξ) eq' with inspect (nth_error args (pars + narg)) := { @@ -3930,8 +4383,8 @@ Section Conversion. reducible_head Γ (tFix mfix idx) π h := unfold_one_fix Γ mfix idx π h ; - reducible_head Γ (tCase (ind, par) p c brs) π h - with inspect (unfold_one_case (Γ ,,, stack_context π) ind par p c brs _) := { + reducible_head Γ (tCase ci p c brs) π h + with inspect (unfold_one_case (Γ ,,, stack_context π) ci p c brs _) := { | @exist (Some t) eq :=Some (t, π) ; | @exist None _ := None } ; @@ -3945,7 +4398,7 @@ Section Conversion. reducible_head Γ (tConst c u) π h with inspect (lookup_env Σ c) := { | @exist (Some (ConstantDecl {| cst_body := Some body |})) eq := - Some (subst_instance_constr u body, π) ; + Some (subst_instance u body, π) ; | @exist _ _ := None } ; @@ -4155,9 +4608,9 @@ Section Conversion. unfold declared_constant in d; congruence. - clear H. apply unfold_one_case_None in e as [(c'&r&whcase)]. - constructor; exists (tCase (i, n) p c' brs), (decompose_stack π).1. + constructor; exists (tCase indn p c' brs), (decompose_stack π).1. split. - + constructor; eauto with pcuic. + + destruct p. constructor; eauto with pcuic. + split; [eauto with pcuic|]. apply whnf_mkApps. auto. @@ -4184,17 +4637,17 @@ Section Conversion. with inspect (reducible_head Γ t1 π1 h1) := { | @exist (Some (rt1, ρ1)) eq1 with inspect (decompose_stack ρ1) := { | @exist (l1, θ1) eq2 - with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context ρ1) rt1 (appstack l1 ε) _) := { + with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context ρ1) rt1 (appstack l1 []) _) := { | @exist (rt1', θ1') eq3 := - isconv_prog leq rt1' (θ1' +++ θ1) t2 π2 aux + isconv_prog leq rt1' (θ1' ++ θ1) t2 π2 aux } } ; | @exist None nored1 with inspect (reducible_head Γ t2 π2 h2) := { | @exist (Some (rt2, ρ2)) eq1 with inspect (decompose_stack ρ2) := { | @exist (l2, θ2) eq2 - with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context ρ2) rt2 (appstack l2 ε) _) := { + with inspect (reduce_stack RedFlags.nodelta Σ hΣ (Γ ,,, stack_context ρ2) rt2 (appstack l2 []) _) := { | @exist (rt2', θ2') eq3 := - isconv_prog leq t1 π1 rt2' (θ2' +++ θ2) aux + isconv_prog leq t1 π1 rt2' (θ2' ++ θ2) aux } } ; | @exist None nored2 with inspect (eqb_termp_napp Σ G leq #|(decompose_stack π1).1| t1 t2) := { @@ -4223,7 +4676,7 @@ Section Conversion. destruct r1 as [r1]. simpl_reduce_stack. eapply red_welltyped ; auto ; revgoals. - - constructor. zip fold. eapply red_context. simpl_stacks. eassumption. + - constructor. zip fold. eapply red_context_zip. simpl_stacks. eassumption. - cbn. simpl_stacks. eapply red_welltyped ; auto ; revgoals. + constructor. eassumption. @@ -4255,7 +4708,7 @@ Section Conversion. rewrite 2!zipc_appstack in r1. rewrite stack_context_appstack in r2. eapply red_cored_cored ; try eassumption. - repeat zip fold. eapply red_context. assumption. + repeat zip fold. eapply red_context_zip. assumption. Qed. Next Obligation. apply reducible_head_decompose in eq1 as d1. @@ -4319,7 +4772,7 @@ Section Conversion. apply decompose_stack_eq in eq2'. subst. rewrite stack_context_appstack in r2. eapply red_welltyped ; auto ; revgoals. - - constructor. zip fold. eapply red_context. eassumption. + - constructor. zip fold. eapply red_context_zip. eassumption. - rewrite zipc_appstack in r1. cbn. eapply red_welltyped ; auto ; revgoals. + constructor. eassumption. @@ -4351,7 +4804,7 @@ Section Conversion. rewrite 2!zipc_appstack in r1. rewrite stack_context_appstack in r2. eapply red_cored_cored ; try eassumption. - repeat zip fold. eapply red_context. assumption. + repeat zip fold. eapply red_context_zip. assumption. Qed. Next Obligation. apply reducible_head_decompose in eq1 as d1. @@ -4466,8 +4919,8 @@ Section Conversion. destruct h2 as (?&typ2); auto. apply inversion_Ind in typ1 as (?&?&?&?&?&?); auto. apply inversion_Ind in typ2 as (?&?&?&?&?&?); auto. - apply consistent_instance_ext_all_mem in c1. - apply consistent_instance_ext_all_mem in c. + apply consistent_instance_ext_wf in c1. + apply consistent_instance_ext_wf in c. apply compare_global_instance_complete in H3; auto. rewrite eq_inductive_refl in noteq. apply All2_length in rargs1. @@ -4486,8 +4939,8 @@ Section Conversion. destruct h2 as (?&typ2); auto. apply inversion_Construct in typ1 as (?&?&?&?&?&?&?); auto. apply inversion_Construct in typ2 as (?&?&?&?&?&?&?); auto. - apply consistent_instance_ext_all_mem in c1. - apply consistent_instance_ext_all_mem in c. + apply consistent_instance_ext_wf in c1. + apply consistent_instance_ext_wf in c. apply compare_global_instance_complete in H4; auto. rewrite eq_inductive_refl, Nat.eqb_refl in noteq. apply All2_length in rargs1. @@ -4519,6 +4972,7 @@ Section Conversion. apply inversion_Sort in h2 as (_&h2&_); auto. apply inversion_Sort in h1 as (_&h1&_); auto. eapply conv_pb_relb_complete in H0; eauto. + congruence. - now rewrite eq_dec_to_bool_refl in noteq. Qed. @@ -4601,7 +5055,7 @@ Section Conversion. Qed. Definition isconv_term Γ leq t1 (h1 : welltyped Σ Γ t1) t2 (h2 : welltyped Σ Γ t2) := - isconv Γ leq t1 ε h1 t2 ε h2 (sq (conv_ctx_refl _ Γ)). + isconv Γ leq t1 [] h1 t2 [] h2 (sq (conv_ctx_refl _ Γ)). Theorem isconv_term_sound : forall Γ leq t1 h1 t2 h2, diff --git a/safechecker/theories/PCUICSafeReduce.v b/safechecker/theories/PCUICSafeReduce.v index 5f72d038f..e54cb02cf 100644 --- a/safechecker/theories/PCUICSafeReduce.v +++ b/safechecker/theories/PCUICSafeReduce.v @@ -198,9 +198,6 @@ Section Reduce. Context (Σ : global_env_ext). Context (hΣ : ∥ wf Σ ∥). - Derive NoConfusion NoConfusionHom for option. - Derive NoConfusion NoConfusionHom for context_decl. - Existing Instance Req_refl. Definition inspect {A} (x : A) : { y : A | y = x } := exist x eq_refl. @@ -238,22 +235,23 @@ Section Reduce. let C' := context C[ zip (t,π) ] in change C' end. - + Lemma Req_red : forall Γ x y, Req Σ Γ y x -> ∥ red Σ Γ (zip x) (zip y) ∥. Proof. - intros Γ [t π] [t' π'] h. cbn. + intros Γ [t π] [t' π'] h; simpl. dependent destruction h. - repeat zip fold. rewrite H. constructor. reflexivity. - dependent destruction H. + eapply cored_red. assumption. - + cbn in H0. inversion H0. + + simpl in H0. inversion H0. constructor. reflexivity. Qed. + (* Show Obligation Tactic. *) Ltac obTac := (* program_simpl ; *) @@ -282,7 +280,7 @@ Section Reduce. red_discr (tLetIn _ _ _ _) _ := False ; red_discr (tConst _ _) _ := False ; red_discr (tApp _ _) _ := False ; - red_discr (tLambda _ _ _) (App _ _) := False ; + red_discr (tLambda _ _ _) (App_l _ :: _) := False ; red_discr (tFix _ _) _ := False ; red_discr (tCase _ _ _ _) _ := False ; red_discr (tProj _ _) _ := False ; @@ -293,9 +291,9 @@ Section Reduce. | red_view_LetIn A b B c π : red_view (tLetIn A b B c) π | red_view_Const c u π : red_view (tConst c u) π | red_view_App f a π : red_view (tApp f a) π - | red_view_Lambda na A t a args : red_view (tLambda na A t) (App a args) + | red_view_Lambda na A t a args : red_view (tLambda na A t) (App_l a :: args) | red_view_Fix mfix idx π : red_view (tFix mfix idx) π - | red_view_Case ind par p c brs π : red_view (tCase (ind, par) p c brs) π + | red_view_Case ci p c brs π : red_view (tCase ci p c brs) π | red_view_Proj p c π : red_view (tProj p c) π | red_view_other t π : red_discr t π -> red_view t π. @@ -304,9 +302,9 @@ Section Reduce. red_viewc (tLetIn A b B c) π := red_view_LetIn A b B c π ; red_viewc (tConst c u) π := red_view_Const c u π ; red_viewc (tApp f a) π := red_view_App f a π ; - red_viewc (tLambda na A t) (App a args) := red_view_Lambda na A t a args ; + red_viewc (tLambda na A t) (App_l a :: args) := red_view_Lambda na A t a args ; red_viewc (tFix mfix idx) π := red_view_Fix mfix idx π ; - red_viewc (tCase (ind, par) p c brs) π := red_view_Case ind par p c brs π ; + red_viewc (tCase ci p c brs) π := red_view_Case ci p c brs π ; red_viewc (tProj p c) π := red_view_Proj p c π ; red_viewc t π := red_view_other t π I. @@ -339,7 +337,7 @@ Section Reduce. cc0_viewc (tConstruct ind 0 ui) := cc0view_construct ind ui ; cc0_viewc (tCoFix mfix idx) := cc0view_cofix mfix idx ; cc0_viewc t := cc0view_other t _. - + Equations _reduce_stack (Γ : context) (t : term) (π : stack) (h : welltyped Σ Γ (zip (t,π))) (reduce : forall t' π', R Σ Γ (t',π') (t,π) -> @@ -367,7 +365,7 @@ Section Reduce. | red_view_Const c u π with RedFlags.delta flags := { | true with inspect (lookup_env (fst Σ) c) := { | @exist (Some (ConstantDecl {| cst_body := Some body |})) eq := - let body' := subst_instance_constr u body in + let body' := subst_instance u body in rec reduce body' π ; | @exist (Some (InductiveDecl _)) eq := False_rect _ _ ; | @exist (Some _) eq := give (tConst c u) π ; @@ -376,25 +374,25 @@ Section Reduce. | _ := give (tConst c u) π } ; - | red_view_App f a π := rec reduce f (App a π) ; + | red_view_App f a π := rec reduce f (App_l a :: π) ; | red_view_Lambda na A t a args with inspect (RedFlags.beta flags) := { | @exist true eq1 := rec reduce (subst10 a t) args ; - | @exist false eq1 := give (tLambda na A t) (App a args) + | @exist false eq1 := give (tLambda na A t) (App_l a :: args) } ; | red_view_Fix mfix idx π with RedFlags.fix_ flags := { | true with inspect (unfold_fix mfix idx) := { | @exist (Some (narg, fn)) eq1 with inspect (decompose_stack_at π narg) := { - | @exist (Some (args, c, ρ)) eq2 with inspect (reduce c (Fix mfix idx args ρ) _) := { + | @exist (Some (args, c, ρ)) eq2 with inspect (reduce c (Fix_app mfix idx args :: ρ) _) := { | @exist (@exist (t, ρ') prf) eq3 with construct_viewc t := { | view_construct ind n ui with inspect (decompose_stack ρ') := { | @exist (l, θ) eq4 := - rec reduce fn (appstack args (App (mkApps (tConstruct ind n ui) l) ρ)) + rec reduce fn (appstack args (App_l (mkApps (tConstruct ind n ui) l) :: ρ)) } ; | view_other t ht with inspect (decompose_stack ρ') := { | @exist (l, θ) eq4 := - give (tFix mfix idx) (appstack args (App (mkApps t l) ρ)) + give (tFix mfix idx) (appstack args (App_l (mkApps t l) :: ρ)) } } } ; @@ -405,25 +403,27 @@ Section Reduce. | false := give (tFix mfix idx) π } ; - | red_view_Case ind par p c brs π with RedFlags.iota flags := { - | true with inspect (reduce c (Case (ind, par) p brs π) _) := { + | red_view_Case ci p c brs π with RedFlags.iota flags := { + | true with inspect (reduce c (Case_discr ci p brs :: π) _) := { | @exist (@exist (t,π') prf) eq with inspect (decompose_stack π') := { | @exist (args, ρ) prf' with cc_viewc t := { - | ccview_construct ind' c' _ := rec reduce (iota_red par c' args brs) π ; + | ccview_construct ind' c' inst' with inspect (nth_error brs c') := { + | exist (Some br) eqbr := rec reduce (iota_red ci.(ci_npar) args br) π ; + | exist None bot := False_rect _ _ } ; | ccview_cofix mfix idx with inspect (unfold_cofix mfix idx) := { | @exist (Some (narg, fn)) eq' := - rec reduce (tCase (ind, par) p (mkApps fn args) brs) π ; + rec reduce (tCase ci p (mkApps fn args) brs) π ; | @exist None bot := False_rect _ _ } ; - | ccview_other t ht := give (tCase (ind, par) p (mkApps t args) brs) π + | ccview_other t ht := give (tCase ci p (mkApps t args) brs) π } } } ; - | false := give (tCase (ind, par) p c brs) π + | false := give (tCase ci p c brs) π } ; | red_view_Proj (i, pars, narg) c π with RedFlags.iota flags := { - | true with inspect (reduce c (Proj (i, pars, narg) π) _) := { + | true with inspect (reduce c (Proj (i, pars, narg) :: π) _) := { | @exist (@exist (t,π') prf) eq with inspect (decompose_stack π') := { | @exist (args, ρ) prf' with cc0_viewc t := { | cc0view_construct ind' _ @@ -513,7 +513,8 @@ Section Reduce. (* tApp *) Next Obligation. right. - cbn. unfold posR. cbn. + simpl. unfold posR. simpl. + rewrite stack_position_cons. eapply positionR_poscat_nonil. discriminate. Qed. Next Obligation. @@ -545,7 +546,7 @@ Section Reduce. pose proof (decompose_stack_at_eq _ _ _ _ _ eq2). subst. eapply R_positionR. - cbn. rewrite zipc_appstack. cbn. reflexivity. - - cbn. rewrite stack_position_appstack. cbn. + - simpl. rewrite !stack_position_appstack, !stack_position_cons. simpl. rewrite <- app_assoc. eapply positionR_poscat. constructor. @@ -700,125 +701,90 @@ Section Reduce. (* tCase *) Next Obligation. - right. unfold posR. cbn. + right. unfold posR. simpl. + rewrite stack_position_cons. eapply positionR_poscat_nonil. discriminate. Qed. Next Obligation. + clear eq. + destruct hΣ. unfold Pr in p0. cbn in p0. pose proof p0 as hh. rewrite <- prf' in hh. cbn in hh. subst. - eapply R_Req_R. - - econstructor. econstructor. eapply red1_context. - eapply red_iota. - - instantiate (4 := ind'). instantiate (2 := p). - instantiate (1 := wildcard7). - destruct r. - + inversion e. - subst. - cbn in prf'. inversion prf'. subst. clear prf'. - cbn. - assert (ind = ind'). - { clear - h flags hΣ. - apply welltyped_context in h ; auto. - simpl in h. - eapply Case_Construct_ind_eq with (args := []) ; eauto. - } subst. - reflexivity. - + clear eq. dependent destruction r. - * cbn in H. - symmetry in prf'. - pose proof (decompose_stack_eq _ _ _ prf'). subst. - rewrite zipc_appstack in H. - cbn in H. - right. econstructor. - lazymatch goal with - | h : cored _ _ ?t _ |- _ => - assert (welltyped Σ Γ t) as h' - end. - { clear - h H flags hΣ. - eapply cored_welltyped ; try eassumption. - } - assert (ind = ind'). - { clear - h' flags hΣ H. - zip fold in h'. - apply welltyped_context in h'. 2: assumption. - cbn in h'. - apply Case_Construct_ind_eq in h'. all: eauto. - } subst. - exact H. - * cbn in H0. inversion H0. subst. clear H0. - symmetry in prf'. - pose proof (decompose_stack_eq _ _ _ prf'). subst. - rewrite zipc_appstack in H2. cbn in H2. - apply zipc_inj in H2. - inversion H2. subst. - assert (ind = ind'). - { clear - h flags H hΣ. - apply welltyped_context in h. 2: assumption. - cbn in h. - apply Case_Construct_ind_eq in h. all: eauto. - } subst. - reflexivity. + apply eq_sym, decompose_stack_eq in prf'; subst. + apply Req_red in r; cbn in r. + rewrite zipc_appstack in r. + cbn in r. + pose proof r as [r']. + eapply red_welltyped in r; eauto. + zip fold in r. + apply welltyped_context in r as (?&typ); auto; cbn in *. + apply PCUICInductiveInversion.invert_Case_Construct in typ as H; auto. + destruct H as (?&?&nth&?); subst. + rewrite nth in eqbr; noconf eqbr. + constructor. + eapply cored_red_cored; cycle 1. + - zip fold in r'; exact r'. + - constructor. + eapply red1_context. + eapply red_iota; eauto. + rewrite skipn_length; lia. Qed. Next Obligation. + clear eq. + destruct hΣ. unfold Pr in p0. cbn in p0. pose proof p0 as hh. rewrite <- prf' in hh. cbn in hh. subst. - dependent destruction r. - - inversion e. subst. - left. eapply cored_context. - constructor. - simpl in prf'. inversion prf'. subst. - eapply red_cofix_case with (args := []). eauto. - - clear eq. - dependent destruction r. - + left. - symmetry in prf'. apply decompose_stack_eq in prf' as ?. subst. - cbn in H. rewrite zipc_appstack in H. cbn in H. - eapply cored_trans' ; try eassumption. - zip fold. eapply cored_context. - constructor. eapply red_cofix_case. eauto. - + left. - cbn in H0. destruct y'. inversion H0. subst. clear H0. - symmetry in prf'. apply decompose_stack_eq in prf' as ?. subst. - rewrite zipc_appstack in H2. cbn in H2. - cbn. rewrite H2. - zip fold. eapply cored_context. - constructor. eapply red_cofix_case. eauto. + apply eq_sym, decompose_stack_eq in prf'; subst. + apply Req_red in r; cbn in r. + rewrite zipc_appstack in r. + cbn in r. + pose proof r as [r']. + eapply red_welltyped in r; eauto. + zip fold in r. + apply welltyped_context in r as (?&typ); auto; cbn in *. + apply PCUICInductiveInversion.invert_Case_Construct in typ as H; auto. + destruct H as (?&?&nth&?); subst. + rewrite nth in bot; congruence. Qed. Next Obligation. - destruct hΣ as [wΣ]. + clear eq. + destruct hΣ. unfold Pr in p0. cbn in p0. pose proof p0 as hh. rewrite <- prf' in hh. cbn in hh. subst. - assert (h' : welltyped Σ Γ (zip (tCase (ind, par) p (mkApps (tCoFix mfix idx) args) brs, π))). - { dependent destruction r. - - inversion e. subst. - simpl in prf'. inversion prf'. subst. - assumption. - - clear eq. dependent destruction r. - + apply cored_red in H. destruct H as [r]. - eapply red_welltyped ; eauto. - constructor. - symmetry in prf'. apply decompose_stack_eq in prf'. subst. - cbn in r. rewrite zipc_appstack in r. cbn in r. - assumption. - + cbn in H0. destruct y'. inversion H0. subst. clear H0. - symmetry in prf'. apply decompose_stack_eq in prf'. subst. - rewrite zipc_appstack in H2. cbn in H2. - cbn. rewrite <- H2. assumption. - } - replace (zip (tCase (ind, par) p (mkApps (tCoFix mfix idx) args) brs, π)) - with (zip (tCoFix mfix idx, appstack args (Case (ind, par) p brs π))) - in h'. - - destruct hΣ. - apply welltyped_context in h' ; auto. simpl in h'. - destruct h' as [T h']. - apply inversion_CoFix in h' ; auto. - destruct h' as [decl [? [e [? [? ?]]]]]. - unfold unfold_cofix in bot. - rewrite e in bot. discriminate. - - cbn. rewrite zipc_appstack. reflexivity. + apply eq_sym, decompose_stack_eq in prf'; subst. + apply Req_red in r; cbn in r. + rewrite zipc_appstack in r. + cbn in r. + pose proof r as [r']. + eapply red_welltyped in r; eauto. + zip fold in r. + apply welltyped_context in r as (?&typ); auto; cbn in *. + constructor. + eapply cored_red_cored; cycle 1. + - zip fold in r'; exact r'. + - constructor. + eapply red1_context. + eapply red_cofix_case; eauto. + Qed. + Next Obligation. + clear eq. + destruct hΣ. + unfold Pr in p0. cbn in p0. + pose proof p0 as hh. + rewrite <- prf' in hh. cbn in hh. subst. + apply eq_sym, decompose_stack_eq in prf'; subst. + apply Req_red in r; cbn in r. + pose proof r as [r']. + eapply red_welltyped in r; eauto. + zip fold in r. + apply welltyped_context in r as (?&typ); auto; cbn in *. + apply inversion_CoFix in typ as (?&?&?&?&?&?&?); auto. + unfold unfold_cofix in bot. + rewrite e in bot. + congruence. Qed. Next Obligation. clear eq reduce h. @@ -840,10 +806,11 @@ Section Reduce. apply zipc_inj in H2. inversion H2. subst. reflexivity. Qed. - + (* tProj *) Next Obligation. - right. unfold posR. cbn. + right. unfold posR. simpl. + rewrite stack_position_cons. rewrite <- app_nil_r. eapply positionR_poscat. constructor. @@ -928,7 +895,7 @@ Section Reduce. cbn. rewrite <- H2. assumption. } replace (zip (tProj (i, pars, narg) (mkApps (tCoFix mfix idx) args), π)) - with (zip (tCoFix mfix idx, appstack args (Proj (i, pars, narg) π))) + with (zip (tCoFix mfix idx, appstack args (Proj (i, pars, narg) :: π))) in h'. - destruct hΣ. apply welltyped_context in h' ; auto. simpl in h'. @@ -1105,7 +1072,7 @@ Section Reduce. Qed. Definition reduce_term Γ t (h : welltyped Σ Γ t) := - zip (reduce_stack Γ t ε h). + zip (reduce_stack Γ t [] h). Theorem reduce_term_sound : forall Γ t h, @@ -1113,7 +1080,7 @@ Section Reduce. Proof. intros Γ t h. unfold reduce_term. - refine (reduce_stack_sound _ _ ε _). + refine (reduce_stack_sound _ _ [] _). Qed. (* (* Potentially hard? Ok with SN? *) *) @@ -1209,8 +1176,7 @@ Section Reduce. induction l in l, n |- *; cbn in *. - rewrite nth_error_nil. split; intros; try easy. - unfold decompose_stack_at. - destruct s; easy. + destruct s as [|[]]; cbn in *; easy. - destruct n; [easy|]. cbn in *. split. @@ -1254,7 +1220,7 @@ Section Reduce. - exfalso; eapply invert_fix_ind; eauto. - apply typing_cofix_coind in typ; auto. unfold is_true in typ. - unfold PCUICAst.fst_ctx in *. + unfold PCUICAst.PCUICEnvironment.fst_ctx in *. congruence. - now eapply inversion_Prim in typ. Qed. @@ -1323,7 +1289,7 @@ Section Reduce. congruence. Qed. - Lemma whnf_case_arg_whne Γ hd args ind par p brs T : + Lemma whnf_case_arg_whne Γ hd args ci p brs T : wf Σ -> match hd with | tApp _ _ @@ -1332,20 +1298,20 @@ Section Reduce. | _ => True end -> whnf flags Σ Γ (mkApps hd args) -> - Σ;;; Γ |- tCase (ind, par) p (mkApps hd args) brs : T -> + Σ;;; Γ |- tCase ci p (mkApps hd args) brs : T -> whne flags Σ Γ (mkApps hd args). Proof. intros wf shape wh typ. - apply inversion_Case in typ as (?&?&?&?&?&?&?&?&?&?&?&?&?&?&?&?&?); auto. + apply inversion_Case in typ as (?&?&isdecl&?&[]&?); auto. eapply whnf_non_ctor_finite_ind_typed; try eassumption. - unfold isConstruct_app. now rewrite decompose_app_mkApps; destruct hd. - - unfold isCoFinite in e1. + - unfold isCoFinite in not_cofinite. unfold check_recursivity_kind. cbn. - unfold declared_inductive, declared_minductive in d. - cbn in d. - rewrite (proj1 d). + unfold declared_inductive, declared_minductive in isdecl. + cbn in isdecl. + rewrite (proj1 isdecl). now destruct ind_finite. Qed. @@ -1565,7 +1531,7 @@ Section Reduce. try rewrite stack_context_appstack in typ; try rewrite stack_context_appstack in haux; try rewrite stack_context_appstack in H; - cbn in *). + cbn in * ). destruct H as (noapp&_); cbn in *. rewrite app_nil_r in *. rewrite <- app_assoc in *. @@ -1584,14 +1550,6 @@ Section Reduce. constructor. apply whnf_mkApps. now apply whne_case_noiota. - - match goal with - | |- context [ reduce ?x ?y ?z ] => - case_eq (reduce x y z) ; - specialize (haux x y z) - end. - intros [t' π'] [? [? [? ?]]] eq. cbn. - rewrite eq in haux. cbn in haux. - assumption. - match type of e with | _ = reduce ?x ?y ?z => specialize (haux x y z); @@ -1626,7 +1584,7 @@ Section Reduce. try rewrite stack_context_appstack in typ; try rewrite stack_context_appstack in haux; try rewrite stack_context_appstack in H; - cbn in *). + cbn in * ). rewrite app_nil_r in *. destruct hΣ, haux. constructor. @@ -1642,6 +1600,14 @@ Section Reduce. intros [t' π'] [? [? [? ?]]] eq. cbn. rewrite eq in haux. cbn in haux. assumption. + - match goal with + | |- context [ reduce ?x ?y ?z ] => + case_eq (reduce x y z) ; + specialize (haux x y z) + end. + intros [t' π'] [? [? [? ?]]] eq. cbn. + rewrite eq in haux. cbn in haux. + assumption. - unfold zipp. case_eq (decompose_stack π6). intros. constructor. constructor. eapply whne_mkApps. eapply whne_proj_noiota. assumption. - match type of e with @@ -1678,7 +1644,7 @@ Section Reduce. try rewrite stack_context_appstack in typ; try rewrite stack_context_appstack in haux; try rewrite stack_context_appstack in H; - cbn in *). + cbn in * ). rewrite app_nil_r in *. destruct hΣ, haux. constructor. apply whnf_mkApps, whne_proj. @@ -1706,7 +1672,7 @@ Section Reduce. Theorem reduce_term_complete Γ t h : ∥whnf flags Σ Γ (reduce_term Γ t h)∥. Proof. - pose proof (reduce_stack_whnf Γ t ε h) as H. + pose proof (reduce_stack_whnf Γ t [] h) as H. unfold reduce_term. unfold reduce_stack in *. destruct reduce_stack_full. @@ -1820,7 +1786,7 @@ Section ReduceFns. reduce_to_ind Γ t h with inspect (decompose_app t) := { | exist (thd, args) eq_decomp with view_indc thd := { | view_ind_tInd i u => ret (i; u; args; sq _); - | view_ind_other t _ with inspect (reduce_stack RedFlags.default Σ HΣ Γ t Empty h) := { + | view_ind_other t _ with inspect (reduce_stack RedFlags.default Σ HΣ Γ t [] h) := { | exist (hnft, π) eq with view_indc hnft := { | view_ind_tInd i u with inspect (decompose_stack π) := { | exist (l, _) eq_decomp => ret (i; u; l; _) @@ -1834,17 +1800,17 @@ Section ReduceFns. - assert (X : mkApps (tInd i u) args = t); [|rewrite X; apply refl_red]. etransitivity. 2: symmetry; eapply mkApps_decompose_app. now rewrite <- eq_decomp. - - pose proof (reduce_stack_sound RedFlags.default Σ HΣ _ _ Empty h). + - pose proof (reduce_stack_sound RedFlags.default Σ HΣ _ _ [] h). rewrite <- eq in H. cbn in *. - assert (π = appstack l ε) as ->. + assert (π = appstack l []) as ->. 2: { now rewrite zipc_appstack in H. } unfold reduce_stack in eq. destruct reduce_stack_full as (?&_&stack_val&?). subst x. unfold Pr in stack_val. cbn in *. - assert (decomp: decompose_stack π = ((decompose_stack π).1, ε)). + assert (decomp: decompose_stack π = ((decompose_stack π).1, [])). { rewrite stack_val. now destruct decompose_stack. } apply decompose_stack_eq in decomp as ->. @@ -1859,7 +1825,7 @@ Section ReduceFns. Proof. funelim (reduce_to_ind Γ ty wat); try congruence. intros _ ind u args r. - pose proof (reduce_stack_whnf RedFlags.default Σ HΣ Γ t ε h) as wh. + pose proof (reduce_stack_whnf RedFlags.default Σ HΣ Γ t [] h) as wh. unfold reduce_stack in *. destruct reduce_stack_full as ((hd&π)&r'&stack_valid&(notapp&_)). destruct wh as [wh]. @@ -1868,9 +1834,9 @@ Section ReduceFns. cbn in *. destruct HΣ. eapply red_confluence in r as (?&r1&r2); [|eassumption|exact r']. - assert (exists args, π = appstack args ε) as (?&->). + assert (exists args, π = appstack args []) as (?&->). { exists ((decompose_stack π).1). - assert (decomp: decompose_stack π = ((decompose_stack π).1, ε)). + assert (decomp: decompose_stack π = ((decompose_stack π).1, [])). { now rewrite stack_valid; destruct decompose_stack. } now apply decompose_stack_eq in decomp. } diff --git a/safechecker/theories/PCUICSafeRetyping.v b/safechecker/theories/PCUICSafeRetyping.v index 800dbc0e4..cb8d49378 100644 --- a/safechecker/theories/PCUICSafeRetyping.v +++ b/safechecker/theories/PCUICSafeRetyping.v @@ -9,7 +9,8 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICArities PCUICInduc PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICSafeLemmata PCUICSubstitution PCUICValidity PCUICGeneration PCUICInversion PCUICValidity PCUICInductives PCUICInductiveInversion PCUICSpine PCUICSR PCUICCumulativity PCUICConversion PCUICConfluence PCUICArities - PCUICWeakeningEnv PCUICContexts. + PCUICWeakeningEnv PCUICContexts PCUICContextConversion. + From MetaCoq.SafeChecker Require Import PCUICErrors PCUICSafeReduce. Local Open Scope string_scope. Set Asymmetric Patterns. @@ -168,7 +169,7 @@ Section TypeOf. Qed. Equations lookup_ind_decl ind : typing_result - ({decl & {body & declared_inductive (fst Σ) decl ind body}}) := + ({decl & {body & declared_inductive (fst Σ) ind decl body}}) := lookup_ind_decl ind with inspect (lookup_env (fst Σ) ind.(inductive_mind)) := { | exist (Some (InductiveDecl decl)) look with inspect (nth_error decl.(ind_bodies) ind.(inductive_ind)) := { | exist (Some body) eqnth => Checked (decl; body; _); @@ -182,7 +183,7 @@ Section TypeOf. Defined. Lemma lookup_ind_decl_complete ind e : lookup_ind_decl ind = TypeError e -> - ((∑ mdecl idecl, declared_inductive Σ mdecl ind idecl) -> False). + ((∑ mdecl idecl, declared_inductive Σ ind mdecl idecl) -> False). Proof. apply_funelim (lookup_ind_decl ind). 1-2:intros * _ her [mdecl [idecl [declm decli]]]; @@ -227,11 +228,11 @@ Section TypeOf. ret (subst10 a pi.π2.π2.π1); infer Γ (tConst cst u) wt with inspect (lookup_env (fst Σ) cst) := - { | ret (Some (ConstantDecl d)) := ret (subst_instance_constr u d.(cst_type)); + { | ret (Some (ConstantDecl d)) := ret (subst_instance u d.(cst_type)); | _ := ! }; infer Γ (tInd ind u) wt with inspect (lookup_ind_decl ind) := - { | ret (Checked decl) := ret (subst_instance_constr u decl.π2.π1.(ind_type)); + { | ret (Checked decl) := ret (subst_instance u decl.π2.π1.(ind_type)); | ret (TypeError e) := ! }; infer Γ (tConstruct ind k u) wt with inspect (lookup_ind_decl ind) := @@ -240,9 +241,10 @@ Section TypeOf. | ret None => ! }; | ret (TypeError e) => ! }; - infer Γ (tCase (ind, par) p c brs) wt with inspect (reduce_to_ind hΣ Γ (infer Γ c _) _) := + infer Γ (tCase ci p c brs) wt with inspect (reduce_to_ind hΣ Γ (infer Γ c _) _) := { | ret (Checked indargs) => - ret (mkApps p (List.skipn par indargs.π2.π2.π1 ++ [c])); + let ptm := it_mkLambda_or_LetIn p.(pcontext) p.(preturn) in + ret (mkApps ptm (List.skipn ci.(ci_npar) indargs.π2.π2.π1 ++ [c])); | ret (TypeError _) => ! }; infer Γ (tProj (ind, n, k) c) wt with inspect (@lookup_ind_decl ind) := @@ -250,7 +252,7 @@ Section TypeOf. { | ret (Some pdecl) with inspect (reduce_to_ind hΣ Γ (infer Γ c _) _) := { | ret (Checked indargs) => let ty := snd pdecl in - ret (subst0 (c :: List.rev (indargs.π2.π2.π1)) (subst_instance_constr indargs.π2.π1 ty)); + ret (subst0 (c :: List.rev (indargs.π2.π2.π1)) (subst_instance indargs.π2.π1 ty)); | ret (TypeError _) => ! }; | ret None => ! }; | ret (TypeError e) => ! }; @@ -333,7 +335,7 @@ Section TypeOf. destruct infer as [bty' [[Hbty pbty]]]; subst ty; simpl in *. apply wat_welltyped; auto. sq. - eapply validity_term; eauto. + eapply validity; eauto. - simpl in ty. destruct inversion_App as (? & ? & ? & ? & ? & ?). destruct infer as [bty' [[Hbty pbty]]]; subst ty; simpl in *. sq. exists x, x0, x1. now eapply pbty. @@ -396,7 +398,7 @@ Section TypeOf. exists mdecl, idecl. split; auto. - destruct d as [decl [body decli]]. - assert (declared_constructor Σ decl body (ind, k) cdecl) as declc. + assert (declared_constructor Σ (ind, k) decl body cdecl) as declc. { red; intuition auto. } eapply inversion_Construct in HT; auto. dependent elimination HT as [(mdecl; idecl; cdecl; (wf'', (declc', (rest, cum))))]. @@ -421,124 +423,69 @@ Section TypeOf. now destruct declc'. - eapply inversion_Case in HT; auto. - destruct HT as (u & args & mdecl & idecl & ps & pty & btys & decli & indp & bcp & Hpty & lebs - & isco & Hc & Hbtys & all & cum). + destruct HT as (mdecl & idecl & isdecl & indices & [] & cum). eexists; eauto. - - simpl. destruct inversion_Case as (u & args & mdecl & idecl & ps & pty & btys & decli & indp & bcp & Hpty & lebs - & isco & Hc & Hbtys & all & cum). + - cbn. + destruct inversion_Case as (mdecl & idecl & isdecl & indices & data & cum). destruct infer as [cty [[Hty Hp]]]. simpl. eapply validity in Hty. - eapply wat_welltyped; auto. sq; auto. auto. - - simpl in *. - destruct inversion_Case as (u & args & mdecl & idecl & ps & pty & btys & decli & indp & bcp & Hpty & lebs - & isco & Hc & Hbtys & all & cum). + eapply wat_welltyped; auto. sq; auto. + - cbn -[reduce_to_ind] in *. + destruct inversion_Case as (mdecl & idecl & isdecl & indices & data & cum). destruct infer as [cty [[Hty Hp]]]. - simpl in wildcard. destruct reduce_to_ind => //. + destruct reduce_to_ind => //. injection wildcard. intros ->. clear wildcard. destruct a as [i [u' [l [red]]]]. - simpl. + simpl in *. eapply type_reduction in Hty; eauto. - pose proof (Hp _ Hc). - assert (Σ ;;; Γ |- mkApps (tInd i u') l <= mkApps (tInd ind u) args). + destruct data. + pose proof (Hp _ scrut_ty). + assert (Σ ;;; Γ |- mkApps (tInd i u') l <= mkApps (tInd ci (puinst p)) (pparams p ++ indices)). { eapply cumul_red_l_inv; eauto. } eapply cumul_Ind_Ind_inv in X0 as [[eqi Ru] cl]; auto. + assert (conv_indices : All2 (fun x y : term => Σ;;; Γ |- x = y) (indices ++ [c]) + (skipn (ci_npar ci) l ++ [c])). + { eapply All2_app. 2:repeat (constructor; auto). + eapply All2_skipn in cl. instantiate (1:=(ci_npar ci)) in cl. + symmetry in cl. rewrite skipn_all_app_eq in cl. + now rewrite (wf_predicate_length_pars wf_pred). + exact cl. } sq; split; simpl. - * pose proof (Reflect.eqb_eq i ind eqi) as ->. - simpl in *. subst par. - pose proof (validity_term _ Hc). - eapply (isType_mkApps_Ind w decli) in X0 as [parsubst [argsubst [[sppars spargs] cu]]]; pcuic. - pose proof (PCUICContexts.context_subst_length2 sppars). - len in H. - set (oib := (on_declared_inductive w decli).2) in *. - eapply type_Cumul'. econstructor; eauto. - assert (Σ ;;; Γ |- c : mkApps (tInd ind u) (firstn (ind_npars mdecl) args ++ skipn (ind_npars mdecl) l)). - { eapply type_Cumul'. eauto. - + exists (subst_instance_univ u (ind_sort oib)). - eapply type_mkApps. econstructor; pcuic. - eapply wf_arity_spine_typing_spine; eauto. - constructor. - unshelve epose proof (on_inductive_inst _ _ _ _ _ _ w ltac:(pcuic) _ _ oib cu); eauto. - eapply on_declared_inductive; eauto. - rewrite oib.(ind_arity_eq) -it_mkProd_or_LetIn_app subst_instance_constr_it_mkProd_or_LetIn. - eapply isType_weaken; eauto. pcuic. - rewrite oib.(ind_arity_eq) subst_instance_constr_it_mkProd_or_LetIn. - eapply arity_spine_it_mkProd_or_LetIn; eauto. - rewrite subst_instance_constr_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn. - simpl. rewrite -(app_nil_r (skipn _ _)). - eapply arity_spine_it_mkProd_or_LetIn_smash; eauto. - 2:{ simpl. constructor; auto. } - eapply validity_term in Hty; eauto. - unshelve epose proof (isType_mkApps_Ind w decli _ Hty) as [parsubst' [argsubst' [[spars' spargs'] ?]]]; pcuic. - eapply (subslet_cumul _ _ _ (smash_context [] (subst_context parsubst' 0 - (subst_instance_context u' (ind_indices oib))))); pcuic. - eapply wf_local_smash_end; eauto. eapply spargs'. - eapply wf_local_smash_end; eauto. eapply spargs. - eapply inductive_cumulative_indices; eauto. - destruct decli as [declm ?]. - apply (weaken_lookup_on_global_env' _ _ _ w declm). - now eapply All2_firstn. - eapply spine_subst_smash in spargs'. - eapply spargs'. auto. - - + transitivity (mkApps (tInd ind u) l). - constructor. eapply PCUICEquality.eq_term_upto_univ_napp_mkApps. - now rewrite Nat.add_0_r; constructor. - eapply All2_refl. intros. reflexivity. - rewrite -{1}(firstn_skipn (ind_npars mdecl) l). eapply conv_cumul, mkApps_conv_args; auto. - eapply All2_app. now eapply All2_firstn. eapply All2_refl; eauto. } - exists ps. - eapply type_mkApps; eauto. - eapply wf_arity_spine_typing_spine; eauto. - split. now eapply validity in Hpty. - pose proof (validity_term w X0) as vt; auto. - eapply (build_case_predicate_type_spec _ _ _ _ _ _ _ _ oib) in bcp as [parsubst' [csubst ->]]; auto. - pose proof (PCUICContexts.context_subst_fun sppars csubst). subst parsubst'. - unshelve epose proof (isType_mkApps_Ind w decli _ vt) as [parsubst' [argsubst' [[spars' spargs'] ?]]]; pcuic. - change (ind_indices (on_declared_inductive w decli).2) with (ind_indices oib) in spargs'. - subst oib; destruct on_declared_inductive as [onmind oib]. - rewrite onmind.(onNpars) in H. - pose proof (firstn_length_le_inv _ _ H). - pose proof (subslet_length spargs'). len in H1. - rewrite skipn_all_app_eq in spargs'. now rewrite H. - rewrite (firstn_app_left _ 0) in spars'; try lia. - simpl in spars'. rewrite app_nil_r in spars'. - pose proof (PCUICContexts.context_subst_fun spars' csubst). subst parsubst'. - eapply PCUICSpine.arity_spine_it_mkProd_or_LetIn; eauto. - + simpl. - econstructor. 2:constructor. - rewrite subst_mkApps /= map_app. - rewrite -H1. - rewrite map_map_compose map_subst_lift_id. - relativize (to_extended_list _). - erewrite (spine_subst_subst_to_extended_list_k spargs'). - 2:{ rewrite to_extended_list_k_subst. simpl. - eapply PCUICSubstitution.map_subst_instance_constr_to_extended_list_k. } - assumption. - + simpl. - eapply conv_cumul. + * pose proof (validity scrut_ty). + eapply type_Cumul. econstructor; eauto. + + + assert (Σ ;;; Γ |- it_mkLambda_or_LetIn (pcontext p) (preturn p) : + it_mkProd_or_LetIn (pcontext p) (tSort ps)). + eapply type_it_mkLambda_or_LetIn. eauto. + eapply PCUICGeneration.type_mkApps; tea. + eapply wf_arity_spine_typing_spine; auto. + eapply validity in X1; auto. + split; pcuic. + todo "case". + + eapply conv_cumul. eapply mkApps_conv_args; auto. - eapply All2_app. 2:repeat (constructor; auto). - eapply All2_skipn. now symmetry in cl. * intros T'' Hc'. - eapply inversion_Case in Hc' as (u'' & args' & mdecl' & idecl' & ps' & pty' - & btys' & decli' & indp' & bcp' & Hpty' & lebs' & isco' & Hc' & Hbtys' & all' & cum'); auto. + eapply inversion_Case in Hc' as (mdecl' & idecl' & isdecl' & indices' & [] & cum'); auto. etransitivity. simpl in cum'. 2:eassumption. eapply conv_cumul, mkApps_conv_args; auto. eapply All2_app. 2:repeat (constructor; auto). - eapply All2_skipn. - specialize (Hp _ Hc'). - assert (Σ ;;; Γ |- mkApps (tInd i u') l <= mkApps (tInd ind u'') args'). - { eapply cumul_red_l_inv; eauto. } + specialize (Hp _ scrut_ty0). + assert (Σ ;;; Γ |- mkApps (tInd i u') l <= mkApps (tInd ci (puinst p)) + (pparams p ++ indices')). + { eapply cumul_red_l_inv; eauto. } eapply cumul_Ind_Ind_inv in X0 as [[eqi' Ru'] cl']; auto. + eapply All2_skipn in cl'. instantiate (1 := ci_npar ci) in cl'. + rewrite skipn_all_app_eq // in cl'. + now rewrite (wf_predicate_length_pars wf_pred). - - simpl in wildcard1. - destruct inversion_Case as (u & args & mdecl & idecl & ps & pty & btys & decli & indp & bcp & Hpty & lebs - & isco & Hc & Hbtys & all & cum). - destruct infer as [cty [[Hty Hp]]]. simpl. - destruct validity as [_ i]. simpl in wildcard1. - specialize (Hp _ Hc). + - cbn in wildcard1. + destruct inversion_Case as (mdecl & idecl & isdecl & indices & [] & cum). + destruct infer as [cty [[Hty Hp]]]. + destruct validity as [Hi i]. simpl in wildcard1. + specialize (Hp _ scrut_ty). eapply invert_cumul_ind_r in Hp as [ui' [l' [red [Ru ca]]]]; auto. - symmetry in wildcard1; eapply reduce_to_ind_complete in wildcard1 => //. + symmetry in wildcard1; + eapply reduce_to_ind_complete in wildcard1 => //. eauto. - eapply inversion_Proj in HT as (u & mdecl & idecl & pdecl' & args & declp & Hc & Hargs & cum); auto. @@ -561,12 +508,12 @@ Section TypeOf. eapply cumul_Ind_Ind_inv in X0 as [[eqi' Ru'] cl']; eauto. destruct d as [decl [body decli]]. pose proof (declared_inductive_inj (proj1 declp) decli) as [-> ->]. - assert (declared_projection Σ mdecl idecl (ind, n, k) pdecl). + assert (declared_projection Σ (ind, n, k) mdecl idecl pdecl). { red; intuition eauto. simpl. eapply declp. } pose proof (@Reflect.eqb_eq inductive _). apply H0 in eqi'. subst ind. destruct (declared_projection_inj declp H) as [_ [_ ->]]. sq. split; auto. - * econstructor; eauto. now rewrite (All2_length _ _ cl'). + * econstructor; eauto. now rewrite (All2_length cl'). * intros. eapply inversion_Proj in X0 as (u'' & mdecl' & idecl' & pdecl'' & args' & declp' & Hc''' & Hargs' & cum'); auto. @@ -585,7 +532,7 @@ Section TypeOf. { eapply validity in Hc'''; eauto. destruct Hc''' as [s Hs]; auto. eapply invert_type_mkApps_ind in Hs. intuition eauto. all:auto. eapply declp. } - transitivity (subst0 (c :: List.rev l) (subst_instance_constr u'' pdecl''.2)); cycle 1. + transitivity (subst0 (c :: List.rev l) (subst_instance u'' pdecl''.2)); cycle 1. eapply conv_cumul. eapply (subst_conv _ (projection_context mdecl idecl i u') (projection_context mdecl idecl i u'') []); auto. @@ -596,26 +543,26 @@ Section TypeOf. constructor; auto. now apply All2_rev. eapply PCUICWeakening.weaken_wf_local; eauto. eapply PCUICWeakening.weaken_wf_local; pcuic. - eapply (wf_projection_context _ (p:= (i, n, k))); pcuic. + eapply (wf_projection_context _ (p:= (i, n, k))); eauto. eapply (substitution_cumul _ Γ (projection_context mdecl idecl i u') []); auto. + cbn -[projection_context]. eapply PCUICWeakening.weaken_wf_local; pcuic. - eapply PCUICWeakening.weaken_wf_local; pcuic. - eapply (wf_projection_context _ (p:=(i, n, k))); pcuic. + eapply (wf_projection_context _ (p:=(i, n, k))); eauto. eapply (projection_subslet _ _ _ _ _ _ (i, n, k)); eauto. simpl. eapply validity; eauto. - rewrite -(All2_length _ _ cl'') in Hargs'. rewrite Hargs' in Ru''. + rewrite -(All2_length cl'') in Hargs'. rewrite Hargs' in Ru''. unshelve epose proof (projection_cumulative_indices w declp _ H1 H2 Ru''). { eapply (PCUICWeakeningEnv.weaken_lookup_on_global_env' _ _ _ w (proj1 (proj1 declp))). } eapply PCUICWeakeningEnv.on_declared_projection in declp; eauto. eapply weaken_cumul in X0; eauto. eapply PCUICClosed.closed_wf_local; eauto. - eapply (wf_projection_context _ (p:= (i, n, k))); pcuic. + eapply (wf_projection_context _ (p:= (i, n, k))); eauto. len. simpl. len. simpl. rewrite declp.(onNpars). - rewrite PCUICClosed.closedn_subst_instance_constr. + rewrite PCUICClosed.closedn_subst_instance. now apply (PCUICClosed.declared_projection_closed w declp'). simpl; len. rewrite declp.(onNpars). - rewrite PCUICClosed.closedn_subst_instance_constr. + rewrite PCUICClosed.closedn_subst_instance. now apply (PCUICClosed.declared_projection_closed w declp'). - simpl in *. @@ -658,7 +605,7 @@ Section TypeOf. - now eapply inversion_CoFix in HT as [decl [fg [hnth [htys [hbods [wf cum]]]]]]; auto. - - now eapply inversion_Prim in HT. + - now eapply inversion_Prim in HT. Unshelve. todo "case". Defined. Definition type_of Γ t wt : term := (infer Γ t wt). diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 2ce20f41c..61cfc8fef 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -6,13 +6,13 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICWeakening PCUICPosition PCUICCumulativity PCUICSafeLemmata PCUICSN PCUICPretty PCUICArities PCUICConfluence PCUICSize PCUICContextConversion PCUICConversion PCUICWfUniverses - PCUICGlobalEnv + PCUICGlobalEnv PCUICEqualityDec (* Used for support lemmas *) PCUICInductives PCUICWfUniverses PCUICContexts PCUICSubstitution PCUICSpine PCUICInductiveInversion PCUICClosed PCUICUnivSubstitution PCUICWeakeningEnv. -From MetaCoq.SafeChecker Require Import PCUICSafeReduce PCUICErrors PCUICEqualityDec +From MetaCoq.SafeChecker Require Import PCUICSafeReduce PCUICErrors PCUICSafeConversion PCUICWfReduction PCUICWfEnv. From Equations Require Import Equations. @@ -58,7 +58,7 @@ Section Typecheck. let t' := hnf Γ t ht in let u' := hnf Γ u hu in (* match leq_term (snd Σ) t' u' with true => ret _ | false => *) - raise (NotCumulSmaller G Γ t u t' u' e) + raise (NotCumulSmaller false G Γ t u t' u' e) (* end *) end end. Next Obligation. @@ -80,7 +80,7 @@ Section Typecheck. let t' := hnf Γ t ht in let u' := hnf Γ u hu in (* match leq_term (snd Σ) t' u' with true => ret _ | false => *) - raise (NotCumulSmaller G Γ t u t' u' e) + raise (NotCumulSmaller true G Γ t u t' u' e) (* end *) end end. Next Obligation. @@ -92,6 +92,15 @@ Section Typecheck. assumption. Qed. + + Definition wt_decl (Σ : global_env_ext) Γ d := + match d with + | {| decl_body := Some b; decl_type := ty |} => + welltyped Σ Γ ty /\ welltyped Σ Γ b + | {| decl_body := None; decl_type := ty |} => + welltyped Σ Γ ty + end. + Section InferAux. Variable (infer : forall Γ (HΓ : ∥ wf_local Σ Γ ∥) (t : term), typing_result ({ A : term & ∥ Σ ;;; Γ |- t : A ∥ })). @@ -109,6 +118,13 @@ Section Typecheck. now constructor; eapply type_reduction. Defined. + Program Definition infer_isType Γ HΓ T : typing_result (∥ isType Σ Γ T ∥) := + tx <- infer_type Γ HΓ T ;; + ret _. + Next Obligation. + sq. now eexists. + Defined. + Program Definition infer_cumul Γ HΓ t A (hA : ∥ isType Σ Γ A ∥) : typing_result (∥ Σ ;;; Γ |- t : A ∥) := A' <- infer Γ HΓ t ;; @@ -139,11 +155,312 @@ Section Typecheck. sq. eapply type_reduction; eauto. Qed. + + Lemma sq_wfl_nil : ∥ wf_local Σ [] ∥. + Proof. + repeat constructor. + Qed. + + Program Fixpoint check_context Γ : typing_result (∥ wf_local Σ Γ ∥) + := match Γ with + | [] => ret sq_wfl_nil + | {| decl_body := None; decl_type := A |} :: Γ => + HΓ <- check_context Γ ;; + XX <- infer_type Γ HΓ A ;; + ret _ + | {| decl_body := Some t; decl_type := A |} :: Γ => + HΓ <- check_context Γ ;; + XX <- infer_type Γ HΓ A ;; + XX <- infer_cumul Γ HΓ t A _ ;; + ret _ + end. + Next Obligation. + sq. econstructor; tas. econstructor; eauto. + Qed. + Next Obligation. + sq. econstructor; tea. + Qed. + Next Obligation. + sq. econstructor; tas. econstructor; eauto. + Qed. + + Lemma sq_wf_locak_app {Γ Δ} : ∥ wf_local Σ Γ ∥ -> ∥ wf_local_rel Σ Γ Δ ∥ -> ∥ wf_local Σ (Γ ,,, Δ) ∥. + Proof. + intros [] []; constructor; now apply wf_local_app. + Qed. + + Program Fixpoint check_context_rel Γ (Δ : context) : + ∥ wf_local Σ Γ ∥ -> typing_result (∥ wf_local_rel Σ Γ Δ ∥) := + match Δ return ∥ wf_local Σ Γ ∥ -> typing_result (∥ wf_local_rel Σ Γ Δ ∥) with + | [] => fun wfΓ => ret (sq localenv_nil) + | {| decl_body := None; decl_type := A |} :: Δ => + fun wfΓ => + wfΔ <- check_context_rel Γ Δ wfΓ ;; + XX <- infer_isType (Γ ,,, Δ) (sq_wf_locak_app wfΓ wfΔ) A ;; + ret _ + | {| decl_body := Some t; decl_type := A |} :: Δ => + fun wfΓ => + wfΔ <- check_context_rel Γ Δ wfΓ ;; + Aty <- infer_isType (Γ ,,, Δ) (sq_wf_locak_app wfΓ wfΔ) A ;; + XX <- infer_cumul (Γ ,,, Δ) (sq_wf_locak_app wfΓ wfΔ) t A Aty ;; + ret _ + end. + Next Obligation. + sq. constructor; auto. + Qed. + Next Obligation. + sq. constructor; auto. + Qed. + + Program Definition check_cumul_decl Γ d d' : wt_decl Σ Γ d -> wt_decl Σ Γ d' -> typing_result (∥ cumul_decls Σ Γ Γ d d' ∥) := + match d, d' return wt_decl Σ Γ d -> wt_decl Σ Γ d' -> typing_result _ with + | {| decl_name := na; decl_body := Some b; decl_type := ty |}, + {| decl_name := na'; decl_body := Some b'; decl_type := ty' |} => + fun wtd wtd' => + eqna <- check_eq_true (eqb_binder_annot na na') (Msg "Binder annotations do not match") ;; + cumb <- convert Γ b b' _ _ ;; + cumt <- convert_leq Γ ty ty' _ _ ;; + ret (let 'sq cumb := cumb in + let 'sq cumt := cumt in + sq _) + | {| decl_name := na; decl_body := None; decl_type := ty |}, + {| decl_name := na'; decl_body := None; decl_type := ty' |} => + fun wtd wtd' => + eqna <- check_eq_true (eqb_binder_annot na na') (Msg "Binder annotations do not match") ;; + cumt <- convert_leq Γ ty ty' wtd wtd' ;; + ret (let 'sq cumt := cumt in sq _) + | _, _ => + fun wtd wtd' => raise (Msg "While checking cumulativity of contexts: declarations do not match") + end. + Next Obligation. + constructor; pcuics. now apply eqb_binder_annot_spec. + Qed. + Next Obligation. + constructor; pcuics. now apply eqb_binder_annot_spec. + Qed. + + Program Definition check_conv_decl Γ d d' : wt_decl Σ Γ d -> wt_decl Σ Γ d' -> typing_result (∥ conv_decls Σ Γ Γ d d' ∥) := + match d, d' return wt_decl Σ Γ d -> wt_decl Σ Γ d' -> typing_result _ with + | {| decl_name := na; decl_body := Some b; decl_type := ty |}, + {| decl_name := na'; decl_body := Some b'; decl_type := ty' |} => + fun wtd wtd' => + eqna <- check_eq_true (eqb_binder_annot na na') (Msg "Binder annotations do not match") ;; + cumb <- convert Γ b b' _ _ ;; + cumt <- convert Γ ty ty' _ _ ;; + ret (let 'sq cumb := cumb in + let 'sq cumt := cumt in + sq _) + | {| decl_name := na; decl_body := None; decl_type := ty |}, + {| decl_name := na'; decl_body := None; decl_type := ty' |} => + fun wtd wtd' => + eqna <- check_eq_true (eqb_binder_annot na na') (Msg "Binder annotations do not match") ;; + cumt <- convert Γ ty ty' wtd wtd' ;; + ret (let 'sq cumt := cumt in sq _) + | _, _ => + fun wtd wtd' => raise (Msg "While checking cumulativity of contexts: declarations do not match") + end. + Next Obligation. + constructor; pcuics. now apply eqb_binder_annot_spec. + Qed. + Next Obligation. + constructor; pcuics. now apply eqb_binder_annot_spec. + Qed. + + Lemma cumul_ctx_rel_close Γ Δ Δ' : + cumul_ctx_rel Σ Γ Δ Δ' -> + cumul_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). + Proof. + induction 1; pcuic. + Qed. + + Lemma conv_ctx_rel_close Γ Δ Δ' : + conv_context_rel Σ Γ Δ Δ' -> + conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). + Proof. + induction 1; pcuic. simpl. constructor; eauto. + depelim p; constructor; auto. + Qed. + + Lemma context_cumulativity_welltyped Γ Γ' t : + welltyped Σ Γ t -> + cumul_context Σ Γ' Γ -> + wf_local Σ Γ' -> + welltyped Σ Γ' t. + Proof. + destruct HΣ. + intros [s Hs] cum wfΓ'; exists s; eapply context_cumulativity; eauto. + Qed. + + Lemma context_conversion_welltyped Γ Γ' t : + welltyped Σ Γ t -> + conv_context Σ Γ' Γ -> + wf_local Σ Γ' -> + welltyped Σ Γ' t. + Proof. + destruct HΣ. + intros [s Hs] cum wfΓ'; exists s; eapply context_conversion; eauto. + now eapply conv_context_sym. + Qed. + + Lemma context_cumulativity_wt_decl Γ Γ' d : + wt_decl Σ Γ d -> + cumul_context Σ Γ' Γ -> + wf_local Σ Γ' -> + wt_decl Σ Γ' d. + Proof. + destruct d as [na [b|] ty]; simpl; + intuition pcuics; eapply context_cumulativity_welltyped; pcuics. + Qed. + + Lemma context_conversion_wt_decl Γ Γ' d : + wt_decl Σ Γ d -> + conv_context Σ Γ' Γ -> + wf_local Σ Γ' -> + wt_decl Σ Γ' d. + Proof. + destruct d as [na [b|] ty]; simpl; + intuition pcuics; eapply context_conversion_welltyped; pcuics. + Qed. + + Lemma cumul_decls_irrel_sec Γ Γ' d d' : + cumul_decls Σ Γ Γ d d' -> + cumul_decls Σ Γ Γ' d d'. + Proof. + intros cum; depelim cum; intros; constructor; auto. + Qed. + + Lemma conv_decls_irrel_sec Γ Γ' d d' : + conv_decls Σ Γ Γ d d' -> + conv_decls Σ Γ Γ' d d'. + Proof. + intros cum; depelim cum; intros; constructor; auto. + Qed. + + Lemma inv_wf_local Γ d : + wf_local Σ (Γ ,, d) -> + wf_local Σ Γ * wt_decl Σ Γ d. + Proof. + intros wfd; depelim wfd; split; simpl; pcuic. + now exists t. + Qed. + + Lemma cumul_ctx_rel_cons {Γ Δ Δ' d d'} (c : cumul_ctx_rel Σ Γ Δ Δ') + (p : cumul_decls Σ (Γ,,, Δ) (Γ ,,, Δ') d d') : + cumul_ctx_rel Σ Γ (Δ ,, d) (Δ' ,, d'). + Proof. + destruct d as [na [b|] ty], d' as [na' [b'|] ty']; try constructor; auto. + Qed. + Lemma conv_ctx_rel_cons {Γ Δ Δ' d d'} (c : conv_context_rel Σ Γ Δ Δ') + (p : conv_decls Σ (Γ,,, Δ) (Γ ,,, Δ') d d') : + conv_context_rel Σ Γ (Δ ,, d) (Δ' ,, d'). + Proof. + destruct d as [na [b|] ty], d' as [na' [b'|] ty']; try constructor; auto; + depelim p; constructor; auto. + Qed. + + Program Fixpoint check_cumul_ctx Γ Δ Δ' + (wfΔ : ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : ∥ wf_local Σ (Γ ,,, Δ') ∥) : + typing_result (∥ cumul_ctx_rel Σ Γ Δ Δ' ∥) := + match Δ, Δ' with + | [], [] => ret (sq All2_fold_nil) + | decl :: Δ, decl' :: Δ' => + cctx <- check_cumul_ctx Γ Δ Δ' _ _ ;; + cdecl <- check_cumul_decl (Γ ,,, Δ) decl decl' _ _ ;; + ret _ + | _, _ => raise (Msg "While checking cumulativity of contexts: contexts have not the same length") + end. + Next Obligation. + sq; now depelim wfΔ. + Qed. + Next Obligation. + sq; now depelim wfΔ'. + Qed. + Next Obligation. + sq. + depelim wfΔ; simpl. + destruct l; eexists; eauto. + destruct l; split; eexists; eauto. + Qed. + + Next Obligation. + pose proof HΣ as [wfΣ]. + destruct wfΔ as [wfΔ], wfΔ' as [wfΔ'], cctx as [cctx]. + assert(cumul_context Σ (Γ ,,, Δ) (Γ ,,, Δ')). + now apply cumul_ctx_rel_close. + simpl in *. eapply inv_wf_local in wfΔ as [wfΔ wfd]. + eapply inv_wf_local in wfΔ' as [wfΔ' wfd']. + eapply context_cumulativity_wt_decl. 3:eassumption. all:pcuics. + Qed. + Next Obligation. + pose proof HΣ as [wfΣ]. + destruct wfΔ as [wfΔ], wfΔ' as [wfΔ'], cctx as [cctx], cdecl as [cdecl]. + constructor. + eapply inv_wf_local in wfΔ as [wfΔ wfd]. + eapply inv_wf_local in wfΔ' as [wfΔ' wfd']. + apply cumul_ctx_rel_cons. auto. + eapply cumul_decls_irrel_sec; pcuics. + Qed. + Next Obligation. + split. intros. intros []. congruence. intros []; congruence. + Qed. + Next Obligation. + split. intros. intros []. congruence. intros []; congruence. + Qed. + + Program Fixpoint check_conv_ctx Γ Δ Δ' + (wfΔ : ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : ∥ wf_local Σ (Γ ,,, Δ') ∥) : + typing_result (∥ conv_context_rel Σ Γ Δ Δ' ∥) := + match Δ, Δ' with + | [], [] => ret (sq All2_fold_nil) + | decl :: Δ, decl' :: Δ' => + cctx <- check_conv_ctx Γ Δ Δ' _ _ ;; + cdecl <- check_conv_decl (Γ ,,, Δ) decl decl' _ _ ;; + ret _ + | _, _ => raise (Msg "While checking convertibility of contexts: contexts have not the same length") + end. + Next Obligation. + sq; now depelim wfΔ. + Qed. + Next Obligation. + sq; now depelim wfΔ'. + Qed. + Next Obligation. + sq. + depelim wfΔ; simpl. + destruct l; eexists; eauto. + destruct l; split; eexists; eauto. + Qed. + + Next Obligation. + pose proof HΣ as [wfΣ]. + destruct wfΔ as [wfΔ], wfΔ' as [wfΔ'], cctx as [cctx]. + assert(conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ')). + now apply conv_ctx_rel_close. + simpl in *. eapply inv_wf_local in wfΔ as [wfΔ wfd]. + eapply inv_wf_local in wfΔ' as [wfΔ' wfd']. + eapply context_conversion_wt_decl. 3:eassumption. all:pcuics. + Qed. + Next Obligation. + pose proof HΣ as [wfΣ]. + destruct wfΔ as [wfΔ], wfΔ' as [wfΔ'], cctx as [cctx], cdecl as [cdecl]. + constructor. + eapply inv_wf_local in wfΔ as [wfΔ wfd]. + eapply inv_wf_local in wfΔ' as [wfΔ' wfd']. + apply conv_ctx_rel_cons. auto. + eapply conv_decls_irrel_sec; pcuics. + Qed. + Next Obligation. + split. intros. intros []. congruence. intros []; congruence. + Qed. + Next Obligation. + split. intros. intros []. congruence. intros []; congruence. + Qed. + End InferAux. Program Definition lookup_ind_decl ind : typing_result - ({decl & {body & declared_inductive (fst Σ) decl ind body}}) := + ({decl & {body & declared_inductive (fst Σ) ind decl body}}) := match lookup_env (fst Σ) ind.(inductive_mind) with | Some (InductiveDecl decl) => match nth_error decl.(ind_bodies) ind.(inductive_ind) with @@ -257,6 +574,59 @@ Section Typecheck. destruct check_univs; auto. Qed. + Notation wt_brs Γ ci mdecl idecl p ps ptm ctors brs n := + (All2i (fun i cdecl br => + let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in + ∥ (wf_local Σ (Γ ,,, br.(bcontext)) × + conv_context Σ (Γ ,,, br.(bcontext)) (Γ ,,, brctxty.1)) × + ((Σ ;;; Γ ,,, brctxty.1 |- br.(bbody) : brctxty.2) × + (Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps)) ∥) + n ctors brs). + + Notation infer_ty := + (forall (Γ : context) (HΓ : ∥ wf_local Σ Γ ∥) (t : term), typing_result ({ A : term & ∥ Σ ;;; Γ |- t : A ∥ })). + + Section check_brs. + Context (infer : infer_ty) + (Γ : context) (wfΓ : ∥ wf_local Σ Γ ∥) (ps : Universe.t) + (ci : case_info) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) (p : predicate term) (ptm : term). + + Program Fixpoint check_branches (n : nat) (ctors : list constructor_body) + (brs : list (branch term)) {struct brs} + : typing_result (wt_brs Γ ci mdecl idecl p ps ptm ctors brs n) := + match ctors, brs return typing_result (wt_brs Γ ci mdecl idecl p ps ptm ctors brs n) with + | [], [] => ret (All2i_nil : wt_brs Γ ci mdecl idecl p ps ptm [] [] n) + | cdecl :: cdecls, br :: brs => + let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm n cdecl in + check_br_ctx <- check_context_rel infer Γ br.(bcontext) wfΓ ;; + check_conv_ctx Γ br.(bcontext) brctxty.1 _ _ ;; + Z <- infer_cumul infer (Γ ,,, br.(bcontext)) _ br.(bbody) brctxty.2 _ ;; + X <- check_branches (S n) cdecls brs ;; + ret (t:=wt_brs Γ ci mdecl idecl p ps ptm (cdecl :: cdecls) (br :: brs) n) (All2i_cons _ X) + | [], _ :: _ + | _ :: _, [] => raise (Msg "wrong number of branches") + end. + + Next Obligation. + sq; now apply wf_local_app. + Defined. + Next Obligation. + clear infer. todo "case". + Defined. + Next Obligation. + clear infer. todo "case". + Defined. + Next Obligation. + clear infer. todo "case". + Defined. + Obligation Tactic := idtac. + Next Obligation. + intros. + clear infer. todo "case". + Defined. + End check_brs. + Program Fixpoint infer (Γ : context) (HΓ : ∥ wf_local Σ Γ ∥) (t : term) {struct t} : typing_result ({ A : term & ∥ Σ ;;; Γ |- t : A ∥ }) := match t with @@ -300,7 +670,7 @@ Section Typecheck. match lookup_env (fst Σ) cst with | Some (ConstantDecl d) => check_consistent_instance d.(cst_universes) u ;; - let ty := subst_instance_constr u d.(cst_type) in + let ty := subst_instance u d.(cst_type) in ret (ty; _) | _ => raise (UndeclaredConstant cst) end @@ -308,7 +678,7 @@ Section Typecheck. | tInd ind u => d <- lookup_ind_decl ind ;; check_consistent_instance d.π1.(ind_universes) u ;; - let ty := subst_instance_constr u d.π2.π1.(ind_type) in + let ty := subst_instance u d.π2.π1.(ind_type) in ret (ty; _) | tConstruct ind k u => @@ -320,55 +690,33 @@ Section Typecheck. | None => raise (UndeclaredConstructor ind k) end - | tCase (ind, par) p c brs => + | tCase ci p c brs => cty <- infer Γ HΓ c ;; I <- reduce_to_ind HΣ Γ cty.π1 _ ;; let '(ind'; I') := I in let '(u; I'') := I' in let '(args; H) := I'' in - check_eq_true (eqb ind ind') + check_eq_true (eqb ci.(ci_ind) ind') (* bad case info *) - (NotConvertible G Γ (tInd ind u) (tInd ind' u)) ;; - d <- lookup_ind_decl ind' ;; - let '(decl; d') := d in let '(body; HH) := d' in - check_coind <- check_eq_true (negb (isCoFinite (ind_finite decl))) + (NotConvertible G Γ (tInd ci u) (tInd ind' u)) ;; + d <- lookup_ind_decl ci.(ci_ind) ;; + let '(mdecl; (idecl; isdecl)) := (d : ∑ (mdecl : mutual_inductive_body) + (idecl : one_inductive_body), declared_inductive _ _ _ _) in + check_coind <- check_eq_true (negb (isCoFinite (ind_finite mdecl))) (Msg "Case on coinductives disallowed") ;; - check_eq_true (ind_npars decl =? par) + check_eq_true (eqb (ind_npars mdecl) ci.(ci_npar)) (Msg "not the right number of parameters") ;; - IS <- infer_scheme infer Γ HΓ p ;; - let '(pctx; IS') := IS in let '(ps; typ_p) := IS' in - check_is_allowed_elimination ps (ind_kelim body);; - let pty := mkAssumArity pctx ps in - let params := firstn par args in - match build_case_predicate_type ind decl body params u ps with - | None => raise (Msg "failure in build_case_predicate_type") - | Some pty' => - (* We could avoid one useless sort comparison by only comparing *) - (* the contexts [pctx] and [indctx] (what is done in Coq). *) - match iscumul Γ pty _ pty' _ with - | ConvError e => raise (NotCumulSmaller G Γ pty pty' pty pty' e) - | ConvSuccess => - match map_option_out (build_branches_type ind decl body params u p) with - | None => raise (Msg "failure in build_branches_type") - | Some btys => - let btyswf : ∥ All (isType Σ Γ ∘ snd) btys ∥ := _ in - (fix check_branches (brs btys : list (nat * term)) - (HH : ∥ All (isType Σ Γ ∘ snd) btys ∥) {struct brs} - : typing_result - (All2 (fun br bty => br.1 = bty.1 /\ ∥ Σ ;;; Γ |- br.2 : bty.2 ∥) brs btys) - := match brs, btys with - | [], [] => ret All2_nil - | (n, t) :: brs , (m, A) :: btys => - W <- check_dec (Msg "not nat eq") - (EqDecInstances.nat_eqdec n m) ;; - Z <- infer_cumul infer Γ HΓ t A _ ;; - X <- check_branches brs btys _ ;; - ret (All2_cons (conj _ _) X) - | [], _ :: _ - | _ :: _, [] => raise (Msg "wrong number of branches") - end) brs btys btyswf ;; - ret (mkApps p (List.skipn par args ++ [c]); _) - end - end - end + check_eq_true (eqb (ind_relevance idecl) ci.(ci_relevance)) + (Msg "invalid relevance annotation on case") ;; + wfpctx <- check_context_rel infer Γ p.(pcontext) HΓ ;; + let pctx := case_predicate_context ci.(ci_ind) mdecl idecl p in + check_wfpctx_conv <- check_conv_ctx Γ p.(pcontext) pctx _ _ ;; + retty <- infer_type infer (Γ ,,, p.(pcontext)) _ p.(preturn) ;; + let '(ps; typ_pret) := retty in + check_is_allowed_elimination ps (ind_kelim idecl);; + let ptm := it_mkLambda_or_LetIn pctx p.(preturn) in + let params := firstn ci.(ci_npar) args in + check_brs <- check_branches infer Γ HΓ ps ci mdecl idecl p ptm + 0 idecl.(ind_ctors) brs ;; + ret (mkApps ptm (List.skipn ci.(ci_npar) args ++ [c]); _) | tProj (ind, n, k) c => d <- lookup_ind_decl ind ;; @@ -382,7 +730,7 @@ Section Typecheck. check_eq_true (ind_npars d.π1 =? n) (Msg "not the right number of parameters") ;; let ty := snd pdecl in - ret (subst0 (c :: List.rev args) (subst_instance_constr u ty); + ret (subst0 (c :: List.rev args) (subst_instance u ty); _) | None => raise (Msg "projection not found") end @@ -499,7 +847,7 @@ Section Typecheck. Next Obligation. cbn in *; sq. eapply type_reduction in X1 ; try eassumption. - eapply validity_term in X1 ; try assumption. destruct X1 as [s HH]. + eapply validity in X1 ; try assumption. destruct X1 as [s HH]. eapply inversion_Prod in HH ; try assumption. destruct HH as [s1 [_ [HH _]]]. eexists. eassumption. @@ -529,14 +877,25 @@ Section Typecheck. Defined. (* tCase *) - Next Obligation. simpl; eauto using validity_wf. Qed. - Next Obligation. simpl; eauto using validity_wf. Qed. + Obligation Tactic := intros; Program.Tactics.destruct_conjs; cbn in *; subst. + Next Obligation. sq. eapply validity in X as []; eauto. + eexists; eauto using validity_wf. Defined. + Next Obligation. sq. now eapply wf_local_app. Defined. + Next Obligation. sq. eapply wf_local_app; auto. todo "case". Defined. + Next Obligation. sq. now eapply wf_local_app. Defined. Next Obligation. - destruct X1, X11. sq. - change (eqb ind I = true) in H0. - destruct (eqb_spec ind I) as [e|e]; [destruct e|discriminate]. - change (eqb (ind_npars d) par = true) in H1. - destruct (eqb_spec (ind_npars d) par) as [e|e]; [|discriminate]. + noconf Heq_anonymous. rename filtered_var into mdecl. + destruct H, X6, X7, X8. + noconf Heq_I; noconf Heq_I'; noconf Heq_I''. + noconf Heq_retty. sq. clear H H0 r r1. + rename X0 into idecl. + change (eqb ci.(ci_ind) I = true) in H1. + destruct (eqb_spec ci.(ci_ind) I) as [e|e]; [destruct e|discriminate]. + change (eqb (ind_npars mdecl) ci.(ci_npar) = true) in H2. + destruct (eqb_spec (ind_npars mdecl) ci.(ci_npar)) as [e|e]; [|discriminate]. + rewrite -e /ptm. + todo "case". +(* rename Heq_anonymous into HH. symmetry in HH. simpl in *. rewrite <- e in HH. @@ -548,11 +907,37 @@ Section Typecheck. eapply validity in X; auto. eapply PCUICInductives.isType_it_mkProd_or_LetIn_inv in X; eauto. eapply isType_wf_universes in X; auto. - now exact (elimT wf_universe_reflect X). - Qed. + now exact (elimT wf_universe_reflect X).*) + Defined. + (* The obligation tactic removes useful lets here. *) + Obligation Tactic := idtac. - Next Obligation. - symmetry in Heq_anonymous1. + (*Next Obligation. + intros. + cbn. sq. splits. + - now eapply wf_local_app. + - now eapply conv_ctx_rel_close. + - eapply context_conversion; tea. + eapply wf_local_app; tas. todo "cases". + now eapply conv_ctx_rel_close. + - todo "cases". + Defined.*) + (*Next Obligation. + intros. cbn. subst filtered_var. + idtac; Program.Tactics.destruct_conjs. simpl proj1_sig in *. + cbn in *. + destruct X6, X8, H; noconf Heq_I; noconf Heq_I'; noconf Heq_I''. + noconf Heq_anonymous. noconf Heq_retty. destruct wfpctx as [wfpctx]. + noconf H. + clear H H0. destruct X5 as [Hc]. sq. subst t. + change (eqb ci.(ci_ind) I = true) in H1. + destruct (eqb_spec ci.(ci_ind) I) as [e|e]; [destruct e|discriminate]. + change (eqb (ind_npars d) ci.(ci_npar) = true) in H2. + destruct (eqb_spec (ind_npars d) ci.(ci_npar)) as [e|e]; [|discriminate]. + todo "cases". + (* econstructor; eauto. + todo "case". branches *) + (*symmetry in Heq_anonymous1. unfold iscumul in Heq_anonymous1. simpl in Heq_anonymous1. apply isconv_term_sound in Heq_anonymous1. red in Heq_anonymous1. @@ -567,7 +952,7 @@ Section Typecheck. destruct (eqb_spec (ind_npars d) par) as [e|e]; [|discriminate]; subst. assert (wfΣ : wf_ext Σ) by (split; auto). eapply type_reduction in X11; eauto. - have val:= validity_term wfΣ X11. + have val:= validity wfΣ X11. eapply type_Cumul' in typ_p; [| |eassumption]. 2:{ eapply PCUICInductiveInversion.WfArity_build_case_predicate_type; eauto. eapply validity in typ_p; eauto. @@ -578,22 +963,12 @@ Section Typecheck. have [pctx' da] : (∑ pctx', destArity [] pty' = Some (pctx', X0)). { symmetry in Heq_anonymous0. unshelve eapply (PCUICInductives.build_case_predicate_type_spec (Σ.1, ind_universes d)) in Heq_anonymous0 as [parsubst [_ ->]]. - eauto. eapply (PCUICWeakeningEnv.on_declared_inductive wfΣ) in HH as [? ?]. eauto. + eauto. eapply (PCUICWeakeningEnv.on_declared_inductive wfΣ) as [? ?]. eauto. eexists. rewrite !destArity_it_mkProd_or_LetIn; simpl. reflexivity. } - eapply PCUICInductiveInversion.build_branches_type_wt. 6:eapply typ_p. all:eauto. - Defined. - - Next Obligation. - sq. - depelim HH; auto. - Defined. - Next Obligation. - sq. - depelim HH; auto. - Defined. - - (* The obligation tactic removes a useful let here. *) - Obligation Tactic := idtac. + eapply PCUICInductiveInversion.build_branches_type_wt. 6:eapply typ_p. all:eauto.*) + Defined.*) + +(* Next Obligation. intros. clearbody btyswf. idtac; Program.Tactics.program_simplify. symmetry in Heq_anonymous1. @@ -628,11 +1003,11 @@ Section Typecheck. - destruct isCoFinite; auto. - symmetry; eauto. Defined. - +*) Obligation Tactic := Program.Tactics.program_simplify ; eauto 2. (* tProj *) - Next Obligation. simpl; eauto using validity_wf. Qed. + Next Obligation. simpl; eauto using validity_wf. Defined. Next Obligation. simpl in *; sq; eapply type_Proj with (pdecl := (i, t0)). - split. eassumption. split. symmetry; eassumption. cbn in *. @@ -640,26 +1015,24 @@ Section Typecheck. - cbn. destruct (ssrbool.elimT (eqb_spec ind I)); [assumption|]. eapply type_reduction; eassumption. - eapply type_reduction in X5; eauto. - eapply validity_term in X5; eauto. + eapply validity in X5; eauto. destruct (ssrbool.elimT (eqb_spec ind I)); auto. - unshelve eapply (PCUICInductives.isType_mkApps_Ind _ X7 _) in X5 as [parsubst [argsubst [[sp sp'] cu]]]; eauto. - pose proof (PCUICContexts.context_subst_length2 (PCUICSpine.inst_ctx_subst sp)). - pose proof (PCUICContexts.context_subst_length2 (PCUICSpine.inst_ctx_subst sp')). + unshelve eapply (PCUICInductives.isType_mkApps_Ind_inv _ X7 _) in X5 as [parsubst [argsubst [[sp sp'] cu]]]; eauto. + pose proof (PCUICContextSubst.context_subst_length2 (PCUICSpine.inst_ctx_subst sp)). + pose proof (PCUICContextSubst.context_subst_length2 (PCUICSpine.inst_ctx_subst sp')). autorewrite with len in H, H2. - destruct (PCUICWeakeningEnv.on_declared_inductive HΣ X7) eqn:ond. + destruct (on_declared_inductive X7) eqn:ond. rewrite -o.(onNpars) -H. forward (o0.(onProjections)). intros H'; rewrite H' nth_error_nil // in Heq_anonymous. - destruct ind_cshapes as [|cs []]; auto. + destruct ind_ctors as [|cs []]; auto. intros onps. unshelve epose proof (onps.(on_projs_noidx _ _ _ _ _ _)). - rewrite ond /= in H2. - change (ind_indices o0) with (ind_indices o0) in *. - destruct (ind_indices o0) => //. + destruct (ind_indices X6) => //. simpl in H2. rewrite List.skipn_length in H2. rewrite List.firstn_length. lia. - Qed. + Defined. (* tFix *) Next Obligation. sq. constructor; auto. exists W; auto. Defined. @@ -675,7 +1048,7 @@ Section Typecheck. Next Obligation. clear -XX HΣ. sq. now depelim XX. - Qed. + Defined. Next Obligation. assert (∥ All (fun d => ((Σ;;; Γ ,,, fix_context mfix |- dbody d : (lift0 #|fix_context mfix|) (dtype d)))%type) mfix ∥). { eapply All_sq, All_impl. exact YY. @@ -707,33 +1080,6 @@ Section Typecheck. symmetry; eassumption. Qed. - Lemma sq_wfl_nil : ∥ wf_local Σ [] ∥. - Proof. - repeat constructor. - Qed. - - Program Fixpoint check_context Γ : typing_result (∥ wf_local Σ Γ ∥) - := match Γ with - | [] => ret sq_wfl_nil - | {| decl_body := None; decl_type := A |} :: Γ => - HΓ <- check_context Γ ;; - XX <- infer_type infer Γ HΓ A ;; - ret _ - | {| decl_body := Some t; decl_type := A |} :: Γ => - HΓ <- check_context Γ ;; - XX <- infer_type infer Γ HΓ A ;; - XX <- infer_cumul infer Γ HΓ t A _ ;; - ret _ - end. - Next Obligation. - sq. econstructor; tas. econstructor; eauto. - Qed. - Next Obligation. - sq. econstructor; tea. - Qed. - Next Obligation. - sq. econstructor; tas. econstructor; eauto. - Qed. (* Program Definition check_isWfArity Γ (HΓ : ∥ wf_local Σ Γ ∥) A diff --git a/safechecker/theories/PCUICWfReduction.v b/safechecker/theories/PCUICWfReduction.v index befb3a7a8..1ee278bad 100644 --- a/safechecker/theories/PCUICWfReduction.v +++ b/safechecker/theories/PCUICWfReduction.v @@ -39,12 +39,12 @@ Inductive term_direct_subterm : term -> term -> Type := term_direct_subterm v (tApp u v) | term_direct_subterm_7_2 : forall u v : term, term_direct_subterm u (tApp u v) -| term_direct_subterm_11_1 : forall (indn : inductive × nat) - (p c : term) (brs : list (nat × term)), - term_direct_subterm c (tCase indn p c brs) -| term_direct_subterm_11_2 : forall (indn : inductive × nat) - (p c : term) (brs : list (nat × term)), - term_direct_subterm p (tCase indn p c brs) +| term_direct_subterm_11_1 : forall (ci : case_info) + (p : predicate term) (c : term) (brs : list (branch term)), + term_direct_subterm c (tCase ci p c brs) +| term_direct_subterm_11_2 : forall (ci : case_info) + (p : predicate term) (c : term) (brs : list (branch term)), + term_direct_subterm p.(preturn) (tCase ci p c brs) | term_direct_subterm_12_1 : forall (p : projection) (c : term), term_direct_subterm c (tProj p c). Derive Signature for term_direct_subterm. @@ -54,6 +54,7 @@ Definition term_direct_subterm_context (t u : term) (p : term_direct_subterm t u | 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] + | term_direct_subterm_11_2 ci p c brs => pcontext p | _ => [] end. @@ -123,6 +124,8 @@ Section fix_sigma. split. eapply letin_red_ty; eauto. unshelve eexists. repeat constructor. reflexivity. split. eapply letin_red_def; eauto. unshelve eexists. repeat constructor. reflexivity. + split. eapply case_red_return; eauto. unshelve eexists. repeat constructor. + eapply (term_direct_subterm_11_2 ci (set_preturn p s')). simpl. reflexivity. - simpl. intros. rewrite app_context_assoc in X. specialize (IHts1 _ _ X) as [t' [[yt' [ts Hts]]]]. diff --git a/safechecker/theories/SafeTemplateChecker.v b/safechecker/theories/SafeTemplateChecker.v index 737e3f9d6..4c3a56ff7 100644 --- a/safechecker/theories/SafeTemplateChecker.v +++ b/safechecker/theories/SafeTemplateChecker.v @@ -7,39 +7,42 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping From MetaCoq.SafeChecker Require Import PCUICErrors PCUICSafeChecker. -Program Definition infer_template_program {cf : checker_flags} (p : Ast.program) φ Hφ - : EnvCheck (∑ A, ∥ (trans_global_decls p.1, φ) ;;; [] |- trans p.2 : A ∥) := - p <- typecheck_program (cf:=cf) (trans_global_decls p.1, trans p.2) φ Hφ ;; +Program Definition infer_template_program {cf : checker_flags} (p : Ast.Env.program) φ Hφ + : EnvCheck ( + let Σ' := trans_global_decls p.1 in + ∑ A, ∥ (Σ', φ) ;;; [] |- trans Σ' p.2 : A ∥) := + let Σ' := trans_global_decls p.1 in + p <- typecheck_program (cf:=cf) (Σ', trans Σ' p.2) φ Hφ ;; ret (p.π1 ; _). (** In Coq until 8.11 at least, programs can be ill-formed w.r.t. universes as they don't include all declarations of universes and constraints coming from section variable declarations. - We hence write a program that computes the dangling universes in an Ast.program and registers + We hence write a program that computes the dangling universes in an Ast.Env.program and registers them appropriately. *) Definition update_cst_universes univs cb := - {| Ast.cst_type := cb.(Ast.cst_type); - Ast.cst_body := cb.(Ast.cst_body); - Ast.cst_universes := match cb.(Ast.cst_universes) with + {| Ast.Env.cst_type := cb.(Ast.Env.cst_type); + Ast.Env.cst_body := cb.(Ast.Env.cst_body); + Ast.Env.cst_universes := match cb.(Ast.Env.cst_universes) with | Monomorphic_ctx _ => Monomorphic_ctx univs | x => x end |}. Definition update_mib_universes univs mib := - {| Ast.ind_finite := mib.(Ast.ind_finite); - Ast.ind_npars := mib.(Ast.ind_npars); - Ast.ind_params := mib.(Ast.ind_params); - Ast.ind_bodies := mib.(Ast.ind_bodies); - Ast.ind_universes := match mib.(Ast.ind_universes) with + {| Ast.Env.ind_finite := mib.(Ast.Env.ind_finite); + Ast.Env.ind_npars := mib.(Ast.Env.ind_npars); + Ast.Env.ind_params := mib.(Ast.Env.ind_params); + Ast.Env.ind_bodies := mib.(Ast.Env.ind_bodies); + Ast.Env.ind_universes := match mib.(Ast.Env.ind_universes) with | Monomorphic_ctx _ => Monomorphic_ctx univs | x => x end; - Ast.ind_variance := mib.(Ast.ind_variance) |}. + Ast.Env.ind_variance := mib.(Ast.Env.ind_variance) |}. -Definition update_universes (univs : ContextSet.t) (cb : Ast.global_decl) := +Definition update_universes (univs : ContextSet.t) (cb : Ast.Env.global_decl) := match cb with - | Ast.ConstantDecl cb => Ast.ConstantDecl (update_cst_universes univs cb) - | Ast.InductiveDecl mib => Ast.InductiveDecl (update_mib_universes univs mib) + | Ast.Env.ConstantDecl cb => Ast.Env.ConstantDecl (update_cst_universes univs cb) + | Ast.Env.InductiveDecl mib => Ast.Env.InductiveDecl (update_mib_universes univs mib) end. Definition is_unbound_level declared (l : Level.t) := @@ -84,7 +87,7 @@ Section FoldMap. End FoldMap. -Definition fix_global_env_universes (Σ : Ast.global_env) : Ast.global_env := +Definition fix_global_env_universes (Σ : Ast.Env.global_env) : Ast.Env.global_env := let fix_decl '(kn, decl) declared := let '(declu, declcstrs) := Typing.monomorphic_udecl_decl decl in let declared := LevelSet.union declu declared in @@ -93,16 +96,17 @@ Definition fix_global_env_universes (Σ : Ast.global_env) : Ast.global_env := in fst (fold_map_right fix_decl Σ LevelSet.empty). -Definition fix_program_universes (p : Ast.program) : Ast.program := +Definition fix_program_universes (p : Ast.Env.program) : Ast.Env.program := let '(Σ, t) := p in (fix_global_env_universes Σ, t). -Program Definition infer_and_print_template_program {cf : checker_flags} (p : Ast.program) φ Hφ +Program Definition infer_and_print_template_program {cf : checker_flags} (p : Ast.Env.program) φ Hφ : string + string := let p := fix_program_universes p in match infer_template_program (cf:=cf) p φ Hφ return string + string with | CorrectDecl t => - inl ("Environment is well-formed and " ^ string_of_term (trans p.2) ^ + let Σ' := trans_global_decls p.1 in + inl ("Environment is well-formed and " ^ string_of_term (trans Σ' p.2) ^ " has type: " ^ string_of_term t.π1) | EnvError Σ (AlreadyDeclared id) => inr ("Already declared: " ^ id) @@ -110,7 +114,7 @@ Program Definition infer_and_print_template_program {cf : checker_flags} (p : As inr ("Type error: " ^ string_of_type_error Σ e ^ ", while checking " ^ id) end. -(* Program Definition check_template_program {cf : checker_flags} (p : Ast.program) (ty : Ast.term) *) +(* Program Definition check_template_program {cf : checker_flags} (p : Ast.Env.program) (ty : Ast.Env.term) *) (* : EnvCheck (∥ trans_global (AstUtils.empty_ext (List.rev p.1)) ;;; [] |- trans p.2 : trans ty ∥) := *) (* p <- typecheck_program (cf:=cf) ((trans_global (AstUtils.empty_ext p.1)).1, trans p.2) ;; *) (* wrap_error "During checking of type constraints" (check p.1 _ _ _ (trans ty));; *) @@ -123,7 +127,7 @@ Program Definition infer_and_print_template_program {cf : checker_flags} (p : As (* rewrite <-map_rev in X. *) (* Qed. *) -(* Program Definition typecheck_template_program' {cf : checker_flags} (p : Ast.program) *) +(* Program Definition typecheck_template_program' {cf : checker_flags} (p : Ast.Env.program) *) (* : EnvCheck (∑ A, ∥ Typing.typing (AstUtils.empty_ext (List.rev p.1)) [] p.2 A ∥) := *) (* p <- typecheck_template_program (cf:=cf) p ;; *) (* ret (Monad:=envcheck_monad) (p.π1 ; _). *) diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 16ab96933..2d7a15622 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -3,6 +3,7 @@ # utils theories/utils/MCPrelude.v +theories/utils/MCReflect.v theories/utils/All_Forall.v theories/utils/MCArith.v theories/utils/MCCompare.v @@ -11,6 +12,7 @@ theories/utils/LibHypsNaming.v theories/utils/MCList.v theories/utils/MCOption.v theories/utils/MCProd.v +theories/utils/MCPred.v theories/utils/MCRelations.v theories/utils/MCSquash.v theories/utils/MCString.v @@ -30,6 +32,7 @@ theories/Environment.v theories/Ast.v theories/AstUtils.v theories/Reflect.v +theories/ReflectAst.v theories/Kernames.v theories/Induction.v theories/LiftSubst.v diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index ae326e125..cb9d410fc 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -3,22 +3,20 @@ -R theories MetaCoq.Template # Generated Code by `ls -1 *.ml *.mli` in `template-coq/gen-src` after having compiled `Extraction.v` -gen-src/signature.mli -gen-src/signature.ml -gen-src/classes0.mli -gen-src/classes0.ml -gen-src/eqDec.mli -gen-src/eqDec.ml gen-src/all_Forall.ml gen-src/all_Forall.mli +gen-src/peanoNat.mli +gen-src/peanoNat.ml gen-src/ascii.ml gen-src/ascii.mli gen-src/ast0.ml gen-src/ast0.mli -gen-src/ast_denoter.ml -gen-src/ast_quoter.ml gen-src/astUtils.ml gen-src/astUtils.mli +gen-src/ast_denoter.ml +gen-src/ast_quoter.ml +gen-src/monad_utils.mli +gen-src/monad_utils.ml gen-src/basicAst.ml gen-src/basicAst.mli gen-src/basics.ml @@ -29,78 +27,69 @@ gen-src/binNat.ml gen-src/binNat.mli gen-src/binNums.ml gen-src/binNums.mli -gen-src/binPosDef.ml -gen-src/binPosDef.mli gen-src/binPos.ml gen-src/binPos.mli +gen-src/binPosDef.ml +gen-src/binPosDef.mli gen-src/bool.ml gen-src/bool.mli +gen-src/cRelationClasses.ml +gen-src/cRelationClasses.mli +gen-src/classes0.ml +gen-src/classes0.mli gen-src/common0.ml gen-src/common0.mli gen-src/compare_dec.ml gen-src/compare_dec.mli gen-src/config0.ml gen-src/config0.mli -gen-src/cRelationClasses.ml -gen-src/cRelationClasses.mli gen-src/datatypes.ml gen-src/datatypes.mli gen-src/decimal.ml gen-src/decimal.mli +gen-src/decimalString.ml +gen-src/decimalString.mli gen-src/denoter.ml gen-src/environment.ml gen-src/environment.mli +gen-src/eqDec.ml +gen-src/eqDec.mli +gen-src/eqDecInstances.ml +gen-src/eqDecInstances.mli gen-src/equalities.ml gen-src/equalities.mli gen-src/extractable.ml gen-src/extractable.mli -#gen-src/induction.ml -#gen-src/induction.mli +gen-src/floatOps.ml +gen-src/floatOps.mli +gen-src/induction.ml +gen-src/induction.mli gen-src/int63.ml gen-src/int63.mli - -gen-src/sumbool.mli -gen-src/sumbool.ml -gen-src/zeven.mli -gen-src/zeven.ml -gen-src/zArith_dec.mli -gen-src/zArith_dec.ml -gen-src/zbool.mli -gen-src/zbool.ml -gen-src/zpower.mli -gen-src/zpower.ml -gen-src/specFloat.mli -gen-src/specFloat.ml -gen-src/floatOps.mli -gen-src/floatOps.ml -# gen-src/float64.mli -# gen-src/float64.ml gen-src/liftSubst.ml gen-src/liftSubst.mli gen-src/list0.ml gen-src/list0.mli gen-src/logic0.ml gen-src/logic0.mli -gen-src/logic1.mli gen-src/logic1.ml -gen-src/relation.mli -gen-src/relation.ml -gen-src/mCPrelude.mli -gen-src/mCPrelude.ml +gen-src/logic1.mli +gen-src/logic2.ml +gen-src/logic2.mli gen-src/mCCompare.ml gen-src/mCCompare.mli gen-src/mCList.ml gen-src/mCList.mli gen-src/mCOption.ml gen-src/mCOption.mli +gen-src/mCPrelude.ml +gen-src/mCPrelude.mli gen-src/mCProd.ml gen-src/mCProd.mli +gen-src/mCReflect.ml +gen-src/mCReflect.mli gen-src/mCRelations.ml gen-src/mCRelations.mli -gen-src/primFloat.mli -gen-src/primFloat.ml -gen-src/decimalString.mli -gen-src/decimalString.ml gen-src/mCString.ml gen-src/mCString.mli gen-src/mCUtils.ml @@ -119,39 +108,49 @@ gen-src/nat0.ml gen-src/nat0.mli gen-src/orderedType0.ml gen-src/orderedType0.mli +gen-src/orders.ml +gen-src/orders.mli gen-src/ordersFacts.ml gen-src/ordersFacts.mli gen-src/ordersLists.ml gen-src/ordersLists.mli -gen-src/orders.ml -gen-src/orders.mli gen-src/ordersTac.ml gen-src/ordersTac.mli -gen-src/peanoNat.ml -gen-src/peanoNat.mli gen-src/plugin_core.ml gen-src/plugin_core.mli -gen-src/induction.mli -gen-src/induction.ml -gen-src/eqDecInstances.mli -gen-src/eqDecInstances.ml -gen-src/reflect.mli -gen-src/reflect.ml gen-src/pretty.ml gen-src/pretty.mli -gen-src/reification.ml +gen-src/primFloat.ml +gen-src/primFloat.mli gen-src/quoter.ml +gen-src/reflect.ml +gen-src/reflect.mli +gen-src/reification.ml +gen-src/relation.ml +gen-src/relation.mli gen-src/run_extractable.ml gen-src/run_extractable.mli +gen-src/signature.ml +gen-src/signature.mli +gen-src/specFloat.ml +gen-src/specFloat.mli gen-src/specif.ml gen-src/specif.mli gen-src/string0.ml gen-src/string0.mli +gen-src/sumbool.ml +gen-src/sumbool.mli gen-src/tm_util.ml gen-src/universes0.ml gen-src/universes0.mli -gen-src/univSubst0.ml -gen-src/univSubst0.mli +gen-src/zArith_dec.ml +gen-src/zArith_dec.mli +gen-src/zbool.ml +gen-src/zbool.mli +gen-src/zeven.ml +gen-src/zeven.mli +gen-src/zpower.ml +gen-src/zpower.mli gen-src/metacoq_template_plugin.mlpack diff --git a/template-coq/gen-src/metacoq_template_plugin.mlpack b/template-coq/gen-src/metacoq_template_plugin.mlpack index 56c7d8efa..fa226a08f 100644 --- a/template-coq/gen-src/metacoq_template_plugin.mlpack +++ b/template-coq/gen-src/metacoq_template_plugin.mlpack @@ -33,11 +33,13 @@ EqDecInstances Logic1 Relation MCPrelude +MCReflect MCList MCRelations MCOption MCProd MCCompare +Monad_utils Sumbool Zeven ZArith_dec diff --git a/template-coq/gen-src/specFloat.ml.rej b/template-coq/gen-src/specFloat.ml.rej deleted file mode 100644 index 04dcccf83..000000000 --- a/template-coq/gen-src/specFloat.ml.rej +++ /dev/null @@ -1,16 +0,0 @@ -*************** -*** 4,9 **** - open Datatypes - open Zbool - open Zpower - - type spec_float = - | S754_zero of bool ---- 4,10 ---- - open Datatypes - open Zbool - open Zpower -+ open Float64 - - type spec_float = - | S754_zero of bool diff --git a/template-coq/src/ast_denoter.ml b/template-coq/src/ast_denoter.ml index 99fcb8b26..6d1a004e8 100644 --- a/template-coq/src/ast_denoter.ml +++ b/template-coq/src/ast_denoter.ml @@ -2,9 +2,10 @@ open Names open Constr open BasicAst open Ast0 +open Env open Tm_util -module ExtractionDenoterr = +module BaseExtractionDenoter = struct type t = Ast0.term type quoted_ident = char list @@ -42,7 +43,7 @@ struct type quoted_mind_finiteness = recursivity_kind type quoted_entry = (constant_entry, quoted_mind_entry) sum option - type quoted_context_decl = context_decl + type quoted_context_decl = t context_decl type quoted_context = context type quoted_one_inductive_body = one_inductive_body type quoted_mutual_inductive_body = mutual_inductive_body @@ -81,9 +82,26 @@ struct rarg=rarg x } + let unquote_predicate (x: 't Ast0.predicate) : ('t, quoted_aname, quoted_univ_instance) apredicate = + { + auinst = puinst x; + apars = pparams x; + apcontext = pcontext x; + apreturn = preturn x + } + + let unquote_branch (x : 't Ast0.branch) : ('t, quoted_aname) abranch = + { abcontext = bcontext x; + abbody = bbody x } + + let unquote_case_info (x : BasicAst.case_info) : (quoted_int, quoted_inductive, quoted_relevance) acase_info = + { aci_ind = x.ci_ind; + aci_npar = x.ci_npar; + aci_relevance = x.ci_relevance } + let inspect_term (tt: t):(t, quoted_int, quoted_ident, quoted_aname, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_relevance, quoted_univ_instance, quoted_proj, - quoted_int63, quoted_float64) structure_of_term= + quoted_int63, quoted_float64) structure_of_term = match tt with | Coq_tRel n -> ACoq_tRel n | Coq_tVar v -> ACoq_tVar v @@ -97,7 +115,8 @@ struct | Coq_tConst (a,b) -> ACoq_tConst (a,b) | Coq_tInd (a,b) -> ACoq_tInd (a,b) | Coq_tConstruct (a,b,c) -> ACoq_tConstruct (a,b,c) - | Coq_tCase (a,b,c,d) -> ACoq_tCase (a,b,c,d) + | Coq_tCase (a,b,c,d) -> + ACoq_tCase (unquote_case_info a,unquote_predicate b,c,List.map unquote_branch d) | Coq_tProj (a,b) -> ACoq_tProj (a,b) | Coq_tFix (a,b) -> ACoq_tFix (List.map unquote_def a,b) | Coq_tCoFix (a,b) -> ACoq_tCoFix (List.map unquote_def a,b) @@ -214,8 +233,8 @@ struct end -module ExtractionDenoter = Denoter.Denoter(ExtractionDenoterr) +module ExtractionDenoter = Denoter.Denoter(BaseExtractionDenoter) -include ExtractionDenoterr +include BaseExtractionDenoter include ExtractionDenoter diff --git a/template-coq/src/ast_quoter.ml b/template-coq/src/ast_quoter.ml index a0abb64ad..43f8f2a2c 100644 --- a/template-coq/src/ast_quoter.ml +++ b/template-coq/src/ast_quoter.ml @@ -2,6 +2,7 @@ open Names open Datatypes open BasicAst open Ast0 +open Ast0.Env open Tm_util module ExtractedASTBaseQuoter = @@ -42,7 +43,7 @@ struct type quoted_mind_finiteness = recursivity_kind type quoted_entry = (constant_entry, quoted_mind_entry) sum option - type quoted_context_decl = context_decl + type quoted_context_decl = Ast0.term context_decl type quoted_context = context type quoted_one_inductive_body = one_inductive_body type quoted_mutual_inductive_body = mutual_inductive_body @@ -268,20 +269,33 @@ struct let block = List.rev defs in Coq_tFix (block, a) - let mkCase (ind, npar, r) nargs p c brs = - let info = ((ind, npar), r) in - let branches = List.map2 (fun br nargs -> (nargs, br)) brs nargs in - Coq_tCase (info,p,c,branches) + let mkCase (ind, npar, r) (univs, pars, pctx, pret) c brs = + let info = { ci_ind = ind; ci_npar = npar; ci_relevance = r } in + let pred = { pparams = Array.to_list pars; + puinst = univs; + pcontext = Array.to_list pctx; + preturn = pret } in + let branches = List.map (fun (bctx, br) -> { bcontext = Array.to_list bctx; bbody = br }) brs in + Coq_tCase (info,pred,c,branches) + let mkProj p c = Coq_tProj (p,c) let mkMonomorphic_ctx tm = Universes0.Monomorphic_ctx tm let mkPolymorphic_ctx tm = Universes0.Polymorphic_ctx tm - let mk_one_inductive_body (id, ty, kel, ctr, proj, relevance) = - let ctr = List.map (fun (a, b, c) -> ((a, b), c)) ctr in + let mk_one_inductive_body (id, indices, sort, ty, kel, ctr, proj, relevance) = + let ctr = List.map (fun (name, args, indices, ty, arity) -> + { cstr_name = name; + cstr_args = args; + cstr_indices = indices; + cstr_type = ty; + cstr_arity = arity }) ctr in { ind_name = id; ind_type = ty; - ind_kelim = kel; ind_ctors = ctr; + ind_indices = indices; + ind_sort = sort; + ind_kelim = kel; + ind_ctors = ctr; ind_projs = proj; ind_relevance = relevance } let mk_mutual_inductive_body finite npars params inds uctx variance = diff --git a/template-coq/src/constr_denoter.ml b/template-coq/src/constr_denoter.ml index 2bc45bfbb..3d8630400 100644 --- a/template-coq/src/constr_denoter.ml +++ b/template-coq/src/constr_denoter.ml @@ -29,20 +29,16 @@ struct let unquote_case_info trm = let (h,args) = app_full trm [] in - if constr_equall h c_pair then + if constr_equall h mk_case_info then match args with - _ :: _ :: ind_nparam :: relevance :: [] -> - let (h1,args1) = app_full ind_nparam [] in - if constr_equall h1 c_pair then - (match args1 with - | _ :: _ :: ind :: nparam :: [] -> ((ind, nparam), relevance) - | _ -> bad_term_verb trm "unquote_case_info") - else not_supported_verb trm "unquote_case_info" + | ind :: nparam :: relevance :: [] -> + { aci_ind = ind; + aci_npar = nparam; + aci_relevance = relevance } | _ -> bad_term_verb trm "unquote_case_info" else not_supported_verb trm "unquote_case_info" - let rec unquote_list trm = let (h,args) = app_full trm [] in if constr_equall h c_nil then @@ -344,7 +340,26 @@ struct else not_supported_verb trm "unquote_global_reference" - + let unquote_branch trm = + let (h, args) = app_full trm [] in + if constr_equall h tmk_branch then + match args with + | _ty :: bctx :: bbody :: [] -> + { abcontext = unquote_list bctx; abbody = bbody } + | _ -> bad_term_verb trm "unquote_branch" + else not_supported_verb trm "unquote_branch" + + let unquote_predicate trm = + let (h, args) = app_full trm [] in + if constr_equall h tmk_predicate then + match args with + | _ty :: auinst :: apars :: apcontext :: apreturn :: [] -> + let apars = unquote_list apars in + let apcontext = unquote_list apcontext in + { auinst; apars; apcontext; apreturn } + | _ -> bad_term_verb trm "unquote_predicate" + else not_supported_verb trm "unquote_predicate" + let inspect_term (t:Constr.t) : (Constr.t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_relevance, quoted_univ_instance, quoted_proj, @@ -400,7 +415,8 @@ struct | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure: constructor case")) else if constr_equall h tCase then match args with - info::ty::d::brs::_ -> ACoq_tCase (unquote_case_info info, ty, d, List.map unquote_pair (unquote_list brs)) + info::p::d::brs::_ -> ACoq_tCase (unquote_case_info info, unquote_predicate p, d, + List.map unquote_branch (unquote_list brs)) | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) else if constr_equall h tFix then match args with diff --git a/template-coq/src/constr_quoter.ml b/template-coq/src/constr_quoter.ml index 423187e43..765a6bbbc 100644 --- a/template-coq/src/constr_quoter.ml +++ b/template-coq/src/constr_quoter.ml @@ -70,12 +70,25 @@ struct let mkInd i u = constr_mkApp (tInd, [| i ; u |]) - let mkCase (ind, npar, r) nargs p c brs = - let info = pair (prodl tIndTy tnat) (Lazy.force tRelevance) - (pairl tIndTy tnat ind npar) r in - let branches = List.map2 (fun br nargs -> pairl tnat tTerm nargs br) brs nargs in - let tl = prodl tnat tTerm in - constr_mkApp (tCase, [| info ; p ; c ; to_coq_list tl branches |]) + + + let mk_predicate (uinst, pars, pctx, pret) = + let pars = to_coq_listl tTerm (Array.to_list pars) in + let pctx = to_coq_listl taname (Array.to_list pctx) in + constr_mkApp (tmk_predicate, [| Lazy.force tTerm; uinst; pars; pctx; pret |]) + let mk_branch (bctx, bbody) = + let bctx = to_coq_listl taname (Array.to_list bctx) in + constr_mkApp (tmk_branch, [| Lazy.force tTerm; bctx; bbody |]) + + let mk_case_info (ind, npar, relevance) = + constr_mkApp (mk_case_info, [| ind; npar; relevance |]) + + let mkCase ci p c brs = + let ci = mk_case_info ci in + let p = mk_predicate p in + let branches = List.map mk_branch brs in + let tl = constr_mkApp (tbranchTy, [| Lazy.force tTerm |]) in + constr_mkApp (tCase, [| ci ; p ; c ; to_coq_list tl branches |]) let mkProj kn t = constr_mkApp (tProj, [| kn; t |]) @@ -305,20 +318,15 @@ struct | Sorts.InSProp -> Lazy.force sfProp (* FIXME SProp *) let quote_context_decl na b t = - constr_mkApp (tmkdecl, [| na; quote_optionl tTerm b; t |]) + constr_mkApp (tmkdecl, [| Lazy.force tTerm; na; quote_optionl tTerm b; t |]) let quote_context ctx = - to_coq_listl tcontext_decl ctx - - let mk_ctor_list = - let ctor_list = - lazy (let ctor_info_typ = prod (prodl tident tTerm) (Lazy.force tnat) in - to_coq_list ctor_info_typ) - in - fun ls -> - let ctors = List.map (fun (a,b,c) -> pair (prodl tident tTerm) (Lazy.force tnat) - (pairl tident tTerm a b) c) ls in - (Lazy.force ctor_list) ctors + to_coq_list (constr_mkAppl (tcontext_decl, [| tTerm |])) ctx + + let mk_ctor_list ls = + let ctors = List.map (fun (a,b,c,d,e) -> + constr_mkApp (tBuild_constructor_body, [| a ; b ; to_coq_listl tTerm c ; d ; e |])) ls in + to_coq_listl tconstructor_body ctors let mk_proj_list d = to_coq_list (prodl tident tTerm) @@ -347,10 +355,10 @@ struct let quote_proj ind pars args = pair (prodl tIndTy tnat) (Lazy.force tnat) (pairl tIndTy tnat ind pars) args - let mk_one_inductive_body (a, b, c, d, e, r) = - let d = mk_ctor_list d in - let e = mk_proj_list e in - constr_mkApp (tBuild_one_inductive_body, [| a; b; c; d; e ; r |]) + let mk_one_inductive_body (na, indices, sort, ty, sf, ctors, projs, relevance) = + let ctors = mk_ctor_list ctors in + let projs = mk_proj_list projs in + constr_mkApp (tBuild_one_inductive_body, [| na; indices; sort; ty; sf; ctors; projs; relevance |]) let to_coq_option ty f ind = match ind with diff --git a/template-coq/src/constr_reification.ml b/template-coq/src/constr_reification.ml index e78f965e4..da3ce9694 100644 --- a/template-coq/src/constr_reification.ml +++ b/template-coq/src/constr_reification.ml @@ -138,6 +138,13 @@ struct let tname = ast "name" let tIndTy = ast "inductive" let tmkInd = ast "mkInd" + let tcase_info = ast "case_info" + let mk_case_info = ast "mk_case_info" + + let tpredicateTy = ast "predicate" + let tmk_predicate = ast "mk_predicate" + let tbranchTy = ast "branch" + let tmk_branch = ast "mk_branch" let tmkdecl = ast "mkdecl" let (tTerm,tRel,tVar,tEvar,tSort,tCast,tProd, tLambda,tLetIn,tApp,tCase,tFix,tConstructor,tConst,tInd,tCoFix,tProj,tInt,tFloat) = @@ -198,6 +205,8 @@ struct let (tdef,tmkdef) = (ast "def", ast "mkdef") let (cFinite,cCoFinite,cBiFinite) = (ast "Finite", ast "CoFinite", ast "BiFinite") + let tconstructor_body = ast "constructor_body" + let tBuild_constructor_body = ast "Build_constructor_body" let tone_inductive_body = ast "one_inductive_body" let tBuild_one_inductive_body = ast "Build_one_inductive_body" let tBuild_mutual_inductive_body = ast "Build_mutual_inductive_body" diff --git a/template-coq/src/denoter.ml b/template-coq/src/denoter.ml index 1c673c757..009c20f76 100644 --- a/template-coq/src/denoter.ml +++ b/template-coq/src/denoter.ml @@ -41,6 +41,9 @@ let map_evm (f : 'a -> 'b -> 'a * 'c) (evm : 'a) (l : 'b list) : 'a * ('c list) let evm, res = List.fold_left (fun (evm, l) b -> let evm, c = f evm b in evm, c :: l) (evm, []) l in evm, List.rev res +let array_map_evm (f : 'a -> 'b -> 'a * 'c) (evm : 'a) (l : 'b array) : 'a * ('c array) = + CArray.fold_left_map (fun evm b -> let evm, c = f evm b in evm, c) evm l + let fold_env_evm_right (f : 'a -> 'b -> 'c -> 'a * 'b * 'd) (env : 'a) (evm : 'b) (l : 'c list) : 'a * 'b * ('d list) = List.fold_right (fun b (env, evm, l) -> let env, evm, c = f env evm b in env, evm, c :: l) l (env, evm, []) @@ -102,15 +105,29 @@ struct let i = D.unquote_inductive i in let evm, u = D.unquote_universe_instance evm u in evm, Constr.mkIndU (i, u) - | ACoq_tCase (((i, _), r), ty, d, brs) -> - let ind = D.unquote_inductive i in - let relevance = D.unquote_relevance r in - let evm, ty = aux env evm ty in - let evm, d = aux env evm d in - let evm, brs = map_evm (aux env) evm (List.map snd brs) in - (* todo: reify better case_info *) + | ACoq_tCase (ci, p, c, brs) -> + let ind = D.unquote_inductive ci.aci_ind in + let relevance = D.unquote_relevance ci.aci_relevance in let ci = Inductiveops.make_case_info (Global.env ()) ind relevance Constr.RegularStyle in - evm, Constr.mkCase (ci, ty, d, Array.of_list brs) + let evm, puinst = D.unquote_universe_instance evm p.auinst in + let evm, pars = map_evm (aux env) evm p.apars in + let pars = Array.of_list pars in + let napctx = CArray.map_of_list D.unquote_aname p.apcontext in + let pctx = CaseCompat.case_predicate_context env ci puinst pars napctx in + let evm, pret = aux (Environ.push_rel_context pctx env) evm p.apreturn in + let evm, c = aux env evm c in + let brs = List.map (fun { abcontext = bctx; abbody = bbody } -> + let nabctx = CArray.map_of_list D.unquote_aname bctx in + (nabctx, bbody)) brs in + let brs = CaseCompat.case_branches_contexts env ci puinst pars (Array.of_list brs) in + let denote_br evm (nas, bctx, bbody) = + let evm, bbody = aux (Environ.push_rel_context bctx env) evm bbody in + evm, (nas, bbody) + in + let evm, brs = array_map_evm denote_br evm brs in + (* todo: reify better case_info *) + let (ci, ty, iv, c, brs) = CaseCompat.expand_case env (ci, puinst, pars, (napctx, pret), None, c, brs) in + evm, Constr.mkCase (ci, ty, c, brs) | ACoq_tFix (lbd, i) -> let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, List.map (fun p->p.rarg) lbd) in diff --git a/template-coq/src/quoter.ml b/template-coq/src/quoter.ml index 43442c697..aa2332af3 100644 --- a/template-coq/src/quoter.ml +++ b/template-coq/src/quoter.ml @@ -6,6 +6,11 @@ open Pp open Tm_util open Reification +let inductive_sort mip = + match mip.mind_arity with + | RegularArity s -> s.mind_sort + | TemplateArity ar -> Sorts.sort_of_univ ar.template_level + let cast_prop = ref (false) (* whether Set Template Cast Propositions is on, as needed for erasure in Certicoq *) @@ -54,7 +59,9 @@ sig val mkConst : quoted_kernel_name -> quoted_univ_instance -> t val mkInd : quoted_inductive -> quoted_univ_instance -> t val mkConstruct : quoted_inductive * quoted_int -> quoted_univ_instance -> t - val mkCase : (quoted_inductive * quoted_int * quoted_relevance) -> quoted_int list -> t -> t -> t list -> t + val mkCase : (quoted_inductive * quoted_int * quoted_relevance) -> + (quoted_univ_instance * t array * quoted_aname array * t) -> (* predicate: instance, params, binder names, return type *) + t -> (quoted_aname array * t) list (* branches *) -> t val mkProj : quoted_proj -> t -> t val mkFix : (quoted_int array * quoted_int) * (quoted_aname array * t array * t array) -> t val mkCoFix : quoted_int * (quoted_aname array * t array * t array) -> t @@ -112,11 +119,19 @@ sig val quote_context_decl : quoted_aname -> t option -> t -> quoted_context_decl val quote_context : quoted_context_decl list -> quoted_context - val mk_one_inductive_body : quoted_ident * t (* ind type *) * quoted_sort_family - * (quoted_ident * t (* constr type *) * quoted_int) list - * (quoted_ident * t (* projection type *)) list - * quoted_relevance - -> quoted_one_inductive_body + val mk_one_inductive_body : + quoted_ident * + quoted_context (* ind indices context *) * + quoted_sort (* ind sort *) * + t (* ind type *) * + quoted_sort_family * + (quoted_ident * quoted_context (* arguments context *) * + t list (* indices in the conclusion *) * + t (* constr type *) * + quoted_int (* arity (w/o lets) *)) list * + (quoted_ident * t (* projection type *)) list * + quoted_relevance -> + quoted_one_inductive_body val mk_mutual_inductive_body : quoted_mind_finiteness @@ -184,20 +199,24 @@ struct let quote_binder b = Q.quote_aname b + let quote_name_annots nas = + Array.map quote_binder nas + + let quote_terms quote_term acc env ts = + let acc, ts = + CArray.fold_left_map (fun acc t -> let (x, acc) = quote_term acc env t in acc, x) acc ts + in ts, acc + let quote_term_remember (add_constant : KerName.t -> 'a -> 'a) - (add_inductive : Names.inductive -> 'a -> 'a) = + (add_inductive : Names.inductive -> Declarations.mutual_inductive_body -> 'a -> 'a) = let rec quote_term (acc : 'a) env trm = let aux acc env trm = match Constr.kind trm with | Constr.Rel i -> (Q.mkRel (Q.quote_int (i - 1)), acc) | Constr.Var v -> (Q.mkVar (Q.quote_ident v), acc) | Constr.Evar (n,args) -> - let (acc,args') = - CArray.fold_left_map (fun acc x -> - let (x,acc) = quote_term acc env x in acc,x) - acc args - in + let (args',acc) = quote_terms quote_term acc env args in (Q.mkEvar (Q.quote_int (Evar.repr n)) args', acc) | Constr.Sort s -> (Q.mkSort (Q.quote_sort s), acc) | Constr.Cast (c,k,t) -> @@ -225,10 +244,7 @@ struct | Constr.App (f,xs) -> let (f',acc) = quote_term acc env f in - let (acc,xs') = - CArray.fold_left_map (fun acc x -> - let (x,acc) = quote_term acc env x in acc,x) - acc xs in + let (xs',acc) = quote_terms quote_term acc env xs in (Q.mkApp f' xs', acc) | Constr.Const (c,pu) -> @@ -236,27 +252,33 @@ struct (Q.mkConst (Q.quote_kn kn) (Q.quote_univ_instance pu), add_constant kn acc) | Constr.Construct ((mind,c),pu) -> + let mib = Environ.lookup_mind (fst mind) (snd env) in (Q.mkConstruct (quote_inductive' mind, Q.quote_int (c - 1)) (Q.quote_univ_instance pu), - add_inductive mind acc) + add_inductive mind mib acc) | Constr.Ind (mind,pu) -> (Q.mkInd (quote_inductive' mind) (Q.quote_univ_instance pu), - add_inductive mind acc) + let mib = Environ.lookup_mind (fst mind) (snd env) in + add_inductive mind mib acc) | Constr.Case (ci,typeInfo,discriminant,e) -> - let ind = Q.quote_inductive (Q.quote_kn (Names.MutInd.canonical (fst ci.Constr.ci_ind)), + let ci, u, pars, (predctx, pred), iv, discr, brs = CaseCompat.contract_case (snd env) (ci,typeInfo,None,discriminant,e) in + let ind = Q.quote_inductive (Q.quote_kn (Names.MutInd.canonical (fst ci.Constr.ci_ind)), Q.quote_int (snd ci.Constr.ci_ind)) in - let npar = Q.quote_int ci.Constr.ci_npar in - let (qtypeInfo,acc) = quote_term acc env typeInfo in - let (qdiscriminant,acc) = quote_term acc env discriminant in - let (branches,nargs,acc) = - CArray.fold_left2 (fun (xs,nargs,acc) x narg -> - let (x,acc) = quote_term acc env x in - let narg = Q.quote_int narg in - (x :: xs, narg :: nargs, acc)) - ([],[],acc) e ci.Constr.ci_cstr_nargs in - let q_relevance = Q.quote_relevance ci.Constr.ci_relevance in - (Q.mkCase (ind, npar, q_relevance) (List.rev nargs) qtypeInfo qdiscriminant (List.rev branches), acc) + let npar = Q.quote_int ci.Constr.ci_npar in + let q_relevance = Q.quote_relevance ci.Constr.ci_relevance in + let acc, q_pars = CArray.fold_left_map (fun acc par -> let (qt, acc) = quote_term acc env par in acc, qt) acc pars in + let qu = Q.quote_univ_instance u in + let qpctx = quote_name_annots (CaseCompat.make_annots predctx) in + let (qpred,acc) = quote_term acc (push_rel_context predctx env) pred in + let (qdiscr,acc) = quote_term acc env discr in + let (branches,acc) = + CArray.fold_left2 (fun (bodies,acc) (brctx, bbody) narg -> + let (qbody,acc) = quote_term acc (push_rel_context brctx env) bbody in + let qctx = quote_name_annots (CaseCompat.make_annots brctx) in + ((qctx, qbody) :: bodies, acc)) + ([],acc) brs ci.Constr.ci_cstr_nargs in + (Q.mkCase (ind, npar, q_relevance) (qu, q_pars, qpctx, qpred) qdiscr (List.rev branches), acc) | Constr.Fix fp -> quote_fixpoint acc env fp | Constr.CoFix fp -> quote_cofixpoint acc env fp @@ -266,44 +288,21 @@ struct let arg = Q.quote_int (Projection.arg p) in let p' = Q.quote_proj ind pars arg in let t', acc = quote_term acc env c in - (Q.mkProj p' t', add_inductive (Projection.inductive p) acc) + let mib = Environ.lookup_mind (fst (Projection.inductive p)) (snd env) in + (Q.mkProj p' t', add_inductive (Projection.inductive p) mib acc) | Constr.Int i -> (Q.mkInt (Q.quote_int63 i), acc) | Constr.Float f -> (Q.mkFloat (Q.quote_float64 f), acc) | Constr.Meta _ -> failwith "Meta not supported by TemplateCoq" in - let in_prop, env' = env in - if is_cast_prop () && not in_prop then - let ty = - let trm = EConstr.of_constr trm in - try Retyping.get_type_of env' Evd.empty trm - with e -> - Feedback.msg_debug (str"Anomaly trying to get the type of: " ++ - Printer.pr_econstr_env (snd env) Evd.empty trm); - raise e - in - let sf = - try Retyping.get_sort_family_of env' Evd.empty ty - with e -> - Feedback.msg_debug (str"Anomaly trying to get the sort of: " ++ - Printer.pr_econstr_env (snd env) Evd.empty ty); - raise e - in - if sf == Term.InProp then - aux acc (true, env') - (Constr.mkCast (trm, Constr.DEFAULTcast, - Constr.mkCast (EConstr.to_constr Evd.empty ty, Constr.DEFAULTcast, Constr.mkProp))) - else aux acc env trm - else aux acc env trm + aux acc env trm and quote_recdecl (acc : 'a) env b (ns,ts,ds) = let ctxt = CArray.map2_i (fun i na t -> (Context.Rel.Declaration.LocalAssum (na, Vars.lift i t))) ns ts in let envfix = push_rel_context (CArray.rev_to_list ctxt) env in let ns' = Array.map quote_binder ns in let b' = Q.quote_int b in - let acc, ts' = - CArray.fold_left_map (fun acc t -> let x,acc = quote_term acc env t in acc, x) acc ts in - let acc, ds' = - CArray.fold_left_map (fun acc t -> let x,y = quote_term acc envfix t in y, x) acc ds in + let ts', acc = quote_terms quote_term acc env ts in + let ds', acc = quote_terms quote_term acc envfix ds in ((b',(ns',ts',ds')), acc) and quote_fixpoint acc env ((a,b),decl) = let a' = Array.map Q.quote_int a in @@ -312,8 +311,7 @@ struct and quote_cofixpoint acc env (a,decl) = let (a',decl'),acc = quote_recdecl acc env a decl in (Q.mkCoFix (a',decl'), acc) - and quote_minductive_type (acc : 'a) env (t : MutInd.t) = - let mib = Environ.lookup_mind t (snd env) in + and quote_minductive_type (acc : 'a) env (t : MutInd.t) mib = let uctx = get_abstract_inductive_universes mib.Declarations.mind_universes in let inst = Univ.UContext.instance uctx in let indtys = @@ -324,42 +322,62 @@ struct let envind = push_rel_context (List.rev indtys) env in let ref_name = Q.quote_kn (MutInd.canonical t) in let (ls,acc) = - List.fold_left (fun (ls,acc) oib -> - let named_ctors = - CList.combine3 - (Array.to_list oib.mind_consnames) - (Array.to_list oib.mind_user_lc) - (Array.to_list oib.mind_consnrealargs) - in + List.fold_left (fun (ls,acc) oib -> + let named_ctors = + CList.combine3 + (Array.to_list oib.mind_consnames) + (Array.to_list oib.mind_nf_lc) + (Array.to_list oib.mind_consnrealargs) + in let indty = Inductive.type_of_inductive (snd env) ((mib,oib),inst) in + let indices, pars = + let ctx = oib.mind_arity_ctxt in + CList.chop (List.length ctx - List.length mib.mind_params_ctxt) ctx + in + let indices, acc = quote_rel_context quote_term acc (push_rel_context pars env) indices in let indty, acc = quote_term acc env indty in - let (reified_ctors,acc) = - List.fold_left (fun (ls,acc) (nm,ty,ar) -> - debug (fun () -> Pp.(str "opt_hnf_ctor_types:" ++ spc () ++ - bool !opt_hnf_ctor_types)) ; - let ty = if !opt_hnf_ctor_types then hnf_type (snd envind) ty else ty in - let (ty,acc) = quote_term acc envind ty in - ((Q.quote_ident nm, ty, Q.quote_int ar) :: ls, acc)) - ([],acc) named_ctors - in + let indsort = Q.quote_sort (inductive_sort oib) in + let (reified_ctors,acc) = + List.fold_left (fun (ls,acc) (nm,ty,ar) -> + debug (fun () -> Pp.(str "opt_hnf_ctor_types:" ++ spc () ++ + bool !opt_hnf_ctor_types)) ; + let ctx, concl = ty in + let ty = Term.it_mkProd_or_LetIn concl ctx in + let argctx, parsctx = + CList.chop (List.length ctx - List.length mib.mind_params_ctxt) ctx + in + let envcstr = push_rel_context parsctx envind in + let qargctx, acc = quote_rel_context quote_term acc envcstr argctx in + let qindices, acc = + let hd, args = Constr.decompose_appvect concl in + let pars, args = CArray.chop mib.mind_nparams args in + let envconcl = push_rel_context argctx envcstr in + quote_terms quote_term acc envconcl args + in + let ty = if !opt_hnf_ctor_types then hnf_type (snd envind) ty else ty in + let (ty,acc) = quote_term acc envind ty in + ((Q.quote_ident nm, qargctx, Array.to_list qindices, ty, Q.quote_int ar) :: ls, acc)) + ([],acc) named_ctors + in let projs, acc = match mib.Declarations.mind_record with | PrimRecord [|id, csts, relevance, ps|] -> (* TODO handle mutual records *) - let ctxwolet = Termops.smash_rel_context mib.mind_params_ctxt in - let indty = Constr.mkApp (Constr.mkIndU ((t,0),inst), - Context.Rel.to_extended_vect Constr.mkRel 0 ctxwolet) in - let indbinder = Context.Rel.Declaration.LocalAssum (Context.annotR (Names.Name id),indty) in - let envpars = push_rel_context (indbinder :: ctxwolet) env in - let ps, acc = CArray.fold_right2 (fun cst pb (ls,acc) -> - let (ty, acc) = quote_term acc envpars pb in - let na = Q.quote_ident (Names.Label.to_id cst) in - ((na, ty) :: ls, acc)) csts ps ([],acc) - in ps, acc + let ctxwolet = Termops.smash_rel_context mib.mind_params_ctxt in + let indty = Constr.mkApp (Constr.mkIndU ((t,0),inst), + Context.Rel.to_extended_vect Constr.mkRel 0 ctxwolet) in + let indbinder = Context.Rel.Declaration.LocalAssum (Context.annotR (Names.Name id),indty) in + let envpars = push_rel_context (indbinder :: ctxwolet) env in + let ps, acc = CArray.fold_right2 (fun cst pb (ls,acc) -> + let (ty, acc) = quote_term acc envpars pb in + let na = Q.quote_ident (Names.Label.to_id cst) in + ((na, ty) :: ls, acc)) csts ps ([],acc) + in ps, acc | _ -> [], acc in let sf = Q.quote_sort_family oib.Declarations.mind_kelim in - (Q.quote_ident oib.mind_typename, indty, sf, (List.rev reified_ctors), projs, Q.quote_relevance oib.mind_relevance) :: ls, acc) - ([],acc) (Array.to_list mib.mind_packets) + (Q.quote_ident oib.mind_typename, indices, indsort, indty, sf, + (List.rev reified_ctors), projs, Q.quote_relevance oib.mind_relevance) :: ls, acc) + ([],acc) (Array.to_list mib.mind_packets) in let nparams = Q.quote_int mib.Declarations.mind_nparams in let paramsctx, acc = quote_rel_context quote_term acc env mib.Declarations.mind_params_ctxt in @@ -370,18 +388,19 @@ struct let mind = Q.mk_mutual_inductive_body finite nparams paramsctx bodies uctx var in ref_name, Q.mk_inductive_decl mind, acc in ((fun acc env -> quote_term acc (false, env)), - (fun acc env -> quote_minductive_type acc (false, env))) + (fun acc env t mib -> + quote_minductive_type acc (false, env) t mib)) let quote_term env trm = - let (fn,_) = quote_term_remember (fun _ () -> ()) (fun _ () -> ()) in + let (fn,_) = quote_term_remember (fun _ () -> ()) (fun _ _ () -> ()) in fst (fn () env trm) - let quote_mind_decl env trm = - let (_,fn) = quote_term_remember (fun _ () -> ()) (fun _ () -> ()) in - let (_, indd, _) = fn () env trm in indd + let quote_mind_decl env trm mib = + let (_,fn) = quote_term_remember (fun _ () -> ()) (fun _ _ () -> ()) in + let (_, indd, _) = fn () env trm mib in indd type defType = - Ind of Names.inductive + Ind of Names.inductive * mutual_inductive_body | Const of KerName.t let quote_term_rec bypass env trm = @@ -390,76 +409,76 @@ struct let constants = ref [] in let add quote_term quote_type trm acc = match trm with - | Ind (mi,idx) -> - let t = mi in - if Mindset.mem t !visited_types then () - else - begin - visited_types := Mindset.add t !visited_types ; - let (kn,d,acc) = - try quote_type acc env mi + | Ind ((mi,idx), mib) -> + let t = mi in + if Mindset.mem t !visited_types then () + else + begin + visited_types := Mindset.add t !visited_types ; + let (kn,d,acc) = + try quote_type acc env mi mib with e -> Feedback.msg_debug (str"Exception raised while checking " ++ MutInd.print mi); raise e in - constants := (kn,d) :: !constants - end + constants := (kn,d) :: !constants + end | Const kn -> - if Names.KNset.mem kn !visited_terms then () - else - begin - visited_terms := Names.KNset.add kn !visited_terms ; - let c = Names.Constant.make kn kn in - let cd = Environ.lookup_constant c env in - let body = match cd.const_body with - | Undef _ -> None - | Primitive _ -> CErrors.user_err Pp.(str "Primitives are unsupported by TemplateCoq") - | Def cs -> Some (Mod_subst.force_constr cs) - | OpaqueDef lc -> - if bypass then - let c, univs = Opaqueproof.force_proof Library.indirect_accessor (Environ.opaque_tables env) lc in - let () = match univs with - | Opaqueproof.PrivateMonomorphic () -> () - | Opaqueproof.PrivatePolymorphic (n, csts) -> if not (Univ.ContextSet.is_empty csts && Int.equal n 0) then - CErrors.user_err Pp.(str "Private polymorphic universes not supported by TemplateCoq") - in Some c - else None - in - let tm, acc = - match body with - | None -> None, acc - | Some tm -> try let (tm, acc) = quote_term acc (Global.env ()) tm in - (Some tm, acc) - with e -> - Feedback.msg_debug (str"Exception raised while checking body of " ++ KerName.print kn); - raise e - in - let uctx = quote_universes_decl cd.const_universes in - let ty, acc = - let ty = cd.const_type - (*CHANGE : template polymorphism for definitions was removed. - See: https://github.com/coq/coq/commit/d9530632321c0b470ece6337cda2cf54d02d61eb *) - (* match cd.const_type with - * | RegularArity ty -> ty - * | TemplateArity (ctx,ar) -> - * Constr.it_mkProd_or_LetIn (Constr.mkSort (Sorts.Type ar.template_level)) ctx *) - in - (try quote_term acc (Global.env ()) ty - with e -> - Feedback.msg_debug (str"Exception raised while checking type of " ++ KerName.print kn); - raise e) - in - let cst_bdy = Q.mk_constant_body ty tm uctx in - let decl = Q.mk_constant_decl cst_bdy in - constants := (Q.quote_kn kn, decl) :: !constants - end + if Names.KNset.mem kn !visited_terms then () + else + begin + visited_terms := Names.KNset.add kn !visited_terms ; + let c = Names.Constant.make kn kn in + let cd = Environ.lookup_constant c env in + let body = match cd.const_body with + | Undef _ -> None + | Primitive _ -> CErrors.user_err Pp.(str "Primitives are unsupported by TemplateCoq") + | Def cs -> Some (Mod_subst.force_constr cs) + | OpaqueDef lc -> + if bypass then + let c, univs = Opaqueproof.force_proof Library.indirect_accessor (Environ.opaque_tables env) lc in + let () = match univs with + | Opaqueproof.PrivateMonomorphic () -> () + | Opaqueproof.PrivatePolymorphic (n, csts) -> if not (Univ.ContextSet.is_empty csts && Int.equal n 0) then + CErrors.user_err Pp.(str "Private polymorphic universes not supported by TemplateCoq") + in Some c + else None + in + let tm, acc = + match body with + | None -> None, acc + | Some tm -> try let (tm, acc) = quote_term acc (Global.env ()) tm in + (Some tm, acc) + with e -> + Feedback.msg_debug (str"Exception raised while checking body of " ++ KerName.print kn); + raise e + in + let uctx = quote_universes_decl cd.const_universes in + let ty, acc = + let ty = cd.const_type + (*CHANGE : template polymorphism for definitions was removed. + See: https://github.com/coq/coq/commit/d9530632321c0b470ece6337cda2cf54d02d61eb *) + (* match cd.const_type with + * | RegularArity ty -> ty + * | TemplateArity (ctx,ar) -> + * Constr.it_mkProd_or_LetIn (Constr.mkSort (Sorts.Type ar.template_level)) ctx *) + in + (try quote_term acc (Global.env ()) ty + with e -> + Feedback.msg_debug (str"Exception raised while checking type of " ++ KerName.print kn); + raise e) + in + let cst_bdy = Q.mk_constant_body ty tm uctx in + let decl = Q.mk_constant_decl cst_bdy in + constants := (Q.quote_kn kn, decl) :: !constants + end in let (quote_rem,quote_typ) = let a = ref (fun _ _ _ -> assert false) in let b = ref (fun _ _ _ -> assert false) in let (x,y) = - quote_term_remember (fun x () -> add !a !b (Const x) ()) - (fun y () -> add !a !b (Ind y) ()) + quote_term_remember (fun x () -> add !a !b (Const x) ()) + (fun y mib () -> add !a !b (Ind (y, mib)) ()) in a := x ; b := y ; diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 6910d6364..0a949ccb1 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -43,7 +43,14 @@ let quote_rel_context env ctx = quote_context decls (* todo(gmm): this definition adapted from quoter.ml (the body of quote_minductive_type) *) -let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body = +let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_inductive_body) + : Ast0.Env.mutual_inductive_body = + match quote_mind_decl env t mib with + | Ast0.Env.InductiveDecl mib -> mib + | Ast0.Env.ConstantDecl _ -> assert false + +(* +let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_inductive_body) : Ast0.Env.mutual_inductive_body = let open Declarations in let uctx = get_abstract_inductive_universes mib.mind_universes in let inst = Univ.UContext.instance uctx in @@ -63,13 +70,33 @@ let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_in in let indty = Inductive.type_of_inductive env ((mib,oib),inst) in let indty = quote_term env indty in + let indices, pars = + let ctx = oib.mind_arity_ctxt in + CList.chop (List.length ctx - List.length mib.mind_params_ctxt) ctx + in + let indices = quote_rel_context (push_rel_context pars env) indices in + let indty = quote_term env indty in + let indsort = Q.quote_sort (inductive_sort oib) in let (reified_ctors,acc) = List.fold_left (fun (ls,acc) (nm,ty,ar) -> Tm_util.debug (fun () -> Pp.(str "opt_hnf_ctor_types:" ++ spc () ++ bool !Quoter.opt_hnf_ctor_types)) ; + let ctx, concl = ty in + let ty = Term.it_mkProd_or_LetIn concl ctx in + let argctx, parsctx = + CList.chop (List.length ctx - List.length mib.mind_params_ctxt) ctx + in + let envcstr = push_rel_context parsctx envind in + let qargctx = quote_rel_context envcstr argctx in + let qindices = + let hd, args = Constr.decompose_appvect concl in + let pars, args = CArray.chop mib.mind_nparams args in + let envconcl = push_rel_context argctx envcstr in + List.map (quote_term envconcl) args + in let ty = if !Quoter.opt_hnf_ctor_types then Quoter.hnf_type envind ty else ty in let ty = quote_term acc ty in - ((quote_ident nm, ty, quote_int ar) :: ls, acc)) + ((quote_ident nm, qargctx, Array.to_list qindices, ty, quote_int ar) :: ls, acc)) ([],acc) named_ctors in let projs, acc = @@ -90,7 +117,8 @@ let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_in in let relevance = quote_relevance oib.mind_relevance in let sf = quote_sort_family oib.mind_kelim in - (quote_ident oib.mind_typename, indty, sf, (List.rev reified_ctors), projs, relevance) :: ls, acc) + (quote_ident oib.mind_typename, indty, indsort, indices, sf, + (List.rev reified_ctors), projs, relevance) :: ls, acc) ([],env) (Array.to_list mib.mind_packets) in let nparams = quote_int mib.mind_nparams in @@ -99,7 +127,7 @@ let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_in let bodies = List.map mk_one_inductive_body (List.rev ls) in let finite = quote_mind_finiteness mib.mind_finite in let variance = Option.map (CArray.map_to_list quote_variance) mib.mind_variance in - mk_mutual_inductive_body finite nparams paramsctx bodies uctx variance + mk_mutual_inductive_body finite nparams paramsctx bodies uctx variance*) let to_mie (x : Ast0.mutual_inductive_entry) : Plugin_core.mutual_inductive_entry = failwith "to_mie" @@ -117,10 +145,10 @@ let get_constant_body b = | Primitive _ -> failwith "Primitives not supported by TemplateCoq" (* note(gmm): code taken from quoter.ml (quote_entry_aux) *) -let of_constant_body (env : Environ.env) (cd : Plugin_core.constant_body) : Ast0.constant_body = +let of_constant_body (env : Environ.env) (cd : Plugin_core.constant_body) : Ast0.Env.constant_body = let open Declarations in let {const_body = body; const_type = typ; const_universes = univs} = cd in - Ast0.({cst_type = quote_term env typ; + Ast0.Env.({cst_type = quote_term env typ; cst_body = Option.map (quote_term env) (get_constant_body body); cst_universes = quote_universes_decl univs}) @@ -148,10 +176,10 @@ let to_constr (t : Ast0.term) : Constr.t = let tmOfConstr (t : Constr.t) : Ast0.term tm = Plugin_core.with_env_evm (fun env _ -> tmReturn (quote_term env t)) -let tmOfMib (ti : Names.MutInd.t) (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body tm = +let tmOfMib (ti : Names.MutInd.t) (t : Plugin_core.mutual_inductive_body) : Ast0.Env.mutual_inductive_body tm = Plugin_core.with_env_evm (fun env _ -> tmReturn (of_mib env ti t)) -let tmOfConstantBody (t : Plugin_core.constant_body) : Ast0.constant_body tm = +let tmOfConstantBody (t : Plugin_core.constant_body) : Ast0.Env.constant_body tm = Plugin_core.with_env_evm (fun env _ -> tmReturn (of_constant_body env t)) (* diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index e9f5e6992..a6bb588bd 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -248,7 +248,7 @@ let denote_decl env evm d = let (h, args) = app_full d [] in if constr_equall h tmkdecl then match args with - | name :: body :: typ :: [] -> + | _ty :: name :: body :: typ :: [] -> let name = unquote_aname name in let evm, ty = denote_term env evm typ in let evm, decl = (match unquote_option body with @@ -395,13 +395,14 @@ let rec run_template_program_rec ~poly ?(intactic=false) (k : Environ.env * Evd. let qt = quote_term_rec bypass env trm in k (env, evm, qt) | TmQuoteInd (name, strict) -> - let kn = unquote_kn (reduce_all env evm name) in - let t = quote_mind_decl env (MutInd.make1 kn) in - let _, args = Constr.destApp t in - (match args with - | [|decl|] -> - k (env, evm, decl) - | _ -> bad_term_verb t "anomaly in quoting of inductive types") + let kn = unquote_kn (reduce_all env evm name) in + let kn = MutInd.make1 kn in + let mib = Environ.lookup_mind kn env in + let t = quote_mind_decl env kn mib in + let _, args = Constr.destApp t in + (match args with + | [|decl|] -> k (env, evm, decl) + | _ -> bad_term_verb t "anomaly in quoting of inductive types") | TmQuoteConst (name, bypass, strict) -> let name = unquote_kn (reduce_all env evm name) in let bypass = unquote_bool (reduce_all env evm bypass) in diff --git a/template-coq/src/tm_util.ml b/template-coq/src/tm_util.ml index b2cf92ef8..d2a4ff6e9 100644 --- a/template-coq/src/tm_util.ml +++ b/template-coq/src/tm_util.ml @@ -64,10 +64,174 @@ let bad_term_verb trm rs = ++ spc () ++ str " Error: " ++ str rs) +module CaseCompat = + struct + + open Constr + open Context.Rel.Declaration + open Vars + open Util + open Univ + open Declarations + open Inductive + + (** {6 Changes of representation of Case nodes} *) + + (** Provided: + - a universe instance [u] + - a term substitution [subst] + - name replacements [nas] + [instantiate_context u subst nas ctx] applies both [u] and [subst] to [ctx] + while replacing names using [nas] (order reversed) + *) + let instantiate_context u subst nas ctx = + let rec instantiate i ctx = match ctx with + | [] -> assert (Int.equal i (-1)); [] + | LocalAssum (_, ty) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + LocalAssum (nas.(i), ty) :: ctx + | LocalDef (_, ty, bdy) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + let bdy = substnl subst i (subst_instance_constr u bdy) in + LocalDef (nas.(i), ty, bdy) :: ctx + in + instantiate (Array.length nas - 1) ctx + + let case_predicate_context_gen mip ci u paramsubst nas = + let realdecls, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let self = + let args = Context.Rel.to_extended_vect mkRel 0 mip.mind_arity_ctxt in + let inst = Instance.of_array (Array.init (Instance.length u) Level.var) in + mkApp (mkIndU (ci.ci_ind, inst), args) + in + let realdecls = LocalAssum (Context.anonR, self) :: realdecls in + instantiate_context u paramsubst nas realdecls + + let case_predicate_context env ci u params nas = + let mib = Environ.lookup_mind (fst ci.ci_ind) env in + let mip = mib.mind_packets.(snd ci.ci_ind) in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list params) in + case_predicate_context_gen mip ci u paramsubst nas + + let case_branches_contexts_gen mib ci u params brs = + (* Γ ⊢ c : I@{u} params args *) + (* Γ, indices, self : I@{u} params indices ⊢ p : Type *) + let mip = mib.mind_packets.(snd ci.ci_ind) in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list params) in + (* Expand the branches *) + let subst = paramsubst @ ind_subst (fst ci.ci_ind) mib u in + let ebr = + let build_one_branch i (nas, br) (ctx, _) = + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let ctx = instantiate_context u subst nas ctx in + (nas, ctx, br) + in + Array.map2_i build_one_branch brs mip.mind_nf_lc + in + ebr + + let case_branches_contexts env ci u pars brs = + let mib = Environ.lookup_mind (fst ci.ci_ind) env in + case_branches_contexts_gen mib ci u pars brs + + let expand_case_specif mib (ci, u, params, p, iv, c, br) = + (* Γ ⊢ c : I@{u} params args *) + (* Γ, indices, self : I@{u} params indices ⊢ p : Type *) + let mip = mib.mind_packets.(snd ci.ci_ind) in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list params) in + (* Expand the return clause *) + let ep = + let (nas, p) = p in + let realdecls = case_predicate_context_gen mip ci u paramsubst nas in + Term.it_mkLambda_or_LetIn p realdecls + in + (* Expand the branches *) + let subst = paramsubst @ ind_subst (fst ci.ci_ind) mib u in + let ebr = + let build_one_branch i (nas, br) (ctx, _) = + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let ctx = instantiate_context u subst nas ctx in + Term.it_mkLambda_or_LetIn br ctx + in + Array.map2_i build_one_branch br mip.mind_nf_lc + in + (ci, ep, iv, c, ebr) + + let expand_case env (ci, _, _, _, _, _, _ as case) = + let specif = Environ.lookup_mind (fst ci.ci_ind) env in + expand_case_specif specif case + + let contract_case env (ci, p, iv, c, br) = + let (mib, mip) = lookup_mind_specif env ci.ci_ind in + let (arity, p) = + Term.decompose_lam_n_decls (mip.mind_nrealdecls + 1) p + (*with e -> (* Dynamically eta-expand the predicate *) + let ctx, ty = mip.mind_nf_lc.(i) in + let br = Term.appvectc br (Context.Rel.to_extended_vect mkRel 0 ctx) in + (ctx, br)*) + in + let (u, pms) = match arity with + | LocalAssum (_, ty) :: _ -> + (* Last binder is the self binder for the term being eliminated *) + let (ind, args) = decompose_appvect ty in + let (ind, u) = destInd ind in + let () = assert (Names.eq_ind ind ci.ci_ind) in + let pms = Array.sub args 0 mib.mind_nparams in + (* Unlift the parameters from under the index binders *) + let dummy = List.make mip.mind_nrealdecls mkProp in + let pms = Array.map (fun c -> Vars.substl dummy c) pms in + (u, pms) + | _ -> assert false + in + let p = (arity, p) + in + let map i br = + let (ctx, br) = + try Term.decompose_lam_n_decls mip.mind_consnrealdecls.(i) br + with e -> (* Dynamically eta-expand the branch *) + let ctx, ty = mip.mind_nf_lc.(i) in + let nargs = mip.mind_consnrealdecls.(i) in + let ctx, _ = List.chop nargs ctx in + let br = Term.appvectc (Vars.lift nargs br) (Context.Rel.to_extended_vect mkRel 0 ctx) in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list pms) in + let ctx' = + instantiate_context u (paramsubst @ ind_subst (fst ci.ci_ind) mib u) + (Array.of_list (List.map Context.Rel.Declaration.get_annot ctx)) + ctx + in (ctx', br) + in + (ctx, br) + in + (ci, u, pms, p, iv, c, Array.mapi map br) + + let make_annots ctx = Array.of_list (List.rev_map get_annot ctx) +end + type ('term, 'name, 'nat) adef = { adname : 'name; adtype : 'term; adbody : 'term; rarg : 'nat } type ('term, 'name, 'nat) amfixpoint = ('term, 'name, 'nat) adef list +type ('term, 'name, 'universe_instance) apredicate = + { auinst : 'universe_instance; + apars : 'term list; + apcontext : 'name list; + apreturn : 'term } + +type ('term, 'name) abranch = + { abcontext : 'name list; + abbody : 'term } + +type ('nat, 'inductive, 'relevance) acase_info = + { aci_ind : 'inductive; + aci_npar : 'nat; + aci_relevance : 'relevance } + type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive, 'relevance, 'universe_instance, 'projection, 'int63, 'float64) structure_of_term = | ACoq_tRel of 'nat | ACoq_tVar of 'ident @@ -81,7 +245,9 @@ type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive | ACoq_tConst of 'kername * 'universe_instance | ACoq_tInd of 'inductive * 'universe_instance | ACoq_tConstruct of 'inductive * 'nat * 'universe_instance - | ACoq_tCase of (('inductive * 'nat) * 'relevance) * 'term * 'term * ('nat * 'term) list + | ACoq_tCase of ('nat, 'inductive, 'relevance) acase_info * + ('term, 'name, 'universe_instance) apredicate * + 'term * ('term, 'name) abranch list | ACoq_tProj of 'projection * 'term | ACoq_tFix of ('term, 'name, 'nat) amfixpoint * 'nat | ACoq_tCoFix of ('term, 'name, 'nat) amfixpoint * 'nat diff --git a/template-coq/theories/Ast.v b/template-coq/theories/Ast.v index 4b8a0dfc1..13b3ddac4 100644 --- a/template-coq/theories/Ast.v +++ b/template-coq/theories/Ast.v @@ -2,7 +2,8 @@ From MetaCoq.Template Require Import utils Environment. From MetaCoq.Template Require Export Universes. (* For primitive integers and floats *) -From Coq Require Int63 Floats.PrimFloat. +From Coq Require Int63 Floats.PrimFloat Floats.SpecFloat. +From Coq Require Import Morphisms. (** * AST of Coq kernel terms and kernel data structures @@ -34,6 +35,370 @@ From Coq Require Int63 Floats.PrimFloat. From MetaCoq.Template Require Export BasicAst. +(* Defined here since BasicAst does not have access to universe instances. + Parameterized by term types as they are not yet defined. *) +Record predicate {term} := mk_predicate { + puinst : Instance.t; (* The universe instance *) + pparams : list term; (* The parameters *) + pcontext : list aname; (* Names of binders of indices and inductive application, + in same order as context (i.e. name of "inductive application" + binder is first). Types are obtained from inductive declaration. + Also used for lifting/substitution for the return type. *) + preturn : term; (* The return type *) }. + +Arguments predicate : clear implicits. +Arguments mk_predicate {_}. + +Derive NoConfusion for predicate. +Global Instance predicate_eq_dec term : + Classes.EqDec term -> + Classes.EqDec (predicate 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_of_universe_instance (puinst p) + ^ ",(" ^ String.concat "," (map (string_of_name ∘ binder_name) (pcontext p)) ^ ")" + ^ "," ^ f (preturn p) ^ ")". + +Definition test_predicate {term} + (instf : Instance.t -> bool) (paramf preturnf : term -> bool) (p : predicate term) := + instf p.(puinst) && forallb paramf p.(pparams) && preturnf p.(preturn). + +Definition eqb_predicate {term} (eqb_univ_instance : Instance.t -> Instance.t -> bool) (eqterm : term -> term -> bool) (p p' : predicate term) := + forallb2 eqterm p.(pparams) p'.(pparams) && + 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); + pcontext := p.(pcontext); + preturn := preturnf p.(preturn) |}. + + Lemma map_pparams (p : predicate term) : + map paramf (pparams p) = pparams (map_predicate p). + Proof. reflexivity. Qed. + + Lemma map_preturn (p : predicate term) : + preturnf (preturn p) = preturn (map_predicate p). + Proof. reflexivity. Qed. + + Lemma map_puints (p : predicate term) : + uf (puinst p) = puinst (map_predicate p). + Proof. reflexivity. Qed. + +End map_predicate. + +Lemma map_predicate_map_predicate + {term term' term''} + (finst finst' : Instance.t -> Instance.t) + (f g : term' -> term'') + (f' g' : term -> term') + (p : predicate term) : + map_predicate finst f g (map_predicate finst' f' g' p) = + map_predicate (finst ∘ finst') (f ∘ f') (g ∘ g') p. +Proof. + destruct p; cbv. + f_equal. + apply map_map. +Qed. + +Lemma map_predicate_id {t} x : map_predicate (@id _) (@id t) (@id t) x = id x. +Proof. + destruct x; cbv. + f_equal. + apply map_id. +Qed. +Hint Rewrite @map_predicate_id : map. + +Definition tCasePredProp {term} + (Pparams Preturn : term -> Type) + (p : predicate term) := + All Pparams p.(pparams) × Preturn p.(preturn). + +Lemma map_predicate_eq_spec {A B} (finst finst' : Instance.t -> Instance.t) (f f' g g' : A -> B) (p : predicate A) : + finst (puinst p) = finst' (puinst p) -> + map f (pparams p) = map g (pparams p) -> + f' (preturn p) = g' (preturn p) -> + map_predicate finst f f' p = map_predicate finst' g g' p. +Proof. + intros. unfold map_predicate; f_equal; auto. +Qed. +Hint Resolve map_predicate_eq_spec : all. + +Lemma map_predicate_id_spec {A} finst (f f' : A -> A) (p : predicate A) : + finst (puinst p) = puinst p -> + map f (pparams p) = pparams p -> + f' (preturn p) = preturn p -> + map_predicate finst f f' p = p. +Proof. + unfold map_predicate. + intros -> -> ->; destruct p; auto. +Qed. +Hint Resolve map_predicate_id_spec : all. + +Instance map_predicate_proper {term} : Proper (`=1` ==> `=1` ==> Logic.eq ==> Logic.eq)%signature (@map_predicate term term id). +Proof. + intros eqf0 eqf1 eqf. + intros eqf'0 eqf'1 eqf'. + intros x y ->. + apply map_predicate_eq_spec; auto. + now apply map_ext => x. +Qed. + +Instance map_predicate_proper' {term} f : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_predicate term term id f). +Proof. + intros eqf0 eqf1 eqf. + intros x y ->. + apply map_predicate_eq_spec; auto. +Qed. + +Notation shiftf f k := (fun k' => f (k' + k)). + +Section map_predicate_k. + Context {term : Type}. + Context (uf : Instance.t -> Instance.t). + Context (f : nat -> term -> term). + + Definition map_predicate_k k (p : predicate term) := + {| pparams := map (f k) p.(pparams); + puinst := uf p.(puinst); + pcontext := p.(pcontext); + preturn := f (#|p.(pcontext)| + k) p.(preturn) |}. + + Lemma map_k_pparams k (p : predicate term) : + map (f k) (pparams p) = pparams (map_predicate_k k p). + Proof. reflexivity. Qed. + + Lemma map_k_preturn k (p : predicate term) : + f (#|p.(pcontext)| + k) (preturn p) = preturn (map_predicate_k k p). + Proof. reflexivity. Qed. + + Lemma map_k_pcontext k (p : predicate term) : + pcontext p = pcontext (map_predicate_k k p). + Proof. reflexivity. Qed. + + Lemma map_k_puinst k (p : predicate term) : + uf (puinst p) = puinst (map_predicate_k k p). + Proof. reflexivity. Qed. + + Definition test_predicate_k (instp : Instance.t -> bool) + (p : nat -> term -> bool) k (pred : predicate term) := + instp pred.(puinst) && forallb (p k) pred.(pparams) && + p (#|pred.(pcontext)| + k) pred.(preturn). + +End map_predicate_k. + +Section Branch. + Context {term : Type}. + (* Parameterized by term types as they are not yet defined. *) + Record branch := mk_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 -> + Classes.EqDec branch. + Proof. ltac:(Equations.Prop.Tactics.eqdec_proof). Qed. + + Definition string_of_branch (f : term -> string) (b : branch) := + "([" ^ String.concat "," (map (string_of_name ∘ binder_name) (bcontext b)) ^ "], " + ^ f (bbody b) ^ ")". + + 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. +Arguments branch : clear implicits. + +Section map_branch. + Context {term term' : Type}. + Context (bbodyf : term -> term'). + + Definition map_branch (b : branch term) := + {| bcontext := b.(bcontext); + bbody := bbodyf b.(bbody) |}. + + Lemma map_bbody (b : branch term) : + bbodyf (bbody b) = bbody (map_branch b). + Proof. destruct b; auto. Qed. +End map_branch. + +Lemma map_branch_map_branch + {term term' term''} + (f : term' -> term'') + (f' : term -> term') + (b : branch term) : + map_branch f (map_branch f' b) = + map_branch (f ∘ f') b. +Proof. + destruct b; cbv. + f_equal. +Qed. + +Lemma map_branch_id {t} x : map_branch (@id t) x = id x. +Proof. + destruct x; cbv. + f_equal. +Qed. +Hint Rewrite @map_branch_id : map. + +Lemma map_branch_eq_spec {A B} (f g : A -> B) (x : branch A) : + f (bbody x) = g (bbody x) -> + map_branch f x = map_branch g x. +Proof. + intros. unfold map_branch; f_equal; auto. +Qed. +Hint Resolve map_branch_eq_spec : all. + +Instance map_branch_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_branch term term). +Proof. + intros eqf0 eqf1 eqf. + intros x y ->. + apply map_branch_eq_spec; auto. +Qed. + +Lemma map_branch_id_spec {A} (f : A -> A) (x : branch A) : + f (bbody x) = (bbody x) -> + map_branch f x = x. +Proof. + intros. rewrite (map_branch_eq_spec _ id); auto. destruct x; auto. +Qed. +Hint Resolve map_branch_id_spec : all. + +Lemma map_branches_map_branches + {term term' term''} + (f : term' -> term'') + (f' : term -> term') + (l : list (branch term)) : + map (fun b => map_branch f (map_branch f' b)) l = + map (map_branch (f ∘ f')) l. +Proof. + eapply map_ext => b. apply map_branch_map_branch. +Qed. + +Definition map_branches {term B} (f : term -> B) l := List.map (map_branch f) l. + +Definition tCaseBrsProp {A} (P : A -> Type) (l : list (branch A)) := + All (fun x => P (bbody x)) l. + +Notation map_branches_k f k brs := + (List.map (fun b => map_branch (f (#|b.(bcontext)| + k)) b) brs). + +Notation test_branches_k test k brs := + (List.forallb (fun b => test_branch (test (#|b.(bcontext)| + k)) b) brs). + +Lemma map_branches_k_map_branches_k + {term term' term''} + (f : nat -> term' -> term'') + (g : term -> term') + (f' : nat -> term -> term') k + (l : list (branch term)) : + map (fun b => map_branch (f #|bcontext (map_branch g b)|) (map_branch (f' k) b)) l = + map (fun b => map_branch (f #|bcontext b|) (map_branch (f' k) b)) l. +Proof. + eapply map_ext => b. rewrite map_branch_map_branch. + rewrite map_branch_map_branch. + now apply map_branch_eq_spec. +Qed. + +Lemma case_brs_map_spec {A B} {P : A -> Type} {l} {f g : A -> B} : + tCaseBrsProp P l -> (forall x, P x -> f x = g x) -> + map_branches f l = map_branches g l. +Proof. + intros. red in X. + eapply All_map_eq. eapply All_impl; eauto. simpl; intros. + apply map_branch_eq_spec; eauto. +Qed. + +Lemma case_brs_map_k_spec {A B} {P : A -> Type} {k l} {f g : nat -> A -> B} : + tCaseBrsProp P l -> (forall k x, P x -> f k x = g k x) -> + map_branches_k f k l = map_branches_k g k l. +Proof. + intros. red in X. + eapply All_map_eq. eapply All_impl; eauto. simpl; intros. + apply map_branch_eq_spec; eauto. +Qed. + +Lemma case_brs_forallb_map_spec {A B} {P : A -> Type} {p : A -> bool} + {l} {f g : A -> B} : + tCaseBrsProp P l -> + forallb (test_branch p) l -> + (forall x, P x -> p x -> f x = g x) -> + map (map_branch f) l = map (map_branch g) l. +Proof. + intros. + eapply All_map_eq. red in X. apply forallb_All in H. + eapply All_impl. eapply All_prod. exact X. exact H. + intros [] []; unfold map_branch; cbn. f_equal. now apply H0. +Qed. + +Lemma tfix_forallb_map_spec {A B} {P P' : A -> Prop} {p p'} {l} {f f' g g' : A -> B} : + tFixProp P P' l -> + forallb (test_def p p') l -> + (forall x, P x -> p x -> f x = g x) -> + (forall x, P' x -> p' x -> f' x = g' x) -> + map (map_def f f') l = map (map_def g g') l. +Proof. + intros. + eapply All_map_eq; red in X. apply forallb_All in H. + eapply All_impl. eapply All_prod. exact X. exact H. + intros [] [[] ?]; unfold map_def, test_def in *; cbn in *. rtoProp. + f_equal; eauto. +Qed. + +Ltac apply_spec := + match goal with + | H : All _ _, H' : forallb _ _ = _ |- map _ _ = map _ _ => + eapply (All_forallb_map_spec H H') + | H : All _ _, H' : forallb _ _ = _ |- forallb _ _ = _ => + eapply (All_forallb_forallb_spec H H') + | H : tCaseBrsProp _ _, H' : forallb _ _ = _ |- map _ _ = map _ _ => + eapply (case_brs_forallb_map_spec H H') + | H : All _ _, H' : is_true (forallb _ _) |- map _ _ = map _ _ => + eapply (All_forallb_map_spec H H') + | H : All _ _, H' : is_true (forallb _ _) |- forallb _ _ = _ => + eapply (All_forallb_forallb_spec H H') + | H : tCaseBrsProp _ _, H' : is_true (forallb _ _) |- map _ _ = map _ _ => + eapply (case_brs_forallb_map_spec H H') + | H : tCaseBrsProp _ _ |- map _ _ = map _ _ => + eapply (case_brs_map_spec H) + | H : tFixProp _ _ _, H' : forallb _ _ = _ |- map _ _ = map _ _ => + eapply (tfix_forallb_map_spec H H') + | H : tFixProp _ _ _ |- map _ _ = map _ _ => + eapply (tfix_map_spec H) + | H : All _ _ |- map _ _ = map _ _ => + eapply (All_map_eq H) + | H : All _ _ |- map _ _ = _ => + eapply (All_map_id H) + | H : All _ _ |- is_true (forallb _ _) => + eapply (All_forallb _ _ H); clear H + end. + +Ltac close_All := + match goal with + | H : Forall _ _ |- Forall _ _ => apply (Forall_impl H); clear H; simpl + | H : All _ _ |- All _ _ => apply (All_impl H); clear H; simpl + | H : OnOne2 _ _ _ |- OnOne2 _ _ _ => apply (OnOne2_impl H); clear H; simpl + | H : All2 _ _ _ |- All2 _ _ _ => apply (All2_impl H); clear H; simpl + | H : Forall2 _ _ _ |- Forall2 _ _ _ => apply (Forall2_impl H); clear H; simpl + | H : All _ _ |- All2 _ _ _ => + apply (All_All2 H); clear H; simpl + | H : All2 _ _ _ |- All _ _ => + (apply (All2_All_left H) || apply (All2_All_right H)); clear H; simpl + end. + Inductive term : Type := | tRel (n : nat) | tVar (id : ident) (* For free variables (e.g. in a goal) *) @@ -47,8 +412,8 @@ Inductive term : Type := | tConst (c : kername) (u : Instance.t) | tInd (ind : inductive) (u : Instance.t) | tConstruct (ind : inductive) (idx : nat) (u : Instance.t) -| tCase (ind_nbparams_relevance: inductive*nat*relevance) (type_info:term) - (discr:term) (branches : list (nat * term)) +| tCase (ci : case_info) (type_info:predicate term) + (discr:term) (branches : list (branch term)) | tProj (proj : projection) (t : term) | tFix (mfix : mfixpoint term) (idx : nat) | tCoFix (mfix : mfixpoint term) (idx : nat) @@ -70,6 +435,178 @@ Definition mkApps t us := end 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) + | tEvar ev args => tEvar ev (List.map (lift n k) args) + | tLambda na T M => tLambda na (lift n k T) (lift n (S k) M) + | tApp u v => tApp (lift n k u) (List.map (lift n k) v) + | tProd na A B => tProd na (lift n k A) (lift n (S k) B) + | tCast c kind t => tCast (lift n k c) kind (lift n k t) + | tLetIn na b t b' => tLetIn na (lift n k b) (lift n k t) (lift n (S k) b') + | tCase ind p c brs => + let k' := List.length (pcontext p) + k in + let p' := map_predicate id (lift n k) (lift n k') p in + let brs' := map_branches_k (lift n) k brs in + tCase ind p' (lift n k c) brs' + | tProj p c => tProj p (lift n k c) + | tFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in + tCoFix mfix' idx + | x => x + end. + +Notation lift0 n := (lift n 0). + +(** Parallel substitution: it assumes that all terms in the substitution live in the + same context *) + +Fixpoint subst s k u := + match u with + | tRel n => + if Nat.leb k n then + match nth_error s (n - k) with + | Some b => lift0 k b + | None => tRel (n - List.length s) + end + else tRel n + | tEvar ev args => tEvar ev (List.map (subst s k) args) + | tLambda na T M => tLambda na (subst s k T) (subst s (S k) M) + | tApp u v => mkApps (subst s k u) (List.map (subst s k) v) + | tProd na A B => tProd na (subst s k A) (subst s (S k) B) + | tCast c kind ty => tCast (subst s k c) kind (subst s k ty) + | tLetIn na b ty b' => tLetIn na (subst s k b) (subst s k ty) (subst s (S k) b') + | tCase ind p c brs => + let k' := List.length (pcontext p) + k in + let p' := map_predicate id (subst s k) (subst s k') p in + let brs' := map_branches_k (subst s) k brs in + tCase ind p' (subst s k c) brs' + | tProj p c => tProj p (subst s k c) + | tFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let k' := List.length mfix + k in + let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in + tCoFix mfix' idx + | x => x + end. + +(** Substitutes [t1 ; .. ; tn] in u for [Rel 0; .. Rel (n-1)] *in parallel* *) +Notation subst0 t := (subst t 0). +Definition subst1 t k u := subst [t] k u. +Notation subst10 t := (subst1 t 0). +Notation "M { j := N }" := (subst1 N j M) (at level 10, right associativity). + +Fixpoint closedn k (t : term) : bool := + match t with + | tRel i => Nat.ltb i k + | tEvar ev args => List.forallb (closedn k) args + | tLambda _ T M | tProd _ T M => closedn k T && closedn (S k) M + | tApp u v => closedn k u && List.forallb (closedn k) v + | tCast c kind t => closedn k c && closedn k t + | tLetIn na b t b' => closedn k b && closedn k t && closedn (S k) b' + | tCase ind p c brs => + let k' := List.length (pcontext p) + k in + let p' := test_predicate (fun _ => true) (closedn k) (closedn k') p in + let brs' := test_branches_k closedn k brs in + p' && closedn k c && brs' + | tProj p c => closedn k c + | tFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (closedn k) (closedn k')) mfix + | tCoFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (closedn k) (closedn k')) mfix + | x => true + end. + +Notation closed t := (closedn 0 t). + +Fixpoint noccur_between k n (t : term) : bool := + match t with + | tRel i => Nat.ltb i k && Nat.leb (k + n) i + | tEvar ev args => List.forallb (noccur_between k n) args + | tLambda _ T M | tProd _ T M => noccur_between k n T && noccur_between (S k) n M + | tApp u v => noccur_between k n u && List.forallb (noccur_between k n) v + | tCast c kind t => noccur_between k n c && noccur_between k n t + | tLetIn na b t b' => noccur_between k n b && noccur_between k n t && noccur_between (S k) n b' + | tCase ind p c brs => + let k' := List.length (pcontext p) + k in + let p' := test_predicate (fun _ => true) (noccur_between k n) (noccur_between k' n) p in + let brs' := test_branches_k (fun k => noccur_between k n) k brs in + p' && noccur_between k n c && brs' + | tProj p c => noccur_between k n c + | tFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix + | tCoFix mfix idx => + let k' := List.length mfix + k in + List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix + | x => true + end. + +Instance subst_instance_constr : UnivSubst term := + fix subst_instance_constr u c {struct c} : term := + match c with + | tRel _ | tVar _ | tInt _ | tFloat _ => c + | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) + | tSort s => tSort (subst_instance_univ u s) + | tConst c u' => tConst c (subst_instance_instance u u') + | tInd i u' => tInd i (subst_instance_instance u u') + | tConstruct ind k u' => tConstruct ind k (subst_instance_instance u u') + | tLambda na T M => tLambda na (subst_instance_constr u T) (subst_instance_constr u M) + | tApp f v => tApp (subst_instance_constr u f) (List.map (subst_instance_constr u) v) + | tProd na A B => tProd na (subst_instance_constr u A) (subst_instance_constr u B) + | tCast c kind ty => tCast (subst_instance_constr u c) kind (subst_instance_constr u ty) + | tLetIn na b ty b' => tLetIn na (subst_instance_constr u b) (subst_instance_constr u ty) + (subst_instance_constr u b') + | tCase ind p c brs => + let p' := map_predicate (subst_instance_instance u) (subst_instance_constr u) (subst_instance_constr u) p in + let brs' := List.map (map_branch (subst_instance_constr u)) brs in + tCase ind p' (subst_instance_constr u c) brs' + | tProj p c => tProj p (subst_instance_constr u c) + | tFix mfix idx => + let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in + tFix mfix' idx + | tCoFix mfix idx => + let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in + tCoFix mfix' idx + end. + +(** Tests that the term is closed over [k] universe variables *) +Fixpoint closedu (k : nat) (t : term) : bool := + match t with + | tSort univ => closedu_universe k univ + | tInd _ u => closedu_instance k u + | tConstruct _ _ u => closedu_instance k u + | tConst _ u => closedu_instance k u + | tRel i => true + | tEvar ev args => forallb (closedu k) args + | tLambda _ T M | tProd _ T M => closedu k T && closedu k M + | tApp u v => closedu k u && forallb (closedu k) v + | tCast c kind t => closedu k c && closedu k t + | tLetIn na b t b' => closedu k b && closedu k t && closedu k b' + | tCase ind p c brs => + let p' := test_predicate (closedu_instance k) (closedu k) (closedu k) p in + let brs' := forallb (test_branch (closedu k)) brs in + p' && closedu k c && brs' + | tProj p c => closedu k c + | tFix mfix idx => + forallb (test_def (closedu k) (closedu k)) mfix + | tCoFix mfix idx => + forallb (test_def (closedu k) (closedu k)) mfix + | x => true + end. + Module TemplateTerm <: Term. Definition term := term. @@ -83,15 +620,25 @@ Definition tInd := tInd. Definition tProj := tProj. Definition mkApps := mkApps. +Definition lift := lift. +Definition subst := subst. +Definition closedn := closedn. +Definition noccur_between := noccur_between. +Definition subst_instance_constr := subst_instance. + End TemplateTerm. Ltac unf_term := unfold TemplateTerm.term in *; unfold TemplateTerm.tRel in *; unfold TemplateTerm.tSort in *; unfold TemplateTerm.tProd in *; unfold TemplateTerm.tLambda in *; unfold TemplateTerm.tLetIn in *; - unfold TemplateTerm.tInd in *; unfold TemplateTerm.tProj in *. - -Module TemplateEnvironment := Environment TemplateTerm. -Include TemplateEnvironment. + unfold TemplateTerm.tInd in *; unfold TemplateTerm.tProj in *; + unfold TemplateTerm.lift in *; unfold TemplateTerm.subst in *; + unfold TemplateTerm.closedn in *; unfold TemplateTerm.noccur_between in *; + unfold TemplateTerm.subst_instance_constr in *. + +Module Env := Environment TemplateTerm. +Export Env. +(* Do NOT `Include` this module, as this would sadly duplicate the rewrite database... *) Definition mkApp t u := Eval cbn in mkApps t [u]. @@ -122,7 +669,11 @@ Inductive wf : term -> Prop := | wf_tConst k u : wf (tConst k u) | wf_tInd i u : wf (tInd i u) | wf_tConstruct i k u : wf (tConstruct i k u) -| wf_tCase ci p c brs : wf p -> wf c -> Forall (wf ∘ snd) brs -> wf (tCase ci p c brs) +| wf_tCase ci p c brs : + Forall wf (pparams p) -> wf (preturn p) -> + wf c -> + Forall (wf ∘ bbody) brs -> + wf (tCase ci p c brs) | wf_tProj p t : wf t -> wf (tProj p t) | wf_tFix mfix k : Forall (fun def => wf def.(dtype) /\ wf def.(dbody)) mfix -> wf (tFix mfix k) @@ -194,3 +745,46 @@ Record mutual_inductive_entry := { mind_entry_private : option bool (* Private flag for sealing an inductive definition in an enclosing module. Not handled by Template Coq yet. *) }. + +(** Helpers for "compact" case representation, reconstructing predicate and + branch contexts. *) + +Definition case_predicate_context ind mdecl idecl params puinst pctx : context := + let indty := mkApps (tInd ind puinst) (map (lift0 #|idecl.(ind_indices)|) params ++ to_extended_list idecl.(ind_indices)) in + let inddecl := + {| decl_name := + {| binder_name := nNamed (ind_name idecl); binder_relevance := idecl.(ind_relevance) |}; + decl_body := None; + decl_type := indty |} + in + let ictx := + subst_context params 0 + (subst_instance puinst (expand_lets_ctx mdecl.(ind_params) idecl.(ind_indices))) + in + map2 set_binder_name pctx (inddecl :: ictx). + +Definition case_branch_context_gen params puinst cdecl : context := + subst_context params 0 (subst_instance puinst cdecl.(cstr_args)). + +Definition case_branch_context p cdecl : context := + case_branch_context_gen p.(pparams) p.(puinst) cdecl. + +Definition case_branches_contexts_gen idecl params puinst : list context := + map (case_branch_context_gen params puinst) idecl.(ind_ctors). + +Definition case_branches_contexts idecl p : list context := + map (case_branch_context_gen p.(pparams) p.(puinst)) idecl.(ind_ctors). + +Definition case_branch_type_gen ind params puinst ptm i cdecl : context * term := + let cstr := tConstruct ind i puinst in + let args := to_extended_list cdecl.(cstr_args) in + let cstrapp := mkApps cstr (map (lift0 #|cdecl.(cstr_args)|) params ++ args) in + let brctx := subst_context params 0 (subst_instance puinst cdecl.(cstr_args)) in + let ty := mkApps (lift0 #|cdecl.(cstr_args)| ptm) (cdecl.(cstr_indices) ++ [cstrapp]) in + (brctx, ty). + +Definition case_branches_types_gen ind idecl params puinst ptm : list (context * term) := + mapi (case_branch_type_gen ind params puinst ptm) idecl.(ind_ctors). + +Definition case_branches_types ind idecl p ptm : list (context * term) := + mapi (case_branch_type_gen ind p.(pparams) p.(puinst) ptm) idecl.(ind_ctors). \ No newline at end of file diff --git a/template-coq/theories/AstUtils.v b/template-coq/theories/AstUtils.v index 76a3786b1..265134b19 100644 --- a/template-coq/theories/AstUtils.v +++ b/template-coq/theories/AstUtils.v @@ -1,7 +1,7 @@ (* For primitive integers and floats *) From Coq Require Numbers.Cyclic.Int63.Int63 Floats.PrimFloat. (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import utils BasicAst Ast. +From MetaCoq.Template Require Import utils BasicAst Ast Environment monad_utils. Require Import ssreflect. Require Import ZArith. @@ -40,13 +40,11 @@ Fixpoint string_of_term (t : term) := | tInd i u => "Ind(" ^ string_of_inductive i ^ "," ^ string_of_universe_instance u ^ ")" | tConstruct i n u => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ "," ^ string_of_universe_instance u ^ ")" - | tCase (ind, i, r) t p brs => - "Case(" ^ string_of_inductive ind ^ "," - ^ string_of_nat i ^ "," - ^ string_of_relevance r ^ "," + | tCase ci p t brs => + "Case(" ^ string_of_case_info ci ^ "," + ^ string_of_predicate string_of_term p ^ "," ^ string_of_term t ^ "," - ^ string_of_term p ^ "," - ^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")" + ^ string_of_list (string_of_branch string_of_term) brs ^ ")" | tProj (ind, i, k) c => "Proj(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_nat k ^ "," ^ string_of_term c ^ ")" @@ -138,15 +136,14 @@ apply (List.firstn decl.(ind_npars)) in types. refine (map (fun '(x, ty) => vass x ty) (combine names types)). - refine (List.map _ decl.(ind_bodies)). intros []. - refine {| mind_entry_typename := ind_name; - mind_entry_arity := remove_arity decl.(ind_npars) ind_type; + refine {| mind_entry_typename := ind_name0; + mind_entry_arity := remove_arity decl.(ind_npars) ind_type0; mind_entry_template := false; mind_entry_consnames := _; mind_entry_lc := _; |}. - refine (List.map (fun x => fst (fst x)) ind_ctors). - refine (List.map (fun x => remove_arity decl.(ind_npars) - (snd (fst x))) ind_ctors). + refine (List.map (fun x => cstr_name x) ind_ctors0). + refine (List.map (fun x => remove_arity decl.(ind_npars) (cstr_type x)) ind_ctors0). Defined. Fixpoint strip_casts t := @@ -158,8 +155,9 @@ Fixpoint strip_casts t := | tCast c kind t => strip_casts c | tLetIn na b t b' => tLetIn na (strip_casts b) (strip_casts t) (strip_casts b') | tCase ind p c brs => - let brs' := List.map (on_snd (strip_casts)) brs in - tCase ind (strip_casts p) (strip_casts c) brs' + let p' := map_predicate id strip_casts strip_casts p 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 => let mfix' := List.map (map_def strip_casts strip_casts) mfix in @@ -195,6 +193,17 @@ Fixpoint decompose_prod_n_assum (Γ : context) n (t : term) : option (context * end end. +Fixpoint decompose_lam_n_assum (Γ : context) n (t : term) : option (context * term) := + match n with + | 0 => Some (Γ, t) + | S n => + match strip_outer_cast t with + | tLambda na A B => decompose_prod_n_assum (Γ ,, vass na A) n B + | tLetIn na b bty b' => decompose_prod_n_assum (Γ ,, vdef na b bty) n b' + | _ => None + end + end. + Lemma decompose_prod_n_assum_it_mkProd ctx ctx' ty : decompose_prod_n_assum ctx #|ctx'| (it_mkProd_or_LetIn ctx' ty) = Some (ctx' ++ ctx, ty). Proof. @@ -229,3 +238,92 @@ Definition isConstruct_app t := | tConstruct _ _ _ => true | _ => false 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 => + match nth_error mdecl.(ind_bodies) (inductive_ind ind) with + | Some idecl => Some (mdecl, idecl) + | None => None + end + | None => None + end. + +Definition destInd (t : term) := + match t with + | tInd ind u => Some (ind, u) + | _ => None + end. + +Definition forget_types {term} (c : list (BasicAst.context_decl term)) : list aname := + map decl_name c. + +Definition mkCase_old (Σ : global_env) (ci : case_info) (p : term) (c : term) (brs : list (nat × term)) : option term := + '(mib, oib) <- lookup_inductive Σ ci.(ci_ind) ;; + '(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 => + 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 + end ;; + let p' := + {| puinst := puinst; pparams := pparams; pcontext := pctx; preturn := preturn |} + in + brs' <- + 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 ;; + ret (tCase ci p' c brs'). + +Definition default_sort_family (u : Universe.t) : allowed_eliminations := + if Universe.is_sprop u then IntoAny + else if Universe.is_prop u then IntoPropSProp + else IntoAny. + +Definition default_relevance (u : Universe.t) : relevance := + if Universe.is_sprop u then Irrelevant + else Relevant. + +(** 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 [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). *) +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) + (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). *) +Definition make_inductive_body (id : ident) (params : context) (indices : context) + (u : Universe.t) (ind_ctors : list constructor_body) : one_inductive_body := + {| ind_name := id; + ind_indices := indices; + ind_sort := u; + ind_type := it_mkProd_or_LetIn (params ,,, indices) (tSort u); + ind_kelim := default_sort_family u; + ind_ctors := ind_ctors; + ind_projs := []; + ind_relevance := default_relevance u |}. \ No newline at end of file diff --git a/template-coq/theories/BasicAst.v b/template-coq/theories/BasicAst.v index e521dec0b..a07c16205 100644 --- a/template-coq/theories/BasicAst.v +++ b/template-coq/theories/BasicAst.v @@ -1,6 +1,7 @@ (* Distributed under the terms of the MIT license. *) +From Coq Require Import ssreflect Morphisms. From MetaCoq.Template Require Import utils. -From Coq Require Import Floats.SpecFloat. +From Coq Require Floats.SpecFloat. (** ** Reification of names ** *) @@ -93,13 +94,19 @@ Proof. ltac:(Equations.Prop.Tactics.eqdec_proof). Qed. Definition map_binder_annot {A B} (f : A -> B) (b : binder_annot A) : binder_annot B := {| binder_name := f b.(binder_name); binder_relevance := b.(binder_relevance) |}. -Definition eq_binder_annot {A} (b b' : binder_annot A) : Prop := +Definition eq_binder_annot {A B} (b : binder_annot A) (b' : binder_annot B) : Prop := b.(binder_relevance) = b'.(binder_relevance). (** Type of annotated names *) Definition aname := binder_annot name. Instance anqme_eqdec : Classes.EqDec aname := _. +Definition eqb_binder_annot {A} (b b' : binder_annot A) : bool := + match Classes.eq_dec b.(binder_relevance) b'.(binder_relevance) with + | left _ => true + | right _ => false + end. + Definition string_of_name (na : name) := match na with | nAnon => "_" @@ -191,14 +198,14 @@ Definition eq_projection p p' := Lemma eq_inductive_refl i : eq_inductive i i. Proof. destruct i as [mind k]. - unfold eq_inductive. now rewrite eq_kername_refl, PeanoNat.Nat.eqb_refl. + unfold eq_inductive. now rewrite eq_kername_refl PeanoNat.Nat.eqb_refl. Qed. Lemma eq_projection_refl i : eq_projection i i. Proof. destruct i as [[mind k] p]. unfold eq_projection. - now rewrite eq_inductive_refl, !PeanoNat.Nat.eqb_refl. + now rewrite eq_inductive_refl !PeanoNat.Nat.eqb_refl. Qed. (** The kind of a cast *) @@ -209,6 +216,14 @@ Inductive cast_kind : Set := | RevertCast. Derive NoConfusion EqDec for cast_kind. +Record case_info := mk_case_info { ci_ind : inductive; ci_npar : nat; ci_relevance : relevance }. +Derive NoConfusion EqDec for case_info. + +Definition string_of_case_info ci := + "(" ^ string_of_inductive ci.(ci_ind) ^ "," ^ + string_of_nat ci.(ci_npar) ^ "," ^ + string_of_relevance ci.(ci_relevance) ^ ")". + Inductive recursivity_kind := | Finite (* = inductive *) | CoFinite (* = coinductive *) @@ -269,9 +284,6 @@ Definition mfixpoint term := list (def term). Definition test_def {A} (tyf bodyf : A -> bool) (d : def A) := tyf d.(dtype) && bodyf d.(dbody). -Definition tCaseBrsProp {A} (P : A -> Type) (l : list (nat * A)) := - All (fun x => P (snd x)) l. - Definition tFixProp {A} (P P' : A -> Type) (m : mfixpoint A) := All (fun x : def A => P x.(dtype) * P' x.(dbody))%type m. @@ -295,17 +307,41 @@ Lemma map_def_spec {A B} (P P' : A -> Type) (f f' g g' : A -> B) (x : def A) : map_def f f' x = map_def g g' x. Proof. intros. destruct x. unfold map_def. simpl. - now rewrite !H, !H0. + now rewrite !H // !H0. +Qed. + +Hint Extern 10 (_ < _)%nat => lia : all. +Hint Extern 10 (_ <= _)%nat => lia : all. +Hint Extern 10 (@eq nat _ _) => lia : all. +Hint Extern 0 (_ = _) => progress f_equal : all. +Hint Unfold on_snd snd : all. + +Lemma on_snd_eq_id_spec {A B} (f : B -> B) (x : A * B) : + f (snd x) = snd x <-> + on_snd f x = x. +Proof. + destruct x; simpl; unfold on_snd; simpl. split; congruence. Qed. +Hint Resolve -> on_snd_eq_id_spec : all. +Hint Resolve -> on_snd_eq_spec : all. -Lemma case_brs_map_spec {A B} {P : A -> Type} {l} {f g : A -> B} : - tCaseBrsProp P l -> (forall x, P x -> f x = g x) -> - map (on_snd f) l = map (on_snd g) l. +Lemma map_def_eq_spec {A B} (f f' g g' : A -> B) (x : def A) : + f (dtype x) = g (dtype x) -> + f' (dbody x) = g' (dbody x) -> + map_def f f' x = map_def g g' x. Proof. - intros. red in X. - eapply All_map_eq. eapply All_impl; eauto. simpl; intros. - apply on_snd_eq_spec; eauto. + intros. unfold map_def; f_equal; auto. Qed. +Hint Resolve map_def_eq_spec : all. + +Lemma map_def_id_spec {A} (f f' : A -> A) (x : def A) : + f (dtype x) = (dtype x) -> + f' (dbody x) = (dbody x) -> + map_def f f' x = x. +Proof. + intros. rewrite (map_def_eq_spec _ _ id id); auto. destruct x; auto. +Qed. +Hint Resolve map_def_id_spec : all. Lemma tfix_map_spec {A B} {P P' : A -> Type} {l} {f f' g g' : A -> B} : tFixProp P P' l -> (forall x, P x -> f x = g x) -> @@ -318,73 +354,135 @@ Proof. eapply map_def_spec; eauto. Qed. -Lemma case_brs_forallb_map_spec {A B} {P : A -> Type} {p : A -> bool} - {l} {f g : A -> B} : - tCaseBrsProp P l -> - forallb (test_snd p) l -> - (forall x, P x -> p x -> f x = g x) -> - map (on_snd f) l = map (on_snd g) l. +Section Contexts. + Context {term : Type}. + (** *** The context of De Bruijn indices *) + + Record context_decl := mkdecl { + decl_name : aname ; + decl_body : option term ; + decl_type : term + }. + 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' := + {| decl_name := d.(decl_name); + decl_body := option_map f d.(decl_body); + decl_type := f d.(decl_type) |}. + +Lemma compose_map_decl {term term' term''} (g : term -> term') (f : term' -> term'') x : + map_decl f (map_decl g x) = map_decl (f ∘ g) x. Proof. - intros. - eapply All_map_eq. red in X. apply forallb_All in H. - eapply All_impl. eapply All_prod. exact X. exact H. - intros [] []; unfold on_snd; cbn. f_equal. now apply H0. + 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. + now rewrite (H t). Qed. -Lemma tfix_forallb_map_spec {A B} {P P' : A -> Prop} {p p'} {l} {f f' g g' : A -> B} : - tFixProp P P' l -> - forallb (test_def p p') l -> - (forall x, P x -> p x -> f x = g x) -> - (forall x, P' x -> p' x -> f' x = g' x) -> - map (map_def f f') l = map (map_def g g') l. +Instance map_decl_proper {term term'} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_decl term term'). Proof. - intros. - eapply All_map_eq; red in X. apply forallb_All in H. - eapply All_impl. eapply All_prod. exact X. exact H. - intros [] [[] ?]; unfold map_def, test_def in *; cbn in *. rtoProp. - f_equal; eauto. + intros f g Hfg x y ->. now apply map_decl_ext. Qed. -Ltac apply_spec := - match goal with - | H : All _ _, H' : forallb _ _ = _ |- map _ _ = map _ _ => - eapply (All_forallb_map_spec H H') - | H : All _ _, H' : forallb _ _ = _ |- forallb _ _ = _ => - eapply (All_forallb_forallb_spec H H') - | H : tCaseBrsProp _ _, H' : forallb _ _ = _ |- map _ _ = map _ _ => - eapply (case_brs_forallb_map_spec H H') - | H : All _ _, H' : is_true (forallb _ _) |- map _ _ = map _ _ => - eapply (All_forallb_map_spec H H') - | H : All _ _, H' : is_true (forallb _ _) |- forallb _ _ = _ => - eapply (All_forallb_forallb_spec H H') - | H : tCaseBrsProp _ _, H' : is_true (forallb _ _) |- map _ _ = map _ _ => - eapply (case_brs_forallb_map_spec H H') - | H : tCaseBrsProp _ _ |- map _ _ = map _ _ => - eapply (case_brs_map_spec H) - | H : tFixProp _ _ _, H' : forallb _ _ = _ |- map _ _ = map _ _ => - eapply (tfix_forallb_map_spec H H') - | H : tFixProp _ _ _ |- map _ _ = map _ _ => - eapply (tfix_map_spec H) - | H : All _ _ |- map _ _ = map _ _ => - eapply (All_map_eq H) - | H : All _ _ |- map _ _ = _ => - eapply (All_map_id H) - | H : All _ _ |- is_true (forallb _ _) => - eapply (All_forallb _ _ H); clear H - end. +Instance map_decl_pointwise {term term'} : Proper (`=1` ==> `=1`) (@map_decl term term'). +Proof. intros f g Hfg x. rewrite /map_decl. + destruct x => /=. f_equal. + - now rewrite Hfg. + - apply Hfg. +Qed. +(* -Ltac close_All := - match goal with - | H : Forall _ _ |- Forall _ _ => apply (Forall_impl H); clear H; simpl - | H : All _ _ |- All _ _ => apply (All_impl H); clear H; simpl - | H : OnOne2 _ _ _ |- OnOne2 _ _ _ => apply (OnOne2_impl H); clear H; simpl - | H : All2 _ _ _ |- All2 _ _ _ => apply (All2_impl H); clear H; simpl - | H : Forall2 _ _ _ |- Forall2 _ _ _ => apply (Forall2_impl H); clear H; simpl - | H : All _ _ |- All2 _ _ _ => - apply (All_All2 H); clear H; simpl - | H : All2 _ _ _ |- All _ _ => - (apply (All2_All_left H) || apply (All2_All_right H)); clear H; simpl +Instance pointwise_subrelation {A B} : subrelation (`=1`) (@Logic.eq A ==> @Logic.eq B)%signature. +Proof. + intros f g Hfg x y ->. now rewrite Hfg. +Qed. + +Instance pointwise_subrelation_inv {A B} : subrelation (@Logic.eq A ==> @Logic.eq B)%signature (`=1`). +Proof. + intros f g Hfg x. now specialize (Hfg x x eq_refl). +Qed.*) + +Definition map_context {term term'} (f : term -> term') (c : list (context_decl term)) := + List.map (map_decl f) c. + +Instance map_context_proper {term term'} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_context term term'). +Proof. + intros f g Hfg x y ->. + now rewrite /map_context Hfg. +Qed. + +Lemma map_context_length {term term'} (f : term -> term') l : #|map_context f l| = #|l|. +Proof. now unfold map_context; rewrite map_length. Qed. +Hint Rewrite @map_context_length : len. + +Definition test_decl {term} (f : term -> bool) (d : context_decl term) : bool := + option_default f d.(decl_body) true && f d.(decl_type). + +Instance test_decl_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@test_decl term). +Proof. + intros f g Hfg [na [b|] ty] ? <- => /=; rewrite /test_decl /=; + now rewrite Hfg. +Qed. + +Section ContextMap. + Context {term term' : Type} (f : nat -> term -> term'). + + Fixpoint mapi_context (c : list (context_decl term)) : list (context_decl term') := + match c with + | d :: Γ => map_decl (f #|Γ|) d :: mapi_context Γ + | [] => [] end. +End ContextMap. + +Instance mapi_context_proper {term term'} : Proper (`=2` ==> Logic.eq ==> Logic.eq) (@mapi_context term term'). +Proof. + intros f g Hfg Γ ? <-. + induction Γ as [|[na [b|] ty] Γ]; simpl; auto; f_equal; auto; now rewrite Hfg. +Qed. + +Lemma mapi_context_length {term} (f : nat -> term -> term) l : #|mapi_context f l| = #|l|. +Proof. + induction l; simpl; auto. +Qed. +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 + | [] => true + end. +End ContextTest. + +Instance test_context_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@test_context term). +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 + | [] => true + end. +End ContextTestK. + +Instance test_context_k_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq ==> Logic.eq) (@test_context_k term). +Proof. + intros f g Hfg k ? <- Γ ? <-. + induction Γ as [|[na [b|] ty] Γ]; simpl; auto; f_equal; auto; now rewrite Hfg. +Qed. (** Primitive types models (axiom free) *) @@ -399,7 +497,7 @@ Definition string_of_uint63_model (i : uint63_model) := string_of_Z (proj1_sig i Definition prec := 53%Z. Definition emax := 1024%Z. (** We consider valid binary encordings of floats as our model *) -Definition float64_model := sig (valid_binary prec emax). +Definition float64_model := sig (SpecFloat.valid_binary prec emax). Definition string_of_float64_model (i : float64_model) := - "". + "". \ No newline at end of file diff --git a/template-coq/theories/Checker.v b/template-coq/theories/Checker.v index 7de4536e3..ade462750 100644 --- a/template-coq/theories/Checker.v +++ b/template-coq/theories/Checker.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import config Ast AstUtils utils +From MetaCoq.Template Require Import config Environment Ast AstUtils utils LiftSubst UnivSubst uGraph Typing. (** * Coq type-checker for kernel terms @@ -29,6 +29,137 @@ Module RedFlags. Definition default := mk true true true true true true. End RedFlags. + +Inductive type_error := +| UnboundRel (n : nat) +| UnboundVar (id : string) +| UnboundMeta (m : nat) +| UnboundEvar (ev : nat) +| UndeclaredConstant (c : kername) +| UndeclaredInductive (c : inductive) +| UndeclaredConstructor (c : inductive) (i : nat) +| NotConvertible (Γ : context) (t u t' u' : term) +| NotASort (t : term) +| NotAProduct (t t' : term) +| NotAnInductive (t : term) +| IllFormedFix (m : mfixpoint term) (i : nat) +| UnsatisfiedConstraints (c : ConstraintSet.t) +| UnsatisfiableConstraints (c : ConstraintSet.t) +| NotEnoughFuel (n : nat) +| NotSupported (s : string). + +Definition string_of_type_error (e : type_error) : string := + match e with + | UnboundRel n => "Unboound rel " ^ string_of_nat n + | UnboundVar id => "Unbound var " ^ id + | UnboundMeta m => "Unbound meta " ^ string_of_nat m + | UnboundEvar ev => "Unbound evar " ^ string_of_nat ev + | UndeclaredConstant c => "Undeclared constant " ^ string_of_kername c + | UndeclaredInductive c => "Undeclared inductive " ^ string_of_kername (inductive_mind c) + | UndeclaredConstructor c i => "Undeclared inductive " ^ string_of_kername (inductive_mind c) + | NotConvertible Γ t u t' u' => "Terms are not convertible: " ^ + string_of_term t ^ " " ^ string_of_term u ^ " after reduction: " ^ + string_of_term t' ^ " " ^ string_of_term u' + | NotASort t => "Not a sort" + | NotAProduct t t' => "Not a product" + | NotAnInductive t => "Not an inductive" + | IllFormedFix m i => "Ill-formed recursive definition" + | UnsatisfiedConstraints c => "Unsatisfied constraints" + | UnsatisfiableConstraints c => "Unsatisfiable constraints" + | NotEnoughFuel n => "Not enough fuel" + | NotSupported s => s ^ " are not supported" + end. + +Inductive typing_result (A : Type) := +| Checked (a : A) +| TypeError (t : type_error). +Global Arguments Checked {A} a. +Global Arguments TypeError {A} t. + +Instance typing_monad : Monad typing_result := + {| ret A a := Checked a ; + bind A B m f := + match m with + | Checked a => f a + | TypeError t => TypeError t + end + |}. + +Instance monad_exc : MonadExc type_error typing_result := + { raise A e := TypeError e; + catch A m f := + match m with + | Checked a => m + | TypeError t => f t + end + }. + +Section Lookups. + Context (Σ : global_env). + + Definition polymorphic_constraints u := + match u with + | Monomorphic_ctx _ => ConstraintSet.empty + | Polymorphic_ctx ctx => snd (AUContext.repr ctx) + end. + + Definition lookup_constant_type cst u := + match lookup_env Σ cst with + | Some (ConstantDecl {| cst_type := ty; cst_universes := uctx |}) => + ret (subst_instance u ty) + | _ => raise (UndeclaredConstant cst) + end. + + Definition lookup_constant_type_cstrs cst u := + match lookup_env Σ cst with + | Some (ConstantDecl {| cst_type := ty; cst_universes := uctx |}) => + let cstrs := polymorphic_constraints uctx in + ret (subst_instance u ty, subst_instance_cstrs u cstrs) + | _ => raise (UndeclaredConstant cst) + end. + + Definition lookup_ind_decl ind i := + match lookup_env Σ ind with + | Some (InductiveDecl mdecl) => + match nth_error mdecl.(ind_bodies) i with + | Some body => ret (mdecl, body) + | None => raise (UndeclaredInductive (mkInd ind i)) + end + | _ => raise (UndeclaredInductive (mkInd ind i)) + end. + + Definition lookup_ind_type ind i (u : list Level.t) := + res <- lookup_ind_decl ind i ;; + ret (subst_instance u (snd res).(ind_type)). + + Definition lookup_ind_type_cstrs ind i (u : list Level.t) := + res <- lookup_ind_decl ind i ;; + let '(mib, body) := res in + let uctx := mib.(ind_universes) in + let cstrs := polymorphic_constraints uctx in + ret (subst_instance u body.(ind_type), subst_instance_cstrs u cstrs). + + Definition lookup_constructor_decl ind i k := + res <- lookup_ind_decl ind i;; + let '(mib, body) := res in + match nth_error body.(ind_ctors) k with + | Some cdecl => ret (mib, cdecl) + | None => raise (UndeclaredConstructor (mkInd ind i) k) + end. + + Definition lookup_constructor_type ind i k u := + res <- lookup_constructor_decl ind i k ;; + let '(mib, cdecl) := res in + ret (subst0 (inds ind u mib.(ind_bodies)) (subst_instance u cdecl.(cstr_type))). + + Definition lookup_constructor_type_cstrs ind i k u := + res <- lookup_constructor_decl ind i k ;; + let '(mib, cdecl) := res in + let cstrs := polymorphic_constraints mib.(ind_universes) in + ret (subst0 (inds ind u mib.(ind_bodies)) (subst_instance u cdecl.(cstr_type)), + subst_instance_cstrs u cstrs). +End Lookups. + Section Reduce. Context (flags : RedFlags.t) (Σ : global_env). @@ -57,7 +188,7 @@ Section Reduce. if RedFlags.delta flags then match lookup_env Σ c with | Some (ConstantDecl {| cst_body := Some body |}) => - let body' := subst_instance_constr u body in + let body' := subst_instance u body in reduce_stack Γ n body' stack | _ => ret (t, stack) end @@ -101,12 +232,12 @@ Section Reduce. | tCast c _ _ => reduce_stack Γ n c stack - | tCase ((ind, par), relevance) p c brs => + | tCase ci p c brs => if RedFlags.iota flags then c' <- reduce_stack Γ n c [] ;; match c' with - | (tConstruct ind c _, args) => reduce_stack Γ n (iota_red par c args brs) stack - | _ => ret (tCase ((ind, par), relevance) p (zip c') brs, stack) + | (tConstruct ind c _, args) => reduce_stack Γ n (iota_red ci.(ci_npar) c args brs) stack + | _ => ret (tCase ci p (zip c') brs, stack) end else ret (t, stack) @@ -127,6 +258,34 @@ Section Reduce. end in aux [] l. + Definition rebuild_case_predicate_ctx ind (p : predicate term) : context := + match lookup_ind_decl Σ (inductive_mind ind) (inductive_ind ind) with + | TypeError _ => [] + | Checked (mib, oib) => + case_predicate_context ind mib oib p.(pparams) p.(puinst) p.(pcontext) + end. + + Definition map_context_with_binders (f : context -> term -> term) (c : context) Γ : context := + fold_left (fun acc decl => map_decl (f (Γ ,,, acc)) decl :: acc) (List.rev c) []. + + Definition map_predicate_with_binders (f : context -> term -> term) Γ ind (p : predicate term) := + let pctx := rebuild_case_predicate_ctx ind p in + let Γparams := map_context_with_binders f pctx Γ in + {| pparams := map (f Γ) p.(pparams); + puinst := p.(puinst); + pcontext := p.(pcontext); + preturn := f Γparams (preturn p) |}. + + Definition rebuild_case_branch_ctx ind i p := + match lookup_constructor_decl Σ (inductive_mind ind) (inductive_ind ind) i with + | TypeError _ => [] + | Checked (mib, cdecl) => case_branch_context p cdecl + end. + + Definition map_case_branch_with_binders ind i (f : context -> term -> term) Γ p br := + let ctx := rebuild_case_branch_ctx ind i p in + map_branch (f (Γ ,,, ctx)) br. + Definition map_constr_with_binders (f : context -> term -> term) Γ (t : term) : term := match t with | tRel i => t @@ -141,9 +300,10 @@ Section Reduce. let b' := f Γ b in let t' := f Γ t in tLetIn na b' t' (f (Γ ,, vdef na b' t') c) - | tCase ind p c brs => - let brs' := List.map (on_snd (f Γ)) brs in - tCase ind (f Γ p) (f Γ c) brs' + | tCase ci p c brs => + let p' := map_predicate_with_binders f Γ ci.(ci_ind) p in + let brs' := mapi (fun i x => map_case_branch_with_binders ci.(ci_ind) i f Γ p' x) brs in + tCase ci p' (f Γ c) brs' | tProj p c => tProj p (f Γ c) | tFix mfix idx => let Γ' := fix_decls mfix ++ Γ in @@ -189,6 +349,9 @@ Inductive conv_pb := | Conv | Cumul. +Definition eq_case_info (ci ci' : case_info) := + eq_inductive ci.(ci_ind) ci'.(ci_ind) && Nat.eqb ci.(ci_npar) ci'.(ci_npar). (* FIXME relevance check *) + Fixpoint eq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t} := match t, u with | tRel n, tRel n' => Nat.eqb n n' @@ -204,10 +367,10 @@ Fixpoint eq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t} | tLambda _ b t, tLambda _ b' t' => eq_term φ b b' && eq_term φ t t' | tProd _ b t, tProd _ b' t' => eq_term φ b b' && eq_term φ t t' | tLetIn _ b t c, tLetIn _ b' t' c' => eq_term φ b b' && eq_term φ t t' && eq_term φ c c' - | tCase ((ind, par), rel) p c brs, - tCase ((ind',par'), rel') p' c' brs' => - eq_inductive ind ind' && Nat.eqb par par' && - eq_term φ p p' && eq_term φ c c' && forallb2 (fun '(a, b) '(a', b') => eq_term φ b b') brs brs' + | tCase ci p c brs, + tCase ci' p' c' brs' => + eq_case_info ci ci' && + eqb_predicate (eqb_univ_instance φ) (eq_term φ) p p' && eq_term φ c c' && forallb2 (fun br br' => eq_term φ br.(bbody) br'.(bbody)) brs brs' | tProj p c, tProj p' c' => eq_projection p p' && eq_term φ c c' | tFix mfix idx, tFix mfix' idx' => forallb2 (fun x y => @@ -236,10 +399,9 @@ Fixpoint leq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t | tLambda _ b t, tLambda _ b' t' => eq_term φ b b' && eq_term φ t t' | tProd _ b t, tProd _ b' t' => eq_term φ b b' && leq_term φ t t' | tLetIn _ b t c, tLetIn _ b' t' c' => eq_term φ b b' && eq_term φ t t' && leq_term φ c c' - | tCase ((ind, par), rel) p c brs, - tCase ((ind',par'), rel') p' c' brs' => - eq_inductive ind ind' && Nat.eqb par par' && - eq_term φ p p' && eq_term φ c c' && forallb2 (fun '(a, b) '(a', b') => eq_term φ b b') brs brs' + | tCase ci p c brs, tCase ci' p' c' brs' => + eq_case_info ci ci' && + eqb_predicate (eqb_univ_instance φ) (eq_term φ) p p' && eq_term φ c c' && forallb2 (fun br br' => eq_term φ br.(bbody) br'.(bbody)) brs brs' | tProj p c, tProj p' c' => eq_projection p p' && eq_term φ c c' | tFix mfix idx, tFix mfix' idx' => forallb2 (fun x y => @@ -382,17 +544,17 @@ Section Conversion. isconv n leq (Γ ,, vass na b) t [] t' [] else ret false - | tCase (ind, par) p c brs, - tCase (ind',par') p' c' brs' => (* Hnf did not reduce, maybe delta needed in c *) - if eq_term G p p' && eq_term G c c' - && forallb2 (fun '(a, b) '(a', b') => eq_term G b b') brs brs' then + | tCase ci p c brs, + tCase ci' p' c' brs' => (* Hnf did not reduce, maybe delta needed in c *) + if eq_case_info ci ci' && eqb_predicate (eqb_univ_instance G) (eq_term G) p p' && eq_term G c c' + && forallb2 (fun br br' => eq_term G br.(bbody) br'.(bbody)) brs brs' then ret true else cred <- reduce_stack_term RedFlags.default Σ Γ n c ;; c'red <- reduce_stack_term RedFlags.default Σ Γ n c' ;; if eq_term G cred c && eq_term G c'red c' then ret true else - isconv n leq Γ (tCase (ind, par) p cred brs) l1 (tCase (ind, par) p c'red brs') l2 + isconv n leq Γ (tCase ci p cred brs) l1 (tCase ci' p c'red brs') l2 | tProj p c, tProj p' c' => on_cond (eq_projection p p' && eq_term G c c') @@ -429,71 +591,6 @@ Definition try_reduce Σ Γ n t := | None => t end. - -Inductive type_error := -| UnboundRel (n : nat) -| UnboundVar (id : string) -| UnboundMeta (m : nat) -| UnboundEvar (ev : nat) -| UndeclaredConstant (c : kername) -| UndeclaredInductive (c : inductive) -| UndeclaredConstructor (c : inductive) (i : nat) -| NotConvertible (Γ : context) (t u t' u' : term) -| NotASort (t : term) -| NotAProduct (t t' : term) -| NotAnInductive (t : term) -| IllFormedFix (m : mfixpoint term) (i : nat) -| UnsatisfiedConstraints (c : ConstraintSet.t) -| UnsatisfiableConstraints (c : ConstraintSet.t) -| NotEnoughFuel (n : nat) -| NotSupported (s : string). - -Definition string_of_type_error (e : type_error) : string := - match e with - | UnboundRel n => "Unboound rel " ^ string_of_nat n - | UnboundVar id => "Unbound var " ^ id - | UnboundMeta m => "Unbound meta " ^ string_of_nat m - | UnboundEvar ev => "Unbound evar " ^ string_of_nat ev - | UndeclaredConstant c => "Undeclared constant " ^ string_of_kername c - | UndeclaredInductive c => "Undeclared inductive " ^ string_of_kername (inductive_mind c) - | UndeclaredConstructor c i => "Undeclared inductive " ^ string_of_kername (inductive_mind c) - | NotConvertible Γ t u t' u' => "Terms are not convertible: " ^ - string_of_term t ^ " " ^ string_of_term u ^ " after reduction: " ^ - string_of_term t' ^ " " ^ string_of_term u' - | NotASort t => "Not a sort" - | NotAProduct t t' => "Not a product" - | NotAnInductive t => "Not an inductive" - | IllFormedFix m i => "Ill-formed recursive definition" - | UnsatisfiedConstraints c => "Unsatisfied constraints" - | UnsatisfiableConstraints c => "Unsatisfiable constraints" - | NotEnoughFuel n => "Not enough fuel" - | NotSupported s => s ^ " are not supported" - end. - -Inductive typing_result (A : Type) := -| Checked (a : A) -| TypeError (t : type_error). -Global Arguments Checked {A} a. -Global Arguments TypeError {A} t. - -Instance typing_monad : Monad typing_result := - {| ret A a := Checked a ; - bind A B m f := - match m with - | Checked a => f a - | TypeError t => TypeError t - end - |}. - -Instance monad_exc : MonadExc type_error typing_result := - { raise A e := TypeError e; - catch A m f := - match m with - | Checked a => m - | TypeError t => f t - end - }. - Definition check_conv_gen `{checker_flags} {F:Fuel} conv_pb Σ G Γ t u := match isconv Σ G fuel conv_pb Γ t [] u [] with | Some b => if b then ret () else raise (NotConvertible Γ t u t u) @@ -619,66 +716,6 @@ Section Typecheck. End InferAux. - Definition polymorphic_constraints u := - match u with - | Monomorphic_ctx _ => ConstraintSet.empty - | Polymorphic_ctx ctx => snd (AUContext.repr ctx) - end. - - Definition lookup_constant_type cst u := - match lookup_env Σ cst with - | Some (ConstantDecl {| cst_type := ty; cst_universes := uctx |}) => - ret (subst_instance_constr u ty) - | _ => raise (UndeclaredConstant cst) - end. - - Definition lookup_constant_type_cstrs cst u := - match lookup_env Σ cst with - | Some (ConstantDecl {| cst_type := ty; cst_universes := uctx |}) => - let cstrs := polymorphic_constraints uctx in - ret (subst_instance_constr u ty, subst_instance_cstrs u cstrs) - | _ => raise (UndeclaredConstant cst) - end. - - Definition lookup_ind_decl ind i := - match lookup_env Σ ind with - | Some (InductiveDecl {| ind_bodies := l; ind_universes := uctx |}) => - match nth_error l i with - | Some body => ret (l, uctx, body) - | None => raise (UndeclaredInductive (mkInd ind i)) - end - | _ => raise (UndeclaredInductive (mkInd ind i)) - end. - - Definition lookup_ind_type ind i (u : list Level.t) := - res <- lookup_ind_decl ind i ;; - ret (subst_instance_constr u (snd res).(ind_type)). - - Definition lookup_ind_type_cstrs ind i (u : list Level.t) := - res <- lookup_ind_decl ind i ;; - let '(l, uctx, body) := res in - let cstrs := polymorphic_constraints uctx in - ret (subst_instance_constr u body.(ind_type), subst_instance_cstrs u cstrs). - - Definition lookup_constructor_decl ind i k := - res <- lookup_ind_decl ind i;; - let '(l, uctx, body) := res in - match nth_error body.(ind_ctors) k with - | Some (_, ty, _) => ret (l, uctx, ty) - | None => raise (UndeclaredConstructor (mkInd ind i) k) - end. - - Definition lookup_constructor_type ind i k u := - res <- lookup_constructor_decl ind i k ;; - let '(l, uctx, ty) := res in - ret (subst0 (inds ind u l) (subst_instance_constr u ty)). - - Definition lookup_constructor_type_cstrs ind i k u := - res <- lookup_constructor_decl ind i k ;; - let '(l, uctx, ty) := res in - let cstrs := polymorphic_constraints uctx in - ret (subst0 (inds ind u l) (subst_instance_constr u ty), - subst_instance_cstrs u cstrs). Definition check_consistent_constraints cstrs := if check_constraints G cstrs then ret tt @@ -723,33 +760,35 @@ Section Typecheck. infer_spine infer Γ t_ty l | tConst cst u => - tycstrs <- lookup_constant_type_cstrs cst u ;; + tycstrs <- lookup_constant_type_cstrs Σ cst u ;; let '(ty, cstrs) := tycstrs in check_consistent_constraints cstrs;; ret ty | tInd (mkInd ind i) u => - tycstrs <- lookup_ind_type_cstrs ind i u;; + tycstrs <- lookup_ind_type_cstrs Σ ind i u;; let '(ty, cstrs) := tycstrs in check_consistent_constraints cstrs;; ret ty | tConstruct (mkInd ind i) k u => - tycstrs <- lookup_constructor_type_cstrs ind i k u ;; + tycstrs <- lookup_constructor_type_cstrs Σ ind i k u ;; let '(ty, cstrs) := tycstrs in check_consistent_constraints cstrs;; ret ty - | tCase ((ind, par), rel) p c brs => + | tCase ci p c brs => ty <- infer Γ c ;; indargs <- reduce_to_ind Σ Γ ty ;; (** TODO check branches *) - let '(ind', u, args) := indargs in - if eq_inductive ind ind' then - ret (tApp p (List.skipn par args ++ [c])) + let '(ind, u, args) := indargs in + if eq_inductive ind ci.(ci_ind) then + let pctx := rebuild_case_predicate_ctx Σ ind p in + let ptm := it_mkLambda_or_LetIn pctx p.(preturn) in + ret (tApp ptm (List.skipn ci.(ci_npar) args ++ [c])) else let ind1 := tInd ind u in - let ind2 := tInd ind' u in + let ind2 := tInd ci.(ci_ind) u in raise (NotConvertible Γ ind1 ind2 ind1 ind2) | tProj p c => diff --git a/template-coq/theories/Constants.v b/template-coq/theories/Constants.v index 989b102cf..2ef085c11 100644 --- a/template-coq/theories/Constants.v +++ b/template-coq/theories/Constants.v @@ -74,6 +74,8 @@ Register MetaCoq.Template.BasicAst.mkInd as metacoq.ast.mkInd. Register MetaCoq.Template.BasicAst.def as metacoq.ast.def. Register MetaCoq.Template.BasicAst.mkdef as metacoq.ast.mkdef. Register MetaCoq.Template.BasicAst.cast_kind as metacoq.ast.cast_kind. +Register MetaCoq.Template.BasicAst.case_info as metacoq.ast.case_info. +Register MetaCoq.Template.BasicAst.mk_case_info as metacoq.ast.mk_case_info. Register MetaCoq.Template.BasicAst.VmCast as metacoq.ast.VmCast. Register MetaCoq.Template.BasicAst.NativeCast as metacoq.ast.NativeCast. Register MetaCoq.Template.BasicAst.Cast as metacoq.ast.Cast. @@ -150,6 +152,11 @@ Register MetaCoq.Template.common.uGraph.gc_of_constraints as metacoq.ast.graph.a (* Terms *) +Register MetaCoq.Template.Ast.predicate as metacoq.ast.predicate. +Register MetaCoq.Template.Ast.mk_predicate as metacoq.ast.mk_predicate. +Register MetaCoq.Template.Ast.branch as metacoq.ast.branch. +Register MetaCoq.Template.Ast.mk_branch as metacoq.ast.mk_branch. + Register MetaCoq.Template.Ast.term as metacoq.ast.term. Register MetaCoq.Template.Ast.tRel as metacoq.ast.tRel. Register MetaCoq.Template.Ast.tVar as metacoq.ast.tVar. @@ -188,23 +195,26 @@ Register MetaCoq.Template.Ast.Build_one_inductive_entry as metacoq.ast.Build_one Register MetaCoq.Template.Ast.mutual_inductive_entry as metacoq.ast.mutual_inductive_entry. Register MetaCoq.Template.Ast.Build_mutual_inductive_entry as metacoq.ast.Build_mutual_inductive_entry. -Register MetaCoq.Template.Ast.context_decl as metacoq.ast.context_decl. -Register MetaCoq.Template.Ast.mkdecl as metacoq.ast.mkdecl. -Register MetaCoq.Template.Ast.context as metacoq.ast.context. - -Register MetaCoq.Template.Ast.one_inductive_body as metacoq.ast.one_inductive_body. -Register MetaCoq.Template.Ast.Build_one_inductive_body as metacoq.ast.Build_one_inductive_body. -Register MetaCoq.Template.Ast.mutual_inductive_body as metacoq.ast.mutual_inductive_body. -Register MetaCoq.Template.Ast.Build_mutual_inductive_body as metacoq.ast.Build_mutual_inductive_body. -Register MetaCoq.Template.Ast.constant_body as metacoq.ast.constant_body. -Register MetaCoq.Template.Ast.Build_constant_body as metacoq.ast.Build_constant_body. - -Register MetaCoq.Template.Ast.global_decl as metacoq.ast.global_decl. -Register MetaCoq.Template.Ast.ConstantDecl as metacoq.ast.ConstantDecl. -Register MetaCoq.Template.Ast.InductiveDecl as metacoq.ast.InductiveDecl. -Register MetaCoq.Template.Ast.global_env as metacoq.ast.global_env. -Register MetaCoq.Template.Ast.global_env_ext as metacoq.ast.global_env_ext. -Register MetaCoq.Template.Ast.program as metacoq.ast.program. +(* FIXME, now polymorphic *) +Register MetaCoq.Template.BasicAst.context_decl as metacoq.ast.context_decl. +Register MetaCoq.Template.BasicAst.mkdecl as metacoq.ast.mkdecl. +Register MetaCoq.Template.Ast.Env.context as metacoq.ast.context. + +Register MetaCoq.Template.Ast.Env.constructor_body as metacoq.ast.constructor_body. +Register MetaCoq.Template.Ast.Env.Build_constructor_body as metacoq.ast.Build_constructor_body. +Register MetaCoq.Template.Ast.Env.one_inductive_body as metacoq.ast.one_inductive_body. +Register MetaCoq.Template.Ast.Env.Build_one_inductive_body as metacoq.ast.Build_one_inductive_body. +Register MetaCoq.Template.Ast.Env.mutual_inductive_body as metacoq.ast.mutual_inductive_body. +Register MetaCoq.Template.Ast.Env.Build_mutual_inductive_body as metacoq.ast.Build_mutual_inductive_body. +Register MetaCoq.Template.Ast.Env.constant_body as metacoq.ast.constant_body. +Register MetaCoq.Template.Ast.Env.Build_constant_body as metacoq.ast.Build_constant_body. + +Register MetaCoq.Template.Ast.Env.global_decl as metacoq.ast.global_decl. +Register MetaCoq.Template.Ast.Env.ConstantDecl as metacoq.ast.ConstantDecl. +Register MetaCoq.Template.Ast.Env.InductiveDecl as metacoq.ast.InductiveDecl. +Register MetaCoq.Template.Ast.Env.global_env as metacoq.ast.global_env. +Register MetaCoq.Template.Ast.Env.global_env_ext as metacoq.ast.global_env_ext. +Register MetaCoq.Template.Ast.Env.program as metacoq.ast.program. (* Template monad *) diff --git a/template-coq/theories/Environment.v b/template-coq/theories/Environment.v index e99574853..7b00ac6c4 100644 --- a/template-coq/theories/Environment.v +++ b/template-coq/theories/Environment.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) +From Coq Require Import ssreflect ssrfun Morphisms Setoid. From MetaCoq.Template Require Import utils BasicAst. From MetaCoq.Template Require Import Universes. - Module Type Term. Parameter Inline term : Type. @@ -16,30 +16,30 @@ Module Type Term. Parameter Inline tProj : projection -> term -> term. Parameter Inline mkApps : term -> list term -> term. + Parameter Inline lift : nat -> nat -> term -> term. + Parameter Inline subst : list term -> nat -> term -> term. + Parameter Inline closedn : nat -> term -> bool. + Parameter Inline noccur_between : nat -> nat -> term -> bool. + Parameter Inline subst_instance_constr : UnivSubst term. + End Term. Module Environment (T : Term). Import T. + Existing Instance subst_instance_constr. (** ** Declarations *) - - (** *** The context of De Bruijn indices *) - - Record context_decl := mkdecl { - decl_name : aname ; - decl_body : option term ; - decl_type : term - }. - + Notation context_decl := (context_decl term). + (** Local (de Bruijn) variable binding *) - Definition vass x A := + Definition vass x A : context_decl := {| decl_name := x ; decl_body := None ; decl_type := A |}. (** Local (de Bruijn) let-binding *) - Definition vdef x t A := + Definition vdef x t A : context_decl := {| decl_name := x ; decl_body := Some t ; decl_type := A |}. (** Local (de Bruijn) context *) @@ -52,97 +52,320 @@ Module Environment (T : Term). Notation " Γ ,, d " := (snoc Γ d) (at level 20, d at next level). - Definition map_decl f (d : context_decl) := - {| decl_name := d.(decl_name); - decl_body := option_map f d.(decl_body); - decl_type := f d.(decl_type) |}. - - Lemma map_decl_type f decl : f (decl_type decl) = decl_type (map_decl f decl). + Lemma test_decl_impl (f g : term -> bool) x : (forall x, f x -> g x) -> + test_decl f x -> test_decl g x. + Proof. + intros Hf; rewrite /test_decl. + move/andb_and=> [Hd Hb]. + apply/andb_and; split; eauto. + destruct (decl_body x); simpl in *; eauto. + Qed. + + Lemma map_decl_type (f : term -> term) decl : f (decl_type decl) = decl_type (map_decl f decl). Proof. destruct decl; reflexivity. Qed. - Lemma map_decl_body f decl : option_map f (decl_body decl) = decl_body (map_decl f decl). + Lemma map_decl_body (f : term -> term) decl : option_map f (decl_body decl) = decl_body (map_decl f decl). Proof. destruct decl; reflexivity. Qed. - Lemma option_map_decl_body_map_decl f x : + Lemma map_decl_id : @map_decl term term id =1 id. + Proof. intros d; now destruct d as [? [] ?]. Qed. + + Lemma option_map_decl_body_map_decl (f : term -> term) x : option_map decl_body (option_map (map_decl f) x) = option_map (option_map f) (option_map decl_body x). Proof. destruct x; reflexivity. Qed. - Lemma option_map_decl_type_map_decl f x : + Lemma option_map_decl_type_map_decl (f : term -> term) x : option_map decl_type (option_map (map_decl f) x) = option_map f (option_map decl_type x). Proof. destruct x; reflexivity. Qed. - Definition map_context f c := - List.map (map_decl f) c. - - Lemma map_context_length f l : #|map_context f l| = #|l|. - Proof. now unfold map_context; rewrite map_length. Qed. - - Definition fold_context f (Γ : context) : context := + Definition fold_context_k f (Γ : context) : context := List.rev (mapi (fun k' decl => map_decl (f k') decl) (List.rev Γ)). - Arguments fold_context f Γ%list_scope. + Arguments fold_context_k f Γ%list_scope. - Lemma fold_context_alt f Γ : - fold_context f Γ = + Lemma fold_context_k_alt f Γ : + fold_context_k f Γ = mapi (fun k' d => map_decl (f (Nat.pred (length Γ) - k')) d) Γ. Proof. - unfold fold_context. rewrite rev_mapi. rewrite List.rev_involutive. + unfold fold_context_k. rewrite rev_mapi. rewrite List.rev_involutive. apply mapi_ext. intros. f_equal. now rewrite List.rev_length. Qed. - Lemma fold_context_length f Γ : length (fold_context f Γ) = length Γ. + Lemma mapi_context_fold f Γ : + mapi_context f Γ = fold_context_k f Γ. Proof. - unfold fold_context. now rewrite !List.rev_length, mapi_length, List.rev_length. + 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. + induction Γ as [|d Γ]; intros n; simpl; auto. f_equal. + rewrite IHΓ. rewrite mapi_rec_Sk. + apply mapi_rec_ext => k x. intros. + 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. reflexivity. Qed. + + Lemma fold_context_k_length f Γ : length (fold_context_k f Γ) = length Γ. + Proof. + unfold fold_context_k. now rewrite !List.rev_length mapi_length List.rev_length. + Qed. + Hint Rewrite fold_context_k_length : len. - Lemma fold_context_snoc0 f Γ d : - fold_context f (d :: Γ) = fold_context f Γ ,, map_decl (f (length Γ)) d. + Lemma fold_context_k_snoc0 f Γ d : + fold_context_k f (d :: Γ) = fold_context_k f Γ ,, map_decl (f (length Γ)) d. Proof. - unfold fold_context. - rewrite !rev_mapi, !rev_involutive. unfold mapi; rewrite mapi_rec_eqn. - unfold snoc. f_equal. now rewrite Nat.sub_0_r, List.rev_length. + unfold fold_context_k. + rewrite !rev_mapi !rev_involutive. unfold mapi; rewrite mapi_rec_eqn. + unfold snoc. f_equal. now rewrite Nat.sub_0_r List.rev_length. rewrite mapi_rec_Sk. simpl. apply mapi_rec_ext. intros. - rewrite app_length, !List.rev_length. simpl. f_equal. f_equal. lia. + rewrite app_length !List.rev_length. simpl. f_equal. f_equal. lia. Qed. - Lemma fold_context_app f Γ Δ : - fold_context f (Δ ++ Γ) - = fold_context (fun k => f (length Γ + k)) Δ ++ fold_context f Γ. + Lemma fold_context_k_app f Γ Δ : + fold_context_k f (Δ ++ Γ) + = fold_context_k (fun k => f (length Γ + k)) Δ ++ fold_context_k f Γ. Proof. - unfold fold_context. + unfold fold_context_k. rewrite List.rev_app_distr. rewrite mapi_app. rewrite <- List.rev_app_distr. f_equal. f_equal. apply mapi_ext. intros. f_equal. rewrite List.rev_length. f_equal. - Qed. + Qed. + + Lemma fold_context_k_id x : fold_context_k (fun i x => x) x = x. + Proof. + rewrite fold_context_k_alt. + rewrite /mapi. generalize 0. + induction x; simpl; auto. + intros n. + f_equal; auto. + now rewrite map_decl_id. + Qed. + + Lemma fold_context_k_compose f g Γ : + fold_context_k f (fold_context_k g Γ) = + fold_context_k (fun i => f i ∘ g i) Γ. + Proof. + rewrite !fold_context_k_alt mapi_mapi. + apply mapi_ext => i d. + rewrite compose_map_decl. apply map_decl_ext => t. + now len. + Qed. + + Lemma fold_context_k_ext f g Γ : + f =2 g -> + fold_context_k f Γ = fold_context_k g Γ. + Proof. + intros hfg. + induction Γ; simpl; auto; rewrite !fold_context_k_snoc0. + simpl. rewrite IHΓ. f_equal. apply map_decl_ext. + intros. now apply hfg. + Qed. + + Instance fold_context_k_proper : Proper (pointwise_relation nat (pointwise_relation _ Logic.eq) ==> Logic.eq ==> Logic.eq) fold_context_k. + Proof. + intros f g Hfg x y <-. now apply fold_context_k_ext. + Qed. + + Lemma alli_fold_context_k_prop f g 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. + now rewrite fold_context_k_alt /mapi alli_mapi. + Qed. + + Lemma test_decl_map_decl f g x : (@test_decl term) f (map_decl g x) = @test_decl term (f ∘ g) x. + Proof. + rewrite /test_decl /map_decl /=. + f_equal. rewrite /option_default. + destruct (decl_body x) => //. + Qed. + + Definition lift_decl n k d := (map_decl (lift n k) d). + + 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) Γ. + Proof. + unfold lift_context. apply fold_context_k_alt. + Qed. + + Lemma lift_context_length n k Γ : #|lift_context n k Γ| = #|Γ|. + Proof. now rewrite /lift_context; len. Qed. + Hint Rewrite lift_context_length : len. + + 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. + 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) Γ. + Proof. + 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) Γ. + + Instance subst_instance_decl : UnivSubst context_decl + := map_decl ∘ subst_instance. + + Instance subst_instance_context : UnivSubst context + := map_context ∘ subst_instance. + + Lemma subst_instance_length u (ctx : context) + : #|subst_instance u ctx| = #|ctx|. + Proof. unfold subst_instance, subst_instance_context, map_context. now rewrite map_length. Qed. + Hint Rewrite subst_instance_length : len. + + Definition set_binder_name (na : aname) (x : context_decl) : context_decl := + {| decl_name := na; + decl_body := decl_body x; + decl_type := decl_type x |}. + + Fixpoint context_assumptions (Γ : context) := + match Γ with + | [] => 0 + | d :: Γ => + match d.(decl_body) with + | Some _ => context_assumptions Γ + | None => S (context_assumptions Γ) + end + end. + + (** Smashing a context produces an assumption context. *) + + Fixpoint smash_context (Γ Γ' : context) : context := + match Γ' with + | {| decl_body := Some b |} :: Γ' => smash_context (subst_context [b] 0 Γ) Γ' + | {| 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. + - now rewrite IHtl subst_context_length. + - rewrite IHtl app_length. simpl. lia. + Qed. + 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. *) + + Fixpoint extended_subst (Γ : context) (n : nat) + (* Δ, smash_context Γ, n |- extended_subst Γ n : Γ *) := + match Γ with + | nil => nil + | cons d vs => + match decl_body d with + | Some b => + (* Δ , vs |- b *) + let s := extended_subst vs n in + (* Δ , smash_context vs , n |- s : vs *) + let b' := lift (context_assumptions vs + n) #|s| b in + (* Δ, smash_context vs, n , vs |- b' *) + let b' := subst s 0 b' in + (* Δ, smash_context vs , n |- b' *) + b' :: s + | None => tRel n :: extended_subst vs (S n) + end + end. + + Lemma extended_subst_length Γ n : #|extended_subst Γ n| = #|Γ|. + Proof. + induction Γ in n |- *; simpl; auto. + now destruct a as [? [?|] ?] => /=; simpl; rewrite IHΓ. + Qed. + Hint Rewrite extended_subst_length : len. + + 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 Δ := + (subst_context (extended_subst Γ 0) k (lift_context (context_assumptions Γ) (k + #|Γ|) Δ)). + Definition expand_lets_ctx Γ Δ := expand_lets_k_ctx Γ 0 Δ. + + Lemma expand_lets_k_ctx_length Γ k Δ : #|expand_lets_k_ctx Γ k Δ| = #|Δ|. + Proof. now rewrite /expand_lets_k_ctx; len. Qed. + Hint Rewrite expand_lets_k_ctx_length : len. + + Lemma expand_lets_ctx_length Γ Δ : #|expand_lets_ctx Γ Δ| = #|Δ|. + Proof. now rewrite /expand_lets_ctx; len. Qed. + Hint Rewrite expand_lets_ctx_length : len. + + 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 + arities of the mutual inductive + parameters *) + cstr_args : context; + cstr_indices : list 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 *) + }. + + Definition map_constructor_body npars arities f c := + {| 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 + inductive type.. beware of lets! *) + cstr_type := f arities c.(cstr_type); + cstr_arity := c.(cstr_arity) |}. + (** See [one_inductive_body] from [declarations.ml]. *) Record one_inductive_body := { ind_name : ident; - ind_type : term; (* Closed arity *) + ind_indices : context; (* Indices of the inductive types, under params *) + ind_sort : Universe.t; (* Sort of the inductive. *) + ind_type : term; (* Closed arity = forall mind_params, ind_indices, tSort ind_sort *) ind_kelim : allowed_eliminations; (* Allowed eliminations *) - ind_ctors : list (ident * term (* Under context of arities of the mutual inductive *) - * nat (* arity, w/o lets, w/o parameters *)); + ind_ctors : list constructor_body; ind_projs : list (ident * term); (* names and types of projections, if any. Type under context of params and inductive object *) ind_relevance : relevance (* relevance of the inductive definition *) }. - Definition map_one_inductive_body npars arities f (n : nat) m := + Definition map_one_inductive_body npars arities f m := match m with - | Build_one_inductive_body ind_name ind_type ind_kelim ind_ctors ind_projs ind_relevance => - Build_one_inductive_body ind_name - (f 0 ind_type) - ind_kelim - (map (on_pi2 (f arities)) ind_ctors) - (map (on_snd (f (S npars))) ind_projs) - ind_relevance + | 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 + (f 0 ind_type) ind_kelim (map (map_constructor_body npars arities f) ind_ctors) + (map (on_snd (f (S npars))) ind_projs) ind_relevance end. - (** See [mutual_inductive_body] from [declarations.ml]. *) Record mutual_inductive_body := { ind_finite : recursivity_kind; @@ -174,6 +397,7 @@ Module Environment (T : Term). Inductive global_decl := | ConstantDecl : constant_body -> global_decl | InductiveDecl : mutual_inductive_body -> global_decl. + Derive NoConfusion for global_decl. Definition global_env := list (kername * global_decl). @@ -237,6 +461,14 @@ Module Environment (T : Term). Definition to_extended_list_k Γ k := reln [] k Γ. 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 ctx. + Proof. + induction ctx as [|[na [b|] ty] ctx] in n, acc |- *; simpl; auto; + rewrite fold_context_k_snoc0 /=; apply IHctx. + Qed. + Lemma reln_list_lift_above l p Γ : Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) l -> Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) (reln l p Γ). @@ -244,7 +476,7 @@ Module Environment (T : Term). generalize (le_refl p). generalize p at 1 3 5. induction Γ in p, l |- *. simpl. auto. - intros. destruct a. destruct decl_body0. simpl. + intros. destruct a. destruct decl_body. simpl. assert(p0 <= S p) by lia. specialize (IHΓ l (S p) p0 H1). rewrite <- Nat.add_succ_comm, Nat.add_1_r. simpl in *. rewrite <- Nat.add_succ_comm in H0. eauto. @@ -274,7 +506,7 @@ Module Environment (T : Term). destruct H; eexists; intuition eauto. Qed. - Fixpoint reln_alt p Γ := + Fixpoint reln_alt p (Γ : context) := match Γ with | [] => [] | {| decl_body := Some _ |} :: Γ => reln_alt (p + 1) Γ @@ -286,7 +518,7 @@ Module Environment (T : Term). induction Γ in l, k |- *; simpl; auto. destruct a as [na [body|] ty]; simpl. now rewrite IHΓ. - now rewrite IHΓ, <- app_assoc. + now rewrite IHΓ -app_assoc. Qed. Lemma to_extended_list_k_cons d Γ k : @@ -299,7 +531,7 @@ Module Environment (T : Term). unfold to_extended_list_k. rewrite reln_alt_eq. simpl. destruct d as [na [body|] ty]. simpl. - now rewrite reln_alt_eq, Nat.add_1_r. + now rewrite reln_alt_eq Nat.add_1_r. simpl. rewrite reln_alt_eq. now rewrite <- app_assoc, !app_nil_r, Nat.add_1_r. Qed. @@ -311,17 +543,8 @@ Module Environment (T : Term). Lemma arities_context_length l : #|arities_context l| = #|l|. Proof. unfold arities_context. now rewrite rev_map_length. Qed. - - Fixpoint context_assumptions (Γ : context) := - match Γ with - | [] => 0 - | d :: Γ => - match d.(decl_body) with - | Some _ => context_assumptions Γ - | None => S (context_assumptions Γ) - end - end. - + Hint Rewrite arities_context_length : len. + Lemma app_context_nil_l Γ : [] ,,, Γ = Γ. Proof. unfold app_context. rewrite app_nil_r. reflexivity. @@ -335,6 +558,7 @@ Module Environment (T : Term). Lemma app_context_length Γ Γ' : #|Γ ,,, Γ'| = #|Γ'| + #|Γ|. Proof. unfold app_context. now rewrite app_length. Qed. + Hint Rewrite app_context_length : len. Lemma nth_error_app_context_ge v Γ Γ' : #|Γ'| <= v -> nth_error (Γ ,,, Γ') v = nth_error Γ (v - #|Γ'|). @@ -349,28 +573,28 @@ Module Environment (T : Term). match m with | Build_mutual_inductive_body finite ind_npars ind_pars ind_bodies ind_universes ind_variance => let arities := arities_context ind_bodies in - let pars := fold_context f ind_pars in + let pars := fold_context_k f ind_pars in Build_mutual_inductive_body finite ind_npars pars - (mapi (map_one_inductive_body (context_assumptions pars) (length arities) f) ind_bodies) + (map (map_one_inductive_body (context_assumptions pars) (length arities) f) ind_bodies) ind_universes ind_variance end. - Lemma ind_type_map f npars_ass arities n oib : - ind_type (map_one_inductive_body npars_ass arities f n oib) = f 0 (ind_type oib). + Lemma ind_type_map f npars_ass arities oib : + ind_type (map_one_inductive_body npars_ass arities f oib) = f 0 (ind_type oib). Proof. destruct oib. reflexivity. Qed. - Lemma ind_ctors_map f npars_ass arities n oib : - ind_ctors (map_one_inductive_body npars_ass arities f n oib) = - map (on_pi2 (f arities)) (ind_ctors oib). + Lemma ind_ctors_map f npars_ass arities oib : + ind_ctors (map_one_inductive_body npars_ass arities f oib) = + map (map_constructor_body npars_ass arities f) (ind_ctors oib). Proof. destruct oib; simpl; reflexivity. Qed. Lemma ind_pars_map f m : ind_params (map_mutual_inductive_body f m) = - fold_context f (ind_params m). + fold_context_k f (ind_params m). Proof. destruct m; simpl; reflexivity. Qed. - Lemma ind_projs_map f npars_ass arities n oib : - ind_projs (map_one_inductive_body npars_ass arities f n oib) = + Lemma ind_projs_map f npars_ass arities oib : + ind_projs (map_one_inductive_body npars_ass arities f oib) = map (on_snd (f (S npars_ass))) (ind_projs oib). Proof. destruct oib; simpl. reflexivity. Qed. @@ -382,57 +606,218 @@ Module Environment (T : Term). else lookup_env tl kn end. - Lemma context_assumptions_fold Γ f : context_assumptions (fold_context f Γ) = context_assumptions Γ. + Lemma context_assumptions_fold Γ f : context_assumptions (fold_context_k f Γ) = context_assumptions Γ. Proof. - rewrite fold_context_alt. + rewrite fold_context_k_alt. unfold mapi. generalize 0 (Nat.pred #|Γ|). induction Γ as [|[na [body|] ty] tl]; cbn; intros; eauto. Qed. + Hint Rewrite context_assumptions_fold : len. - Lemma nth_error_fold_context (f : nat -> term -> term): + Lemma nth_error_fold_context_k (f : nat -> term -> term): forall (Γ' Γ'' : context) (v : nat), v < length Γ' -> forall nth, nth_error Γ' v = Some nth -> - nth_error (fold_context f Γ') v = Some (map_decl (f (length Γ' - S v)) nth). + nth_error (fold_context_k f Γ') v = Some (map_decl (f (length Γ' - S v)) nth). Proof. induction Γ'; intros. - easy. - - simpl. destruct v; rewrite fold_context_snoc0. + - simpl. destruct v; rewrite fold_context_k_snoc0. + simpl. repeat f_equal; try lia. simpl in *. congruence. + simpl. apply IHΓ'; simpl in *; (lia || congruence). Qed. - Lemma nth_error_fold_context_eq: + Lemma nth_error_fold_context_k_eq: forall (Γ' : context) (v : nat) f, - nth_error (fold_context f Γ') v = + nth_error (fold_context_k f Γ') v = option_map (map_decl (f (length Γ' - S v))) (nth_error Γ' v). Proof. induction Γ'; intros. - - simpl. unfold fold_context, fold_context; simpl. now rewrite nth_error_nil. - - simpl. destruct v; rewrite fold_context_snoc0. + - simpl. unfold fold_context_k; simpl. now rewrite nth_error_nil. + - simpl. destruct v; rewrite fold_context_k_snoc0. + simpl. repeat f_equal; try lia. + simpl. apply IHΓ'; simpl in *; (lia || congruence). Qed. - Lemma nth_error_ge {Γ Γ' v Γ''} f : length Γ' <= v -> - nth_error (Γ' ++ Γ) v = - nth_error (fold_context (f 0) Γ' ++ Γ'' ++ Γ) (length Γ'' + v). + Lemma nth_error_ge {Γ Γ' v Γ''} f : + length Γ' <= v -> + nth_error (Γ' ++ Γ) v = + nth_error (fold_context_k (f 0) Γ' ++ Γ'' ++ Γ) (length Γ'' + v). Proof. intros Hv. - rewrite -> !nth_error_app_ge, ?fold_context_length. f_equal. lia. - rewrite fold_context_length. lia. - rewrite fold_context_length. lia. auto. + rewrite -> !nth_error_app_ge, ?fold_context_k_length. f_equal. lia. + rewrite fold_context_k_length. lia. + rewrite fold_context_k_length. lia. auto. Qed. - Lemma nth_error_lt {Γ Γ' Γ'' v} (f : nat -> term -> term) : v < length Γ' -> - nth_error (fold_context f Γ' ++ Γ'' ++ Γ) v = - option_map (map_decl (f (length Γ' - S v))) (nth_error (Γ' ++ Γ) v). + Lemma nth_error_lt {Γ Γ' Γ'' v} (f : nat -> term -> term) : + v < length Γ' -> + nth_error (fold_context_k f Γ' ++ Γ'' ++ Γ) v = + option_map (map_decl (f (length Γ' - S v))) (nth_error (Γ' ++ Γ) v). Proof. simpl. intros Hv. rewrite -> !nth_error_app_lt. - rewrite nth_error_fold_context_eq. - do 2 f_equal. lia. now rewrite fold_context_length. + rewrite nth_error_fold_context_k_eq. + do 2 f_equal. lia. now rewrite fold_context_k_length. + Qed. + + Lemma context_assumptions_length_bound Γ : context_assumptions Γ <= #|Γ|. + Proof. + 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 (Γ ++ Δ) = + context_assumptions Γ + context_assumptions Δ. + Proof. + induction Γ as [|[? [] ?] ?]; simpl; auto. Qed. + + 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. + + 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 Γ. + Proof. apply context_assumptions_map. Qed. + + 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 Γ. + Proof. apply context_assumptions_fold. Qed. + + Hint Rewrite context_assumptions_subst_instance + context_assumptions_subst_context context_assumptions_lift_context : len. + + Lemma fold_context_k_map f g Γ : + fold_context_k f (map_context g Γ) = + fold_context_k (fun k => f k ∘ g) Γ. + Proof. + 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 g Γ : + (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. + intros Hfg. + rewrite !fold_context_k_alt mapi_map. + rewrite /map_context map_mapi. + apply mapi_ext => i x. + rewrite !compose_map_decl. + apply map_decl_ext => t. + rewrite Hfg. + now len. + Qed. + + (** Lifting a relation to declarations, without alpha renaming. *) + Inductive All_decls (P : term -> term -> Type) : context_decl -> context_decl -> Type := + | on_vass na t t' : + P t t' -> + All_decls P (vass na t) (vass na t') + + | on_vdef na b t b' t' : + P b b' -> + P t t' -> + All_decls P (vdef na b t) (vdef na b' t'). + Derive Signature NoConfusion for All_decls. + + (** Allow alpha-renaming of binders *) + Inductive All_decls_alpha (P : term -> term -> Type) : context_decl -> context_decl -> Type := + | on_vass_alpha na na' t t' : + 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' : + All_decls P d d' -> + (forall t t', P t t' -> Q t t') -> + All_decls Q d d'. + Proof. + intros ond H; destruct ond; constructor; auto. + Qed. + + 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'. + Proof. + intros ond H; destruct ond; constructor; auto. + Qed. + + 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. + + Inductive All2_fold {P : context -> context -> context_decl -> context_decl -> Type} + : forall (Γ Γ' : context), Type := + | All2_fold_nil : All2_fold nil nil + | All2_fold_cons {d d' Γ Γ'} : All2_fold Γ Γ' -> P Γ Γ' d d' -> All2_fold (d :: Γ) (d' :: Γ'). + + Derive Signature NoConfusion for All2_fold. + Arguments All2_fold P Γ Γ' : clear implicits. + + Lemma All2_fold_length {P Γ Γ'} : + All2_fold P Γ Γ' -> #|Γ| = #|Γ'|. + Proof. + induction 1; cbn; congruence. + Qed. + + Lemma All2_fold_impl {P Q Γ Γ'} : + All2_fold P Γ Γ' -> (forall Γ Γ' d d', P Γ Γ' d d' -> Q Γ Γ' d d') -> + All2_fold Q Γ Γ'. + Proof. + induction 1; constructor; auto. + Qed. + + Definition All_over {A} (P : context -> context -> A -> A -> Type) Γ Γ' := + fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ'). + + Lemma All2_fold_app_inv : + forall P (Γ Γ' Γl Γr : context), + All2_fold P Γ Γl -> + All2_fold (All_over P Γ Γl) Γ' Γr -> + All2_fold P (Γ ,,, Γ') (Γl ,,, Γr). + Proof. + induction 2; auto. + - simpl. constructor; auto. + Qed. + + Definition All2_fold_over P Γ Γ' := All2_fold (All_over P Γ Γ'). + + Notation on_decls P := (fun Γ Γ' => All_decls (P Γ Γ')). + Notation on_contexts P := (All2_fold (on_decls P)). + Notation on_contexts_over P Γ Γ' := (All2_fold (All_over (on_decls P) Γ Γ')). + End Environment. Module Type EnvironmentSig (T : Term). diff --git a/template-coq/theories/EnvironmentTyping.v b/template-coq/theories/EnvironmentTyping.v index f8a8b8d0c..3f918b481 100644 --- a/template-coq/theories/EnvironmentTyping.v +++ b/template-coq/theories/EnvironmentTyping.v @@ -1,7 +1,6 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import config utils BasicAst AstUtils - Universes Environment. - +From MetaCoq.Template Require Import config utils BasicAst Universes Environment. +From Equations Require Import Equations. Module Lookup (T : Term) (E : EnvironmentSig T). @@ -15,17 +14,17 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Definition declared_minductive Σ mind decl := lookup_env Σ mind = Some (InductiveDecl decl). - Definition declared_inductive Σ mdecl ind decl := + Definition declared_inductive Σ ind mdecl decl := declared_minductive Σ (inductive_mind ind) mdecl /\ List.nth_error mdecl.(ind_bodies) (inductive_ind ind) = Some decl. - Definition declared_constructor Σ mdecl idecl cstr cdecl : Prop := - declared_inductive Σ mdecl (fst cstr) idecl /\ + Definition declared_constructor Σ cstr mdecl idecl cdecl : Prop := + declared_inductive Σ (fst cstr) mdecl idecl /\ List.nth_error idecl.(ind_ctors) (snd cstr) = Some cdecl. - Definition declared_projection Σ mdecl idecl (proj : projection) pdecl + Definition declared_projection Σ (proj : projection) mdecl idecl pdecl : Prop := - declared_inductive Σ mdecl (fst (fst proj)) idecl /\ + declared_inductive Σ (fst (fst proj)) mdecl idecl /\ List.nth_error idecl.(ind_projs) (snd proj) = Some pdecl /\ mdecl.(ind_npars) = snd (fst proj). @@ -139,100 +138,32 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T). typing Γ t None -> typing Γ b (Some t) -> All_local_env (Γ ,, vdef na b t). - Derive Signature for All_local_env. + Derive Signature NoConfusion for All_local_env. End TypeLocal. Arguments localenv_nil {_}. Arguments localenv_cons_def {_ _ _ _ _} _ _. Arguments localenv_cons_abs {_ _ _ _} _ _. - Inductive context_relation (P : context -> context -> context_decl -> context_decl -> Type) - : forall (Γ Γ' : context), Type := - | ctx_rel_nil : context_relation P nil nil - | ctx_rel_vass na na' T U Γ Γ' : - context_relation P Γ Γ' -> - P Γ Γ' (vass na T) (vass na' U) -> - context_relation P (vass na T :: Γ) (vass na' U :: Γ') - | ctx_rel_def na na' t T u U Γ Γ' : - context_relation P Γ Γ' -> - P Γ Γ' (vdef na t T) (vdef na' u U) -> - context_relation P (vdef na t T :: Γ) (vdef na' u U :: Γ'). - - Derive Signature for context_relation. - Arguments context_relation P Γ Γ' : clear implicits. - - Lemma context_relation_length {P Γ Γ'} : - context_relation P Γ Γ' -> #|Γ| = #|Γ'|. - Proof. - induction 1; cbn; congruence. - Qed. - - Lemma context_relation_impl {P Q Γ Γ'} : - context_relation P Γ Γ' -> (forall Γ Γ' d d', P Γ Γ' d d' -> Q Γ Γ' d d') -> - context_relation Q Γ Γ'. + Lemma All_local_env_fold P f Γ : + All_local_env (fun Γ t T => P (fold_context_k f Γ) (f #|Γ| t) (option_map (f #|Γ|) T)) Γ <~> + All_local_env P (fold_context_k f Γ). Proof. - induction 1; constructor; auto. + split. + - induction 1; simpl; try unfold snoc; rewrite ?fold_context_k_snoc0; try constructor; auto. + - induction Γ; simpl; try unfold snoc; rewrite ?fold_context_k_snoc0; intros H. + * constructor. + * destruct a as [na [b|] ty]; depelim H; specialize (IHΓ H); constructor; simpl; auto. Qed. - Section All2_local_env. - - Definition on_decl (P : context -> context -> term -> term -> Type) - (Γ Γ' : context) (b : option (term * term)) (t t' : term) := - match b with - | Some (b, b') => (P Γ Γ' b b' * P Γ Γ' t t')%type - | None => P Γ Γ' t t' - end. - - Section All_local_2. - Context (P : forall (Γ Γ' : context), option (term * term) -> term -> term -> Type). - - Inductive All2_local_env : context -> context -> Type := - | localenv2_nil : All2_local_env [] [] - | localenv2_cons_abs Γ Γ' na na' t t' : - All2_local_env Γ Γ' -> - eq_binder_annot na na' -> - P Γ Γ' None t t' -> - All2_local_env (Γ ,, vass na t) (Γ' ,, vass na' t') - | localenv2_cons_def Γ Γ' na na' b b' t t' : - All2_local_env Γ Γ' -> - eq_binder_annot na na' -> - P Γ Γ' (Some (b, b')) t t' -> - All2_local_env (Γ ,, vdef na b t) (Γ' ,, vdef na' b' t'). - End All_local_2. - - Definition on_decl_over (P : context -> context -> term -> term -> Type) Γ Γ' := - fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ'). - - Definition All2_local_env_over P Γ Γ' := All2_local_env (on_decl (on_decl_over P Γ Γ')). - - Lemma All2_local_env_length {P l l'} : @All2_local_env P l l' -> #|l| = #|l'|. - Proof. induction 1; simpl; auto. Qed. - - - Lemma All2_local_env_impl {P Q : context -> context -> term -> term -> Type} {par par'} : - All2_local_env (on_decl P) par par' -> - (forall par par' x y, P par par' x y -> Q par par' x y) -> - All2_local_env (on_decl Q) par par'. - Proof. - intros H aux. - induction H; constructor. auto. red in p. assumption. apply aux, p. - apply IHAll2_local_env. assumption. red. split. - apply aux. apply p. apply aux. apply p. - Defined. - - Lemma All2_local_env_app_inv : - forall P (Γ Γ' Γl Γr : context), - All2_local_env (on_decl P) Γ Γl -> - All2_local_env (on_decl (on_decl_over P Γ Γl)) Γ' Γr -> - All2_local_env (on_decl P) (Γ ,,, Γ') (Γl ,,, Γr). + Lemma All_local_env_impl_ind {P Q : context -> term -> option term -> Type} {l} : + All_local_env P l -> + (forall Γ t T, All_local_env Q Γ -> P Γ t T -> Q Γ t T) -> + All_local_env Q l. Proof. - induction 2; auto. - - simpl. constructor; auto. - - simpl. constructor; auto. + induction 1; intros; simpl; econstructor; eauto. Qed. - - End All2_local_env. - + (** Well-formedness of local environments embeds a sorting for each variable *) Definition lift_typing (P : global_env_ext -> context -> term -> term -> Type) : @@ -277,6 +208,23 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T). All_local_env_over Σ (Γ ,, vdef na b t) (localenv_cons_def all tu tb). End TypeLocalOver. + Derive Signature for All_local_env_over. + + Section TypeCtxInst. + Context (typing : forall (Σ : global_env_ext) (Γ : context), term -> term -> Type). + + (* Γ |- 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 Δ : + typing Σ Γ i t -> + ctx_inst Σ Γ inst (subst_telescope [i] 0 Δ) -> + ctx_inst Σ Γ (i :: inst) (vass na t :: Δ) + | ctx_inst_def na b t inst Δ : + ctx_inst Σ Γ inst (subst_telescope [b] 0 Δ) -> + ctx_inst Σ Γ inst (vdef na b t :: Δ). + Derive Signature NoConfusion for ctx_inst. + End TypeCtxInst. End EnvTyping. @@ -284,49 +232,17 @@ Module Type EnvTypingSig (T : Term) (E : EnvironmentSig T). Include EnvTyping T E. End EnvTypingSig. -Module Type Typing (T : Term) (E : EnvironmentSig T) (ET : EnvTypingSig T E). +Module Type ConversionParSig (T : Term) (E : EnvironmentSig T) (ET : EnvTypingSig T E). Import T E ET. Parameter (conv : forall `{checker_flags}, global_env_ext -> context -> term -> term -> Type). Parameter (cumul : forall `{checker_flags}, global_env_ext -> context -> term -> term -> Type). - Parameter (typing : forall `{checker_flags}, global_env_ext -> context -> term -> term -> Type). - - Parameter (wf_universe : global_env_ext -> Universe.t -> Prop). - - Notation " Σ ;;; Γ |- t : T " := - (typing Σ Γ t T) (at level 50, Γ, t, T at next level) : type_scope. - - Parameter Inline smash_context : context -> context -> context. - Parameter Inline lift_context : nat -> nat -> context -> context. - Parameter Inline subst_context : list term -> nat -> context -> context. - Parameter Inline expand_lets : context -> term -> term. - Parameter Inline expand_lets_ctx : context -> context -> context. - Parameter Inline subst_telescope : list term -> nat -> context -> context. - Parameter Inline subst_instance_context : Instance.t -> context -> context. - Parameter Inline subst_instance_constr : Instance.t -> term -> term. - Parameter Inline lift : nat -> nat -> term -> term. - Parameter Inline subst : list term -> nat -> term -> term. - Parameter Inline inds : kername -> Instance.t -> list one_inductive_body -> list term. - Parameter Inline extended_subst : context -> nat -> list term. (* Let expansion substitution *) - Parameter destArity : term -> option (context * Universe.t). - - (* [noccur_between n k t] Checks that deBruijn indices between n and n+k do not appear in t (even under binders). *) - Parameter Inline noccur_between : nat -> nat -> term -> bool. - Parameter Inline closedn : nat -> term -> bool. - - Notation wf_local Σ Γ := (All_local_env (lift_typing typing Σ) Γ). - -End Typing. - -Module DeclarationTyping (T : Term) (E : EnvironmentSig T) - (ET : EnvTypingSig T E) (Ty : Typing T E ET) (L : LookupSig T E). - - Import T E Ty L ET. +End ConversionParSig. - Definition isType `{checker_flags} (Σ : global_env_ext) (Γ : context) (t : term) := - { s : _ & Σ ;;; Γ |- t : tSort s }. +Module Conversion (T : Term) (E : EnvironmentSig T) (ET : EnvTypingSig T E) (CT : ConversionParSig T E ET). + Import T E ET CT. Section ContextConversion. Context {cf : checker_flags}. @@ -362,7 +278,45 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) End ContextConversion. Definition cumul_ctx_rel {cf:checker_flags} Σ Γ Δ Δ' := - context_relation (fun Δ Δ' => cumul_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ'. + All2_fold (fun Δ Δ' => cumul_decls Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ'. + +End Conversion. + +Module Type ConversionSig (T : Term) (E : EnvironmentSig T) (ET : EnvTypingSig T E) (CT : ConversionParSig T E ET). + Include Conversion T E ET CT. +End ConversionSig. + +Module Type Typing (T : Term) (E : EnvironmentSig T) (ET : EnvTypingSig T E) + (CS : ConversionParSig T E ET) (CT : ConversionSig T E ET CS). + + Import T E ET CS CT. + + Parameter (typing : forall `{checker_flags}, global_env_ext -> context -> term -> term -> Type). + + Parameter (wf_universe : global_env_ext -> Universe.t -> Prop). + + Notation " Σ ;;; Γ |- t : T " := + (typing Σ Γ t T) (at level 50, Γ, t, T at next level) : type_scope. + + Parameter Inline inds : kername -> Instance.t -> list one_inductive_body -> list term. + Parameter destArity : term -> option (context * Universe.t). + + Notation wf_local Σ Γ := (All_local_env (lift_typing typing Σ) Γ). + +End Typing. + +Module DeclarationTyping (T : Term) (E : EnvironmentSig T) + (ET : EnvTypingSig T E) + (CS : ConversionParSig T E ET) + (CT : ConversionSig T E ET CS) (Ty : Typing T E ET CS CT) + (L : LookupSig T E). + + Import T E Ty L ET CS CT. + + Definition isType `{checker_flags} (Σ : global_env_ext) (Γ : context) (t : term) := + { s : _ & Σ ;;; Γ |- t : tSort s }. + + (** *** Typing of inductive declarations *) @@ -393,38 +347,11 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) (sorts_local_ctx Σ Γ Δ us * (P Σ (Γ ,,, Δ) t None * P Σ (Γ ,,, Δ) b (Some t))) | _, _ => False end. - - (* Delta telescope *) - Inductive ctx_inst Σ (Γ : context) : list term -> context -> Type := - | ctx_inst_nil : ctx_inst Σ Γ [] [] - | ctx_inst_ass na t i inst Δ : - P Σ Γ i (Some t) -> - ctx_inst Σ Γ inst (subst_telescope [i] 0 Δ) -> - ctx_inst Σ Γ (i :: inst) (vass na t :: Δ) - | ctx_inst_def na b t inst Δ : - ctx_inst Σ Γ inst (subst_telescope [b] 0 Δ) -> - ctx_inst Σ Γ inst (vdef na b t :: Δ). - Implicit Types (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : ident * term * nat). + Implicit Types (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body). Definition on_type Σ Γ T := P Σ Γ T None. - Definition cdecl_type cdecl := cdecl.1.2. - Definition cdecl_args cdecl := cdecl.2. - - (* A constructor shape is a decomposition of a constructor's type *) - Record constructor_shape := - { cshape_args : context; - (* Arguments (with lets) *) - - cshape_indices : list term; - (* Indices of the constructor, whose length should be the real arguments - length of the inductive *) - - cshape_sorts : list Universe.t; - (* The sorts of the arguments context (without lets) *) - }. - Open Scope type_scope. (** Positivity checking of the inductive, ensuring that the inductive itself @@ -587,9 +514,9 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) let univs := ind_universes mdecl in match variance_universes univs v with | Some (univs, u, u') => - cumul_ctx_rel (Σ, univs) (subst_instance_context u (smash_context [] (ind_params mdecl))) - (subst_instance_context u (expand_lets_ctx (ind_params mdecl) (smash_context [] indices))) - (subst_instance_context u' (expand_lets_ctx (ind_params mdecl) (smash_context [] indices))) + cumul_ctx_rel (Σ, univs) (subst_instance u (smash_context [] (ind_params mdecl))) + (subst_instance u (expand_lets_ctx (ind_params mdecl) (smash_context [] indices))) + (subst_instance u' (expand_lets_ctx (ind_params mdecl) (smash_context [] indices))) | None => False end. @@ -597,60 +524,60 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) let univs := ind_universes mdecl in match variance_universes univs v with | Some (univs, u, u') => - cumul_ctx_rel (Σ, univs) (subst_instance_context u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl))) - (subst_instance_context u (expand_lets_ctx (ind_params mdecl) (smash_context [] (cshape_args cs)))) - (subst_instance_context u' (expand_lets_ctx (ind_params mdecl) (smash_context [] (cshape_args cs)))) * + cumul_ctx_rel (Σ, univs) (subst_instance u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl))) + (subst_instance u (expand_lets_ctx (ind_params mdecl) (smash_context [] (cstr_args cs)))) + (subst_instance u' (expand_lets_ctx (ind_params mdecl) (smash_context [] (cstr_args cs)))) * All2 - (conv (Σ, univs) (subst_instance_context u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl ,,, cshape_args cs)))) - (map (subst_instance_constr u ∘ expand_lets (ind_params mdecl ,,, cshape_args cs)) (cshape_indices cs)) - (map (subst_instance_constr u' ∘ expand_lets (ind_params mdecl ,,, cshape_args cs)) (cshape_indices cs)) + (conv (Σ, univs) (subst_instance u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl ,,, cstr_args cs)))) + (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)) | None => False (* Monomorphic inductives have no variance attached *) end. - Record on_constructor Σ mdecl i idecl ind_indices cdecl (cshape : constructor_shape) := { + Record on_constructor Σ mdecl i idecl ind_indices cdecl cunivs := { (* cdecl.1 fresh ?? *) - cstr_args_length : context_assumptions (cshape_args cshape) = cdecl_args cdecl; + cstr_args_length : context_assumptions (cstr_args cdecl) = cstr_arity cdecl; (* Real (non-let) arguments bound by the constructor *) cstr_concl_head := tRel (#|mdecl.(ind_bodies)| - S i + #|mdecl.(ind_params)| - + #|cshape_args cshape|); + + #|cstr_args cdecl|); (* Conclusion head: reference to the current inductive in the block *) - cstr_eq : cdecl_type cdecl = + cstr_eq : cstr_type cdecl = it_mkProd_or_LetIn mdecl.(ind_params) - (it_mkProd_or_LetIn (cshape_args cshape) + (it_mkProd_or_LetIn (cstr_args cdecl) (mkApps cstr_concl_head - (to_extended_list_k mdecl.(ind_params) #|cshape_args cshape| - ++ cshape_indices cshape))); + (to_extended_list_k mdecl.(ind_params) #|cstr_args cdecl| + ++ cstr_indices cdecl))); (* The type of the constructor canonically has this shape: parameters, real arguments ending with a reference to the inductive applied to the (non-lets) parameters and arguments *) - on_ctype : on_type Σ (arities_context mdecl.(ind_bodies)) (cdecl_type cdecl); + on_ctype : on_type Σ (arities_context mdecl.(ind_bodies)) (cstr_type cdecl); on_cargs : sorts_local_ctx Σ (arities_context mdecl.(ind_bodies) ,,, mdecl.(ind_params)) - cshape.(cshape_args) cshape.(cshape_sorts); + cdecl.(cstr_args) cunivs; on_cindices : - ctx_inst Σ (arities_context mdecl.(ind_bodies) ,,, mdecl.(ind_params) ,,, cshape.(cshape_args)) - cshape.(cshape_indices) - (List.rev (lift_context #|cshape.(cshape_args)| 0 ind_indices)); + ctx_inst (fun Σ Γ t T => P Σ Γ t (Some 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)); on_ctype_positive : (* The constructor type is positive *) - positive_cstr mdecl i [] (cdecl_type cdecl); + positive_cstr mdecl i [] (cstr_type cdecl); on_ctype_variance : (* The constructor type respect the variance annotation on polymorphic universes, if any. *) forall v, ind_variance mdecl = Some v -> - cstr_respects_variance Σ mdecl v cshape + cstr_respects_variance Σ mdecl v cdecl }. - Arguments on_ctype {Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments on_cargs {Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments on_cindices {Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments cstr_args_length {Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments cstr_eq {Σ mdecl i idecl ind_indices cdecl cshape}. + Arguments on_ctype {Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments on_cargs {Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments on_cindices {Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments cstr_args_length {Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments cstr_eq {Σ mdecl i idecl ind_indices cdecl cunivs}. Definition on_constructors Σ mdecl i idecl ind_indices := All2 (on_constructor Σ mdecl i idecl ind_indices). @@ -678,9 +605,9 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) Lemma projs_length ind npars k : #|projs ind npars k| = k. Proof. induction k; simpl; auto. Qed. - Definition on_projection mdecl mind i cshape (k : nat) (p : ident * term) := - let Γ := smash_context [] (cshape.(cshape_args) ++ mdecl.(ind_params)) in - match nth_error Γ (context_assumptions cshape.(cshape_args) - S k) with + Definition on_projection mdecl mind i cdecl (k : nat) (p : ident * term) := + let Γ := smash_context [] (cdecl.(cstr_args) ++ mdecl.(ind_params)) in + match nth_error Γ (context_assumptions cdecl.(cstr_args) - S k) with | None => False | Some decl => let u := abstract_instance mdecl.(ind_universes) in @@ -695,7 +622,7 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) (lift 1 k (decl_type decl)))) end. - Record on_projections mdecl mind i idecl (ind_indices : context) cshape := + Record on_projections mdecl mind i idecl (ind_indices : context) cdecl := { on_projs_record : #|idecl.(ind_ctors)| = 1; (** The inductive must be a record *) @@ -705,81 +632,82 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) on_projs_elim : idecl.(ind_kelim) = IntoAny; (** This ensures that all projections are definable *) - on_projs_all : #|idecl.(ind_projs)| = context_assumptions (cshape_args cshape); + on_projs_all : #|idecl.(ind_projs)| = context_assumptions (cstr_args cdecl); (** There are as many projections as (non-let) constructor arguments *) - on_projs : Alli (on_projection mdecl mind i cshape) 0 idecl.(ind_projs) }. + on_projs : Alli (on_projection mdecl mind i cdecl) 0 idecl.(ind_projs) }. - Definition check_constructors_smaller φ cshapes ind_sort := - Forall (fun cs => - Forall (fun argsort => leq_universe φ argsort ind_sort) cs.(cshape_sorts)) cshapes. + Definition check_constructors_smaller φ cunivss ind_sort := + Forall (fun cunivs => + Forall (fun argsort => leq_universe φ argsort ind_sort) cunivs) cunivss. (** This ensures that all sorts in kelim are lower or equal to the top elimination sort, if set. For inductives in Type we do not check [kelim] currently. *) - - Definition elim_sort_prop_ind (ind_ctors_sort : list constructor_shape) := + + Definition constructor_univs := list Universe.t. + (* The sorts of the arguments context (without lets) *) + + Definition elim_sort_prop_ind (ind_ctors_sort : list constructor_univs) := match ind_ctors_sort with | [] => (* Empty inductive proposition: *) IntoAny | [ s ] => - if forallb Universes.is_propositional (cshape_sorts s) then + if forallb Universes.is_propositional s then IntoAny (* Singleton elimination *) else IntoPropSProp (* Squashed: some arguments are higher than Prop, restrict to Prop *) | _ => (* Squashed: at least 2 constructors *) IntoPropSProp end. - Fixpoint elim_sort_sprop_ind (ind_ctors_sort : list constructor_shape) := + Fixpoint elim_sort_sprop_ind (ind_ctors_sort : list constructor_univs) := match ind_ctors_sort with | [] => (* Empty inductive strict proposition: *) IntoAny | _ => (* All other inductives in SProp are squashed *) IntoSProp end. Definition check_ind_sorts (Σ : global_env_ext) - params kelim ind_indices cshapes ind_sort : Type := + params kelim ind_indices cdecls ind_sort : Type := if Universe.is_prop ind_sort then (** The inductive is declared in the impredicative sort Prop *) (** No universe-checking to do: any size of constructor argument is allowed, however elimination restrictions apply. *) - allowed_eliminations_subset kelim (elim_sort_prop_ind cshapes) + allowed_eliminations_subset kelim (elim_sort_prop_ind cdecls) else if Universe.is_sprop ind_sort then (** The inductive is declared in the impredicative sort SProp *) (** No universe-checking to do: any size of constructor argument is allowed, however elimination restrictions apply. *) - allowed_eliminations_subset kelim (elim_sort_sprop_ind cshapes) + allowed_eliminations_subset kelim (elim_sort_sprop_ind cdecls) else (** The inductive is predicative: check that all constructors arguments are smaller than the declared universe. *) - check_constructors_smaller Σ cshapes ind_sort + check_constructors_smaller Σ cdecls ind_sort × 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. *) - ind_indices : context; - ind_sort : Universe.t; ind_arity_eq : idecl.(ind_type) = it_mkProd_or_LetIn mdecl.(ind_params) - (it_mkProd_or_LetIn ind_indices (tSort ind_sort)); + (it_mkProd_or_LetIn idecl.(ind_indices) (tSort idecl.(ind_sort))); (** It must be well-typed in the empty context. *) onArity : on_type Σ [] idecl.(ind_type); - (** The decompose shapes of each constructor *) - ind_cshapes : list constructor_shape; + (** The sorts of the arguments contexts of each constructor *) + ind_cunivs : list constructor_univs; (** Constructors are well-typed *) onConstructors : - on_constructors Σ mdecl i idecl ind_indices idecl.(ind_ctors) ind_cshapes; + on_constructors Σ mdecl i idecl idecl.(ind_indices) idecl.(ind_ctors) ind_cunivs; (** Projections, if any, are well-typed *) onProjections : idecl.(ind_projs) <> [] -> - match ind_cshapes return Type with + match idecl.(ind_ctors) return Type with | [ o ] => - on_projections mdecl mind i idecl ind_indices o + on_projections mdecl mind i idecl idecl.(ind_indices) o | _ => False end; @@ -788,12 +716,12 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) are declared in [on_constructors]. *) ind_sorts : check_ind_sorts Σ mdecl.(ind_params) idecl.(ind_kelim) - ind_indices ind_cshapes ind_sort; + idecl.(ind_indices) ind_cunivs idecl.(ind_sort); onIndices : (* The inductive type respect the variance annotation on polymorphic universes, if any. *) forall v, ind_variance mdecl = Some v -> - ind_respects_variance Σ mdecl v ind_indices + ind_respects_variance Σ mdecl v idecl.(ind_indices) }. Definition on_variance univs (variances : option (list Variance.t)) := @@ -873,24 +801,23 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) on_udecl Σ udecl -> on_global_decl (Σ, udecl) kn d -> on_global_env (Σ ,, (kn, d)). + Derive Signature for on_global_env. Definition on_global_env_ext `{checker_flags} (Σ : global_env_ext) := on_global_env Σ.1 × on_udecl Σ.1 Σ.2. End GlobalMaps. - Arguments cstr_args_length {_ P Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments cstr_eq {_ P Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments on_ctype {_ P Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments on_cargs {_ P Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments on_cindices {_ P Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments on_ctype_positive {_ P Σ mdecl i idecl ind_indices cdecl cshape}. - Arguments on_ctype_variance {_ P Σ mdecl i idecl ind_indices cdecl cshape}. + Arguments cstr_args_length {_ P Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments cstr_eq {_ P Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments on_ctype {_ P Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments on_cargs {_ P Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments on_cindices {_ P Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments on_ctype_positive {_ P Σ mdecl i idecl ind_indices cdecl cunivs}. + Arguments on_ctype_variance {_ P Σ mdecl i idecl ind_indices cdecl cunivs}. - Arguments ind_indices {_ P Σ mind mdecl i idecl}. - Arguments ind_sort {_ P Σ mind mdecl i idecl}. Arguments ind_arity_eq {_ P Σ mind mdecl i idecl}. - Arguments ind_cshapes {_ P Σ mind mdecl i idecl}. + Arguments ind_cunivs {_ P Σ mind mdecl i idecl}. Arguments onArity {_ P Σ mind mdecl i idecl}. Arguments onConstructors {_ P Σ mind mdecl i idecl}. Arguments onProjections {_ P Σ mind mdecl i idecl}. @@ -1021,4 +948,67 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) end. End wf_local_size. + Lemma lift_typing_impl P Q Σ Γ t T : + (forall Γ t T, P Σ Γ t T -> Q Σ Γ t T) -> + lift_typing P Σ Γ t T -> lift_typing Q Σ Γ t T. + Proof. + intros HPQ. + destruct T; simpl. + * apply HPQ. + * intros [s Hs]; exists s. now apply HPQ. + Qed. + + (** 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 (lift_typing typing) Σ} P Q : + (forall Σ Γ t T, on_global_env (lift_typing typing) Σ.1 -> + on_global_env P Σ.1 -> + on_global_env Q Σ.1 -> + P Σ Γ t T -> Q Σ Γ t T) -> + on_global_env P Σ -> on_global_env Q Σ. + Proof. + intros X X0. + simpl in *. revert wfΣ. induction X0; constructor; eauto. + { depelim wfΣ. eauto. } + depelim wfΣ. specialize (IHX0 wfΣ). + assert (X' := fun Γ t T => X (Σ, udecl0) Γ t T wfΣ X0 IHX0); clear X. + rename X' into X. + clear IHX0. destruct d; simpl. + - destruct c; simpl. destruct cst_body0; simpl in *; now eapply X. + - red in o. simpl in *. + destruct o0 as [onI onP onNP]. + constructor; auto. + -- eapply Alli_impl; tea. intros. + refine {| ind_arity_eq := X1.(ind_arity_eq); + ind_cunivs := X1.(ind_cunivs) |}. + --- apply onArity in X1. unfold on_type in *; simpl in *. + now eapply X. + --- pose proof X1.(onConstructors) as X11. red in X11. + eapply All2_impl; eauto. + simpl. intros. destruct X2 as [? ? ? ?]; unshelve econstructor; eauto. + * apply X; eauto. + * clear -X0 X on_cargs0. revert on_cargs0. + generalize (cstr_args x0). + induction c in y |- *; destruct y; simpl; auto; + destruct a as [na [b|] ty]; simpl in *; auto; + split; intuition eauto. + * clear -X0 X on_cindices0. + revert on_cindices0. + generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))). + generalize (cstr_indices x0). + induction 1; simpl; constructor; auto. + --- simpl; intros. pose (onProjections X1 H0). simpl in *; auto. + --- destruct X1. simpl. unfold check_ind_sorts in *. + destruct Universe.is_prop; auto. + destruct Universe.is_sprop; auto. + split. + * apply ind_sorts0. + * destruct indices_matter; auto. + eapply type_local_ctx_impl; eauto. + eapply ind_sorts0. + --- eapply X1.(onIndices). + -- red in onP. red. + eapply All_local_env_impl; tea. + Qed. + End DeclarationTyping. diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v index b938e219a..b76f10778 100644 --- a/template-coq/theories/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -31,7 +31,6 @@ Cd "gen-src". From MetaCoq.Template Require Import TemplateMonad.Extractable config Induction LiftSubst UnivSubst Pretty. Import Init.Nat. -Locate Nat. (* Floats *) (* Extraction Library Zeven. diff --git a/template-coq/theories/Induction.v b/template-coq/theories/Induction.v index 7182c9f1e..14db51c8e 100644 --- a/template-coq/theories/Induction.v +++ b/template-coq/theories/Induction.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq Require Import utils Ast AstUtils. +From MetaCoq Require Import utils Ast AstUtils Environment. (** * Deriving a compact induction principle for terms @@ -24,9 +24,9 @@ Lemma term_forall_list_ind : (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 (p : inductive * nat * relevance) (t : term), - P t -> forall t0 : term, P t0 -> forall l : list (nat * term), - tCaseBrsProp P l -> P (tCase p t t0 l)) -> + (forall (ci : case_info) (t : predicate term), + tCasePredProp P P t -> forall t0 : term, P t0 -> forall l : list (branch term), + tCaseBrsProp P l -> P (tCase ci t t0 l)) -> (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)) -> @@ -41,15 +41,17 @@ Proof. match goal with H : _ |- _ => apply H; auto end; - match goal with + try solve [match goal with |- _ P ?arg => revert arg; fix aux_arg 1; intro arg; destruct arg; constructor; [|apply aux_arg]; try split; apply auxt - end. + end]. + destruct type_info; split; cbn; [|now auto]. + revert pparams; fix aux_pparams 1. + intros []; constructor; [apply auxt|apply aux_pparams]. Defined. - Lemma lift_to_list (P : term -> Prop) : (forall t, wf t -> P t) -> forall l, Forall wf l -> Forall P l. Proof. intros IH. @@ -83,9 +85,9 @@ Lemma term_wf_forall_list_ind : (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 (p : inductive * nat * relevance) (t : term), - P t -> forall t0 : term, P t0 -> forall l : list (nat * term), - tCaseBrsProp P l -> P (tCase p t t0 l)) -> + (forall (ci : case_info) (p0 : predicate term), + tCasePredProp P P p0 -> forall t : term, P t -> forall l : list (branch term), + tCaseBrsProp P l -> P (tCase ci p0 t l)) -> (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)) -> @@ -109,12 +111,16 @@ Proof. - inv H19; auto. apply H8; auto. auto using lift_to_wf_list. - - - inv H19; apply H12; auto. - red. red in X. - induction X. - + constructor. - + constructor. inv H22; auto. apply IHX. inv H22; auto. + + - destruct X. + inv H18; apply H12; auto. + + split; auto. + apply Forall_All in H19. + eapply All_mix in a; [|exact H19]. + eapply All_impl; eauto; cbn; intros; tauto. + + apply Forall_All in H22. + eapply All_mix in X0; [|exact H22]. + eapply All_impl; eauto; cbn; intros; tauto. - inv H18; auto. @@ -131,8 +137,8 @@ Proof. + apply IHX. now inv H18. Qed. -Definition tCaseBrsType {A} (P : A -> Type) (l : list (nat * A)) := - All (fun x => P (snd x)) l. +Definition tCaseBrsType {A} (P : A -> Type) (l : list (branch A)) := + All (fun x => P (bbody x)) l. Definition tFixType {A} (P P' : A -> Type) (m : mfixpoint A) := All (fun x : def A => P x.(dtype) * P' x.(dbody))%type m. @@ -152,9 +158,9 @@ Lemma term_forall_list_rect : (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 (p : inductive * nat * relevance) (t : term), - P t -> forall t0 : term, P t0 -> forall l : list (nat * term), - tCaseBrsType P l -> P (tCase p t t0 l)) -> + (forall (ci : case_info) (p0 : predicate term), + tCasePredProp P P p0 -> forall t : term, P t -> forall l : list (branch term), + tCaseBrsType P l -> P (tCase ci p0 t l)) -> (forall (s : projection) (t : term), P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), tFixType P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixType P P m -> P (tCoFix m n)) -> @@ -169,10 +175,13 @@ Proof. match goal with H : _ |- _ => apply H; auto end; - match goal with + try solve [match goal with |- _ P ?arg => revert arg; fix aux_arg 1; intro arg; destruct arg; constructor; [|apply aux_arg]; try split; apply auxt - end. + end]. + destruct type_info; split; cbn; [|now auto]. + revert pparams; fix aux_pparams 1. + intros []; constructor; [apply auxt|apply aux_pparams]. Defined. diff --git a/template-coq/theories/LiftSubst.v b/template-coq/theories/LiftSubst.v index 3633858fe..f02ec5e0c 100644 --- a/template-coq/theories/LiftSubst.v +++ b/template-coq/theories/LiftSubst.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import utils Ast AstUtils Induction. +From MetaCoq.Template Require Import utils Ast AstUtils Environment Induction. From Coq Require Import ssreflect. From Equations Require Import Equations. @@ -9,196 +9,8 @@ From Equations Require Import Equations. Definition of [closedn] (boolean) predicate for checking if a term is closed. *) - -Fixpoint lift n k t : term := - match t with - | tRel i => tRel (if Nat.leb k i then n + i else i) - | tEvar ev args => tEvar ev (List.map (lift n k) args) - | tLambda na T M => tLambda na (lift n k T) (lift n (S k) M) - | tApp u v => tApp (lift n k u) (List.map (lift n k) v) - | tProd na A B => tProd na (lift n k A) (lift n (S k) B) - | tCast c kind t => tCast (lift n k c) kind (lift n k t) - | tLetIn na b t b' => tLetIn na (lift n k b) (lift n k t) (lift n (S k) b') - | tCase ind p c brs => - let brs' := List.map (on_snd (lift n k)) brs in - tCase ind (lift n k p) (lift n k c) brs' - | tProj p c => tProj p (lift n k c) - | tFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (lift n k) (lift n k')) mfix in - tCoFix mfix' idx - | x => x - end. - - -Notation lift0 n := (lift n 0). Definition up := lift 1 0. -Definition lift_decl n k d := (map_decl (lift n k) d). - -Definition lift_context n k (Γ : context) : context := - fold_context (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) Γ. -Proof. - unfold lift_context. apply fold_context_alt. -Qed. - -(** Parallel substitution: it assumes that all terms in the substitution live in the - same context *) - -Fixpoint subst s k u := - match u with - | tRel n => - if Nat.leb k n then - match nth_error s (n - k) with - | Some b => lift0 k b - | None => tRel (n - List.length s) - end - else tRel n - | tEvar ev args => tEvar ev (List.map (subst s k) args) - | tLambda na T M => tLambda na (subst s k T) (subst s (S k) M) - | tApp u v => mkApps (subst s k u) (List.map (subst s k) v) - | tProd na A B => tProd na (subst s k A) (subst s (S k) B) - | tCast c kind ty => tCast (subst s k c) kind (subst s k ty) - | tLetIn na b ty b' => tLetIn na (subst s k b) (subst s k ty) (subst s (S k) b') - | tCase ind p c brs => - let brs' := List.map (on_snd (subst s k)) brs in - tCase ind (subst s k p) (subst s k c) brs' - | tProj p c => tProj p (subst s k c) - | tFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let k' := List.length mfix + k in - let mfix' := List.map (map_def (subst s k) (subst s k')) mfix in - tCoFix mfix' idx - | x => x - end. - -(** Substitutes [t1 ; .. ; tn] in u for [Rel 0; .. Rel (n-1)] *in parallel* *) -Notation subst0 t := (subst t 0). -Definition subst1 t k u := subst [t] k u. -Notation subst10 t := (subst1 t 0). -Notation "M { j := N }" := (subst1 N j M) (at level 10, right associativity). - -Definition subst_context s k (Γ : context) : context := - fold_context (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. - induction Γ as [|[na [body|] ty] tl] in Γ |- *; cbn; eauto. - - rewrite !List.rev_length !mapi_rec_length !app_length !List.rev_length. simpl. - lia. - - rewrite !List.rev_length !mapi_rec_length !app_length !List.rev_length. simpl. - lia. -Qed. - -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) Γ. -Proof. - unfold subst_context, fold_context. 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. - unfold subst_context, fold_context. - rewrite !rev_mapi !rev_involutive /mapi mapi_rec_eqn /snoc. - f_equal. now rewrite Nat.sub_0_r List.rev_length. - rewrite mapi_rec_Sk. simpl. apply mapi_rec_ext. intros. - rewrite app_length !List.rev_length. simpl. f_equal. f_equal. lia. -Qed. - -Definition subst_telescope s k (Γ : context) : context := - mapi (fun k' decl => map_decl (subst s (k' + k)) decl) Γ. - -Fixpoint closedn k (t : term) : bool := - match t with - | tRel i => Nat.ltb i k - | tEvar ev args => List.forallb (closedn k) args - | tLambda _ T M | tProd _ T M => closedn k T && closedn (S k) M - | tApp u v => closedn k u && List.forallb (closedn k) v - | tCast c kind t => closedn k c && closedn k t - | tLetIn na b t b' => closedn k b && closedn k t && closedn (S k) b' - | tCase ind p c brs => - let brs' := List.forallb (test_snd (closedn k)) brs in - closedn k p && closedn k c && brs' - | tProj p c => closedn k c - | tFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (closedn k) (closedn k')) mfix - | tCoFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (closedn k) (closedn k')) mfix - | x => true - end. - -Notation closed t := (closedn 0 t). - -Fixpoint noccur_between k n (t : term) : bool := - match t with - | tRel i => Nat.ltb i k && Nat.leb (k + n) i - | tEvar ev args => List.forallb (noccur_between k n) args - | tLambda _ T M | tProd _ T M => noccur_between k n T && noccur_between (S k) n M - | tApp u v => noccur_between k n u && List.forallb (noccur_between k n) v - | tCast c kind t => noccur_between k n c && noccur_between k n t - | tLetIn na b t b' => noccur_between k n b && noccur_between k n t && noccur_between (S k) n b' - | tCase ind p c brs => - let brs' := List.forallb (test_snd (noccur_between k n)) brs in - noccur_between k n p && noccur_between k n c && brs' - | tProj p c => noccur_between k n c - | tFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix - | tCoFix mfix idx => - let k' := List.length mfix + k in - List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix - | x => true - end. - -Fixpoint extended_subst (Γ : context) (n : nat) - (* Δ, smash_context Γ, n |- extended_subst Γ n : Γ *) := - match Γ with - | nil => nil - | cons d vs => - match decl_body d with - | Some b => - (* Δ , vs |- b *) - let s := extended_subst vs n in - (* Δ , smash_context vs , n |- s : vs *) - let b' := lift (context_assumptions vs + n) #|s| b in - (* Δ, smash_context vs, n , vs |- b' *) - let b' := subst0 s b' in - (* Δ, smash_context vs , n |- b' *) - b' :: s - | None => tRel n :: extended_subst vs (S n) - end - end. - -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 Δ := - (subst_context (extended_subst Γ 0) k (lift_context (context_assumptions Γ) (k + #|Γ|) Δ)). - -Definition expand_lets_ctx Γ Δ := expand_lets_k_ctx Γ 0 Δ. - Create HintDb terms. Ltac arith_congr := repeat (try lia; progress f_equal). @@ -276,51 +88,28 @@ Proof. reflexivity. intros. lia. Qed. -Hint Extern 0 (_ = _) => progress f_equal : all. -Hint Unfold on_snd snd : all. - -Lemma on_snd_eq_id_spec {A B} (f : B -> B) (x : A * B) : - f (snd x) = snd x <-> - on_snd f x = x. -Proof. - destruct x; simpl; unfold on_snd; simpl. split; congruence. -Qed. -Hint Resolve -> on_snd_eq_id_spec : all. -Hint Resolve -> on_snd_eq_spec : all. - -Lemma map_def_eq_spec {A B} (f f' g g' : A -> B) (x : def A) : - f (dtype x) = g (dtype x) -> - f' (dbody x) = g' (dbody x) -> - map_def f f' x = map_def g g' x. -Proof. - intros. unfold map_def; f_equal; auto. -Qed. -Hint Resolve map_def_eq_spec : all. - -Lemma map_def_id_spec {A} (f f' : A -> A) (x : def A) : - f (dtype x) = (dtype x) -> - f' (dbody x) = (dbody x) -> - map_def f f' x = x. -Proof. - intros. rewrite (map_def_eq_spec _ _ id id); auto. destruct x; auto. -Qed. -Hint Resolve map_def_id_spec : all. - -Hint Extern 10 (_ < _)%nat => lia : all. -Hint Extern 10 (_ <= _)%nat => lia : all. -Hint Extern 10 (@eq nat _ _) => lia : all. - Ltac change_Sk := repeat match goal with - |- context [S (?x + ?y)] => progress change (S (x + y)) with (S x + y) + | |- context [S (?x + ?y)] => progress change (S (x + y)) with (S x + y) + | |- context [#|?l| + (?x + ?y)] => progress replace (#|l| + (x + y)) with ((#|l| + x) + y) by now rewrite Nat.add_assoc end. -Ltac solve_all := +Hint Extern 10 => progress unfold map_branches_k : all. + +Ltac solve_all_one := + try lazymatch goal with + | H: tCasePredProp _ _ _ |- _ => destruct H + end; unfold tCaseBrsProp, tFixProp in *; + try apply map_predicate_eq_spec; + try apply map_predicate_id_spec; repeat toAll; try All_map; try close_Forall; change_Sk; auto with all; intuition eauto 4 with all. +Ltac solve_all := repeat (progress solve_all_one). +Hint Extern 10 => rewrite !map_branch_map_branch : all. + Ltac nth_leb_simpl := match goal with |- context [leb ?k ?n] => elim (leb_spec_Set k n); try lia; simpl @@ -340,11 +129,11 @@ Proof. elim M using term_forall_list_ind; simpl in |- *; intros; try easy ; try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy); try (f_equal; auto; solve_all). - - - now elim (leb k n). + now elim (leb k n). Qed. Lemma lift0_p : forall M, lift0 0 M = M. +Proof. intros; unfold lift in |- *. apply lift0_id; easy. Qed. @@ -358,6 +147,7 @@ Proof. elim M using term_forall_list_ind; intros; simpl; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + rewrite -> ?map_predicate_map_predicate; try (rewrite -> H, ?H0, ?H1; auto); try (f_equal; auto; solve_all). - elim (leb_spec k n); intros. @@ -369,6 +159,20 @@ Lemma simpl_lift0 : forall M n, lift0 (S n) M = lift0 1 (lift0 n M). now intros; rewrite simpl_lift. Qed. + +Lemma map_branches_k_map_branches_k + {term term' term''} + (f : nat -> term' -> term'') + (g : branch term -> term -> term') + (f' : term -> term') + (l : list (branch term)) k : + map (fun b => map_branch (f (#|bcontext (map_branch (g b) b)| + k)) (map_branch f' b)) l = + map (fun b => map_branch (f (#|bcontext b| + k)) (map_branch f' b)) l. +Proof. + eapply map_ext => b. rewrite map_branch_map_branch. + now apply map_branch_eq_spec. +Qed. + Lemma permute_lift : forall M n k p i, i <= k -> @@ -378,7 +182,7 @@ Proof. elim M using term_forall_list_ind; intros; simpl; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, - ?Nat.add_assoc; f_equal; + ?Nat.add_assoc, ?map_predicate_map_predicate, ?map_branches_map_branches; f_equal; try solve [auto; solve_all]; repeat nth_leb_simpl. Qed. @@ -412,7 +216,7 @@ Lemma wf_lift n k t : wf t -> wf (lift n k t). Proof. intros wft; revert t wft k. apply (term_wf_forall_list_ind (fun t => forall k, wf (lift n k t))); - simpl; intros; try constructor; auto; solve_all. + intros; try constructor; simpl; auto; solve_all. Qed. Lemma mkApps_tApp t l : @@ -432,7 +236,8 @@ Lemma simpl_subst_rec : Proof. intros M wfM. induction wfM using term_wf_forall_list_ind; intros; simpl; - 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; try solve [f_equal; auto; solve_all]; repeat nth_leb_simpl. - rewrite IHwfM; auto. @@ -465,7 +270,8 @@ Proof. intros M. elim M using term_forall_list_ind; intros; simpl; try easy; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc, + ?map_predicate_map_predicate; try solve [f_equal; auto; solve_all]. - repeat nth_leb_simpl. @@ -490,7 +296,8 @@ Proof. |- context [tRel _] => idtac | |- _ => cbn -[plus] end; try easy; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc, + ?map_predicate_map_predicate; try solve [f_equal; auto; solve_all]. - unfold subst at 1. unfold lift at 4. @@ -544,7 +351,8 @@ Proof. |- context [tRel _] => idtac | |- _ => simpl end; try easy; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc, + ?map_predicate_map_predicate; try solve [f_equal; auto; solve_all]. - unfold subst at 2. @@ -586,9 +394,11 @@ Lemma lift_closed n k t : closedn k t -> lift n k t = t. Proof. revert k. elim t using term_forall_list_ind; intros; try easy; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; - unfold test_def in *; - simpl closed in *; try solve [simpl lift; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + ?map_predicate_map_predicate; + simpl closed in *; + unfold test_def, test_predicate in *; + try solve [simpl lift; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - rewrite lift_rel_lt; auto. revert H. elim (Nat.ltb_spec n0 k); intros; try easy. - simpl lift. f_equal. solve_all. unfold test_def in b. toProp. solve_all. @@ -599,8 +409,9 @@ Lemma closed_upwards {k t} k' : closedn k t -> k' >= k -> closedn k' t. Proof. revert k k'. elim t using term_forall_list_ind; intros; try lia; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; - simpl closed in *; unfold test_snd, test_def in *; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + ?map_predicate_map_predicate; + simpl closed in *; unfold test_snd, test_def, test_predicate, test_branch in *; try solve [(try f_equal; simpl; repeat (rtoProp; solve_all); eauto)]. - elim (ltb_spec n k'); auto. intros. @@ -643,6 +454,8 @@ Proof. apply wf_lift; auto. constructor. constructor. - apply Forall_map. eapply Forall_impl; eauto. - apply wf_mkApps; auto. apply Forall_map. eapply Forall_impl; eauto. + - destruct X. apply Forall_map. apply All_Forall. eapply All_impl; eauto. + - destruct X; cbn; auto. - apply Forall_map. apply All_Forall. eapply All_impl; tea. intros [] XX; cbn in *; apply XX. - solve_all. @@ -695,7 +508,8 @@ Proof. intros wft wfl. induction wft in k |- * using term_wf_forall_list_ind; simpl; auto; rewrite ?subst_mkApps; try change_Sk; - try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + ?map_predicate_map_predicate; eauto; solve_all). - repeat nth_leb_simpl. @@ -714,7 +528,8 @@ Proof. intros wft wfl wfl'. induction wft in k |- * using term_wf_forall_list_ind; simpl; eauto; rewrite ?subst_mkApps; try change_Sk; - try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc; + try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + ?Nat.add_assoc, ?map_predicate_map_predicate; eauto; solve_all; eauto). - repeat nth_leb_simpl. @@ -752,7 +567,11 @@ Proof. - rewrite lift_mkApps IHt map_map_compose. f_equal; solve_all. + - rewrite !map_predicate_map_predicate. + unfold map_predicate. f_equal. + solve_all. solve_all. Qed. + Lemma mkApps_ex t u l : ∑ f args, Ast.mkApps t (u :: l) = Ast.tApp f args. Proof. induction t; simpl; eexists _, _; reflexivity. diff --git a/template-coq/theories/Normal.v b/template-coq/theories/Normal.v index 8ecd1235a..15c5ca8e7 100644 --- a/template-coq/theories/Normal.v +++ b/template-coq/theories/Normal.v @@ -29,8 +29,10 @@ 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 -> Forall (normal Γ ∘ snd) brs -> - neutral Γ (tCase i p c brs) + | 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) | ne_proj p c : neutral Γ c -> neutral Γ (tProj p c). Inductive whnf (Γ : context) : term -> Prop := diff --git a/template-coq/theories/Pretty.v b/template-coq/theories/Pretty.v index 893d593cb..220daf0f9 100644 --- a/template-coq/theories/Pretty.v +++ b/template-coq/theories/Pretty.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq Require Import utils Ast AstUtils LiftSubst Universes. +From MetaCoq Require Import utils Ast AstUtils Environment LiftSubst Universes. (** * Pretty printing *) @@ -7,13 +7,6 @@ From MetaCoq Require Import utils Ast AstUtils LiftSubst Universes. Section print_term. Context (Σ : global_env_ext). - Definition fix_context (m : mfixpoint term) : context := - List.rev (mapi (fun i d => vass d.(dname) (lift0 i d.(dtype))) m). - - Definition print_defs (print_term : context -> bool -> term -> string) Γ (defs : mfixpoint term) := - let ctx' := fix_context defs in - print_list (print_def (print_term Γ true) (print_term (ctx' ++ Γ) true)) (nl ^ " with ") defs. - Fixpoint decompose_lam (t : term) (n : nat) : (list aname) * (list term) * term := match n with | 0 => ([], [], t) @@ -26,13 +19,8 @@ Section print_term. end end. - Definition is_fresh (Γ : context) (id : ident) := - List.forallb - (fun decl => - match decl.(decl_name).(binder_name) with - | nNamed id' => negb (ident_eq id id') - | nAnon => true - end) Γ. + Definition is_fresh (Γ : list ident) (id : ident) := + List.forallb (fun id' => negb (ident_eq id id')) Γ. (* todo : duplicate in Environment ? *) Fixpoint lookup_env (Σ : global_env) (id : kername) : option global_decl := @@ -82,25 +70,68 @@ Section print_term. end in aux n. - Definition fresh_name (Γ : context) (na : name) (t : term) := + Definition fresh_name (Γ : list ident) (na : name) (t : option term) : ident := let id := match na with | nNamed id => id - | nAnon => name_from_term t + | nAnon => + match t with + | Some t => name_from_term t + | None => "_" + end end in - if is_fresh Γ id then nNamed id - else nNamed (fresh_id_from Γ 10 id). + if is_fresh Γ id then id + else fresh_id_from Γ 10 id. + + 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) + (pred : predicate term) : option context := + (* Decompose the type. It will contain parameters too, but at the end, which is ok. *) + let '(Γ, _) := decompose_prod_assum [] (ind_type oib) in + (* We have to skip the first name since that's the name of the inductive binder. *) + let index_names := tl (pcontext pred) in + match hd_error (pcontext pred) with + | Some ind_binder_name => + Some ( + map (fun '(na, decl) => rename_decl na decl) + (combine (tl (pcontext pred)) Γ) + ,, + 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 + | [] => Γids + | decl :: Γ => aux (fresh_name Γids (binder_name (decl_name decl)) + (Some (decl_type decl)) :: Γids) + Γ + end in + aux Γ (MCList.rev Γ'). + + Definition print_defs (print_term : list ident -> bool -> term -> string) + Γ + (defs : mfixpoint term) := + let ctx' := fix_context defs in + print_list (print_def (print_term Γ true) (print_term (fresh_names Γ ctx') true)) + (nl ^ " with ") defs. (* TODO: SPROP: we ignore relevance on printing, maybe add print config? *) - Fixpoint print_term (Γ : context) (top : bool) (t : term) {struct t} := + Fixpoint print_term (Γ : list ident) (top : bool) (t : term) {struct t} := match t with | tRel n => match nth_error Γ n with - | Some {| decl_name := na |} => - match na.(binder_name) with - | nAnon => "Anonymous (" ^ string_of_nat n ^ ")" - | nNamed id => id - end + | Some id => id | None => "UnboundRel(" ^ string_of_nat n ^ ")" end | tVar n => "Var(" ^ n ^ ")" @@ -108,22 +139,22 @@ Section print_term. | tSort s => string_of_sort s | tCast c k t => parens top (print_term Γ true c ^ ":" ^ print_term Γ true t) | tProd na dom codom => - let na' := (fresh_name Γ na.(binder_name) dom) in - let ann_na' := mkBindAnn na' na.(binder_relevance) in - parens top - ("∀ " ^ string_of_name na' ^ " : " ^ - print_term Γ true dom ^ ", " ^ print_term (vass ann_na' dom :: Γ) true codom) + let na' := (fresh_name Γ na.(binder_name) (Some dom)) in + if (noccur_between 0 1 codom) then + parens top + (print_term Γ false dom ^ " → " ^ print_term (na' :: Γ) true codom) + else parens top + ("∀ " ^ na' ^ " : " ^ + print_term Γ false dom ^ ", " ^ print_term (na' :: Γ) true codom) | tLambda na dom body => - let na' := (fresh_name Γ na.(binder_name) dom) in - let ann_na' := mkBindAnn na' na.(binder_relevance) in - parens top ("fun " ^ string_of_name na' ^ " : " ^ print_term Γ true dom - ^ " => " ^ print_term (vass ann_na' dom :: Γ) true body) + let na' := (fresh_name Γ na.(binder_name) (Some dom)) in + parens top ("fun " ^ na' ^ " : " ^ print_term Γ true dom + ^ " ⇒ " ^ print_term (na' :: Γ) true body) | tLetIn na def dom body => - let na' := (fresh_name Γ na.(binder_name) dom) in - let ann_na' := mkBindAnn na' na.(binder_relevance) in - parens top ("let" ^ string_of_name na' ^ " : " ^ print_term Γ true dom ^ + let na' := (fresh_name Γ na.(binder_name) (Some dom)) in + parens top ("let " ^ na' ^ " : " ^ print_term Γ true dom ^ " := " ^ print_term Γ true def ^ " in " ^ nl ^ - print_term (vdef ann_na' def dom :: Γ) true body) + print_term (na' :: Γ) true body) | tApp f l => parens top (print_term Γ false f ^ " " ^ print_list (print_term Γ false) " " l) | tConst c u => string_of_kername c ^ print_universe_instance u @@ -137,7 +168,7 @@ Section print_term. match lookup_ind_decl i k with | Some oib => match nth_error oib.(ind_ctors) l with - | Some (na, _, _) => na ^ print_universe_instance u + | Some cb => cb.(cstr_name) ^ print_universe_instance u | None => "UnboundConstruct(" ^ string_of_inductive ind ^ "," ^ string_of_nat l ^ "," ^ string_of_universe_instance u ^ ")" @@ -146,40 +177,46 @@ Section print_term. "UnboundConstruct(" ^ string_of_inductive ind ^ "," ^ string_of_nat l ^ "," ^ string_of_universe_instance u ^ ")" end - | tCase (mkInd mind i as ind, pars, _) p t brs => + | tCase {| ci_ind := mkInd mind i as ind; ci_npar := pars |} p t brs => match lookup_ind_decl mind i with | Some oib => - match p with - | tLambda na _ty b => - let fix print_branch Γ arity br {struct br} := - match arity with - | 0 => "=> " ^ print_term Γ true br - | S n => - match br with - | tLambda na A B => - let na' := (fresh_name Γ na.(binder_name) A) in - let ann_na' := mkBindAnn na' na.(binder_relevance) in - string_of_name na' ^ " " ^ print_branch (vass ann_na' A :: Γ) n B - | t => "=> " ^ print_term Γ true br - end + 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_list (pretty_string_of_branch string_of_term) brs ^ ")" + + | Some Γret => + let Γret := fresh_names Γ Γret in + let ret_binders := firstn #|pcontext p| Γret in + let (as_name, indices) := (hd "_" ret_binders, MCList.rev (tail ret_binders)) in + let in_args := repeat "_" #|pparams p| ++ indices in + let in_str := oib.(ind_name) ^ String.concat "" (map (fun a => " " ^ a) in_args) in + + let fix print_branch Γ names prbr {struct names} := + match names with + | [] => "⇒ " ^ prbr Γ + | na :: l => + let na' := (fresh_name Γ na.(binder_name) None) in + na' ^ " " ^ print_branch (na' :: Γ) l prbr end in - let brs := map (fun '(arity, br) => - print_branch Γ arity br) brs in + + 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 " ^ string_of_name na.(binder_name) ^ - " in " ^ oib.(ind_name) ^ " return " ^ print_term Γ true b ^ + " as " ^ as_name ^ + " in " ^ in_str ^ + " return " ^ print_term Γret true (preturn p) ^ " with " ^ nl ^ - print_list (fun '(b, (na, _, _)) => na ^ " " ^ b) + print_list (fun '(b, cb) => cb.(cstr_name) ^ " " ^ b) (nl ^ " | ") brs ^ nl ^ "end" ^ nl) - | _ => - "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_term p ^ "," ^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")" end | None => "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_term p ^ "," ^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")" + ^ string_of_predicate string_of_term p ^ "," ^ + string_of_list (pretty_string_of_branch string_of_term) brs ^ ")" end | tProj (mkInd mind i as ind, pars, k) c => match lookup_ind_decl mind i with @@ -207,3 +244,72 @@ Section print_term. end. End print_term. + +Definition pr_context_decl (Σ : global_env_ext) Γ (c : context_decl) : ident * string := + match c with + | {| 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 ++ ")")%string) + | {| decl_name := na; decl_type := ty; decl_body := Some b |} => + let na' := (fresh_name Σ Γ na.(binder_name) (Some ty)) in + (na', ("(" ++ na' ++ " : " ++ print_term Σ Γ true ty ++ " := " ++ + print_term Σ Γ true b ++ ")")%string) + end. + +Fixpoint print_context Σ Γ Δ := + match Δ with + | [] => (Γ, ""%string) + | d :: decls => + let '(Γ, s) := print_context Σ Γ decls in + let '(na, s') := pr_context_decl Σ Γ d in + match decls with + | [] => (na :: Γ, (s ++ s')%string) + | _ => (na :: Γ, (s ++ " " ++ s')%string) + end + end. + +Definition print_one_cstr Σ Γ (mib : mutual_inductive_body) (c : constructor_body) : string := + 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) : string := + 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). + +Fixpoint print_env_aux (short : bool) (prefix : nat) (Σ : global_env) (acc : string) := + match prefix with + | 0 => match Σ with [] => acc | _ => ("..." ++ nl ++ acc)%string end + | S n => + match Σ with + | [] => acc + | (kn, InductiveDecl mib) :: Σ => + let Σ' := (Σ, mib.(ind_universes)) in + let names := fresh_names Σ' [] (arities_context mib.(ind_bodies)) in + print_env_aux short n Σ + ("Inductive " ++ + print_list (print_one_ind short Σ' names mib) nl mib.(ind_bodies) ++ "." ++ + nl ++ acc)%string + | (kn, ConstantDecl cb) :: Σ => + let Σ' := (Σ, cb.(cst_universes)) in + print_env_aux short n Σ + ((match cb.(cst_body) with + | Some _ => "Definition " + | None => "Axiom " + end) ++ string_of_kername kn ++ " : " ++ print_term Σ' nil true cb.(cst_type) ++ + match cb.(cst_body) with + | Some b => + if short then ("..." ++ nl)%string + else (" := " ++ nl ++ print_term Σ' nil true b ++ "." ++ nl) + | None => "." + end ++ acc)%string + end + end. + +Definition print_env (short : bool) (prefix : nat) Σ := print_env_aux short prefix Σ EmptyString. + +Definition print_program (short : bool) (prefix : nat) (p : program) : string := + print_env short prefix (fst p) ++ nl ++ + print_term (empty_ext (fst p)) nil true (snd p). diff --git a/template-coq/theories/Reflect.v b/template-coq/theories/Reflect.v index d87c4ccf3..bbde103cb 100644 --- a/template-coq/theories/Reflect.v +++ b/template-coq/theories/Reflect.v @@ -1,42 +1,10 @@ (* Distributed under the terms of the MIT license. *) (* For primitive integers and floats *) From Coq Require Numbers.Cyclic.Int63.Int63 Floats.PrimFloat Floats.FloatAxioms. -From MetaCoq.Template Require Import utils AstUtils BasicAst Ast Induction. +From MetaCoq.Template Require Import utils BasicAst Universes. Require Import ssreflect. From Equations Require Import Equations. -(** * Notion of reflection for Type-based properties *) - -Inductive reflectT (A : Type) : bool -> Type := -| ReflectT : A -> reflectT A true -| ReflectF : (A -> False) -> reflectT A false. - -Lemma reflectT_reflect (A : Prop) b : reflectT A b -> reflect A b. -Proof. - destruct 1; now constructor. -Qed. - -Lemma reflect_reflectT (A : Prop) b : reflect A b -> reflectT A b. -Proof. - destruct 1; now constructor. -Qed. - -Lemma equiv_reflectT P (b : bool) : (P -> b) -> (b -> P) -> reflectT P b. -Proof. - intros. destruct b; constructor; auto. - intros p; specialize (H p). discriminate. -Qed. - -Lemma reflectT_subrelation {A} {R} {r : A -> A -> bool} : (forall x y, reflectT (R x y) (r x y)) -> CRelationClasses.subrelation R r. -Proof. - intros. intros x y h. destruct (X x y); auto. -Qed. - -Lemma reflectT_subrelation' {A} {R} {r : A -> A -> bool} : (forall x y, reflectT (R x y) (r x y)) -> CRelationClasses.subrelation r R. -Proof. - intros. intros x y h. destruct (X x y); auto. discriminate. -Qed. - (* Some reflection / EqDec lemmata *) Class ReflectEq A := { @@ -80,16 +48,16 @@ Ltac nodec := let bot := fresh "bot" in try solve [ constructor ; intro bot ; inversion bot ; subst ; tauto ]. -Definition eq_option {A} `{ReflectEq A} (u v : option A) : bool := +Definition eq_option {A} (eqA : A -> A -> bool) (u v : option A) : bool := match u, v with - | Some u, Some v => eqb u v + | Some u, Some v => eqA u v | None, None => true | _, _ => false end. Instance reflect_option : forall {A}, ReflectEq A -> ReflectEq (option A). Proof. - intros A RA. refine {| eqb := eq_option |}. + intros A RA. refine {| eqb := eq_option eqb |}. intros x y. destruct x, y. all: cbn. all: try solve [ constructor ; easy ]. @@ -300,7 +268,7 @@ Defined. Definition eq_aname (na nb : binder_annot name) := eqb na.(binder_name) nb.(binder_name) && eqb na.(binder_relevance) nb.(binder_relevance). - + #[program] Instance reflect_aname : ReflectEq aname := { eqb := eq_aname }. @@ -402,134 +370,9 @@ Proof. apply eq_dec_univ0. Defined. -Local Ltac finish := - let h := fresh "h" in - right ; - match goal with - | e : ?t <> ?u |- _ => - intro h ; apply e ; now inversion h - end. - -Local Ltac fcase c := - let e := fresh "e" in - case c ; intro e ; [ subst ; try (left ; reflexivity) | finish ]. - -Local Ltac term_dec_tac term_dec := - repeat match goal with - | t : term, u : term |- _ => fcase (term_dec t u) - | u : Universe.t, u' : Universe.t |- _ => fcase (eq_dec u u') - | x : Instance.t, y : Instance.t |- _ => - fcase (eq_dec x y) - | x : list Level.t, y : Instance.t |- _ => - fcase (eq_dec x y) - | n : nat, m : nat |- _ => fcase (Nat.eq_dec n m) - | i : ident, i' : ident |- _ => fcase (string_dec i i') - | i : kername, i' : kername |- _ => fcase (kername_eq_dec i i') - | i : string, i' : kername |- _ => fcase (string_dec i i') - | n : name, n' : name |- _ => fcase (eq_dec n n') - | n : aname, n' : aname |- _ => fcase (eq_dec n n') - | i : inductive, i' : inductive |- _ => fcase (eq_dec i i') - | x : inductive * nat, y : inductive * nat |- _ => - fcase (eq_dec x y) - | x : (inductive * nat) * relevance, y : (inductive * nat) * relevance |- _ => - fcase (eq_dec x y) - | x : projection, y : projection |- _ => fcase (eq_dec x y) - | x : cast_kind, y : cast_kind |- _ => fcase (eq_dec x y) - end. - -Derive NoConfusion NoConfusionHom for term. - -Instance EqDec_term : EqDec term. -Proof. - intro x; induction x using term_forall_list_rect ; intro t ; - destruct t ; try (right ; discriminate). - all: term_dec_tac term_dec. - - induction X in args |- *. - + destruct args. - * left. reflexivity. - * right. discriminate. - + destruct args. - * right. discriminate. - * destruct (IHX args) ; nodec. - destruct (p t) ; nodec. - subst. left. inversion e. reflexivity. - - destruct (IHx1 t1) ; nodec. - destruct (IHx2 t2) ; nodec. - subst. left. reflexivity. - - destruct (IHx1 t1) ; nodec. - destruct (IHx2 t2) ; nodec. - subst. left. reflexivity. - - destruct (IHx1 t1) ; nodec. - destruct (IHx2 t2) ; nodec. - subst. left. reflexivity. - - destruct (IHx1 t1) ; nodec. - destruct (IHx2 t2) ; nodec. - destruct (IHx3 t3) ; nodec. - subst. left. reflexivity. - - destruct (IHx t) ; nodec. - subst. induction X in args |- *. - + destruct args. all: nodec. - left. reflexivity. - + destruct args. all: nodec. - destruct (IHX args). all: nodec. - destruct (p t0). all: nodec. - subst. inversion e. subst. - left. reflexivity. - - destruct (IHx1 t1) ; nodec. - destruct (IHx2 t2) ; nodec. - subst. revert branches. clear IHx1 IHx2. - induction X ; intro l0. - + destruct l0. - * left. reflexivity. - * right. discriminate. - + destruct l0. - * right. discriminate. - * destruct (IHX l0) ; nodec. - destruct (p (snd p0)) ; nodec. - destruct (eq_dec (fst x) (fst p0)) ; nodec. - destruct x, p0. - left. - cbn in *. subst. inversion e. reflexivity. - - destruct (IHx t) ; nodec. - left. subst. reflexivity. - - revert mfix. induction X ; intro m0. - + destruct m0. - * left. reflexivity. - * right. discriminate. - + destruct p as [p1 p2]. - destruct m0. - * right. discriminate. - * destruct (p1 (dtype d)) ; nodec. - destruct (p2 (dbody d)) ; nodec. - destruct (IHX m0) ; nodec. - destruct x, d ; subst. cbn in *. - destruct (eq_dec dname dname0) ; nodec. - subst. inversion e1. subst. - destruct (eq_dec rarg rarg0) ; nodec. - subst. left. reflexivity. - - revert mfix. induction X ; intro m0. - + destruct m0. - * left. reflexivity. - * right. discriminate. - + destruct p as [p1 p2]. - destruct m0. - * right. discriminate. - * destruct (p1 (dtype d)) ; nodec. - destruct (p2 (dbody d)) ; nodec. - destruct (IHX m0) ; nodec. - destruct x, d ; subst. cbn in *. - destruct (eq_dec dname dname0) ; nodec. - subst. inversion e1. subst. - destruct (eq_dec rarg rarg0) ; nodec. - subst. left. reflexivity. - - destruct (Int63.eqs i i0) ; nodec. - subst. left. reflexivity. - - destruct (eq_dec f f0) ; nodec. - subst. left. reflexivity. -Defined. +Instance reflect_eq_univ : ReflectEq Universe.t := EqDec_ReflectEq _. -Instance reflect_term : ReflectEq term := - let h := EqDec_ReflectEq term in _. +Instance reflect_case_info : ReflectEq case_info := EqDec_ReflectEq case_info. Definition eq_sig_true {A f} `{ReflectEq A} (x y : { z : A | f z = true }) : bool := let '(exist x hx) := x in @@ -548,23 +391,23 @@ Defined. Derive NoConfusion NoConfusionHom for sig. Derive NoConfusion NoConfusionHom for prod. -Definition eqb_context_decl (x y : context_decl) := +Definition eqb_context_decl {term : Type} (eqterm : term -> term -> bool) + (x y : BasicAst.context_decl term) := let (na, b, ty) := x in let (na', b', ty') := y in - eqb na na' && eqb b b' && eqb ty ty'. + eqb na na' && eq_option eqterm b b' && eqterm ty ty'. -Instance eq_ctx : ReflectEq context_decl. +Instance eq_decl_reflect {term} {Ht : ReflectEq term} : ReflectEq (BasicAst.context_decl term). Proof. - refine {| eqb := eqb_context_decl |}. + refine {| eqb := eqb_context_decl eqb |}. intros. destruct x as [na b ty], y as [na' b' ty']. cbn -[eqb]. + change (eq_option eqb b b') with (eqb b b'). destruct (eqb_spec na na'); subst; destruct (eqb_spec b b'); subst; destruct (eqb_spec ty ty'); subst; constructor; congruence. Qed. -Instance eqb_ctx : ReflectEq context := _. - Definition eqb_recursivity_kind r r' := match r, r' with | Finite, Finite => true @@ -635,6 +478,7 @@ Ltac finish_reflect := | |- context[eqb ?a ?b] => destruct (eqb_spec a b); [subst|constructor; congruence] end); constructor; trivial; congruence. + Instance reflect_universes_decl : ReflectEq universes_decl. Proof. refine {| eqb := eqb_universes_decl |}. @@ -642,18 +486,6 @@ Proof. intros [] []; finish_reflect. Defined. -Definition eqb_constant_body (x y : constant_body) := - let (tyx, bodyx, univx) := x in - let (tyy, bodyy, univy) := y in - eqb tyx tyy && eqb bodyx bodyy && eqb univx univy. - -Instance reflect_constant_body : ReflectEq constant_body. -Proof. - refine {| eqb := eqb_constant_body |}. - intros [] []. - unfold eqb_constant_body; finish_reflect. -Defined. - Definition eqb_allowed_eliminations x y := match x, y with | IntoSProp, IntoSProp @@ -669,17 +501,7 @@ Proof. intros [] []; simpl; constructor; congruence. Defined. -Definition eqb_one_inductive_body (x y : one_inductive_body) := - let (n, t, k, c, p, r) := x in - let (n', t', k', c', p', r') := y in - eqb n n' && eqb t t' && eqb k k' && eqb c c' && eqb p p' && eqb r r'. - -Instance reflect_one_inductive_body : ReflectEq one_inductive_body. -Proof. - refine {| eqb := eqb_one_inductive_body |}. - intros [] []. - unfold eqb_one_inductive_body; finish_reflect. -Defined. +Local Infix "==?" := eqb (at level 20). Definition eqb_Variance x y := match x, y with @@ -694,29 +516,3 @@ Proof. refine {| eqb := eqb_Variance |}. intros [] []; constructor; congruence. Defined. - -Definition eqb_mutual_inductive_body (x y : mutual_inductive_body) := - let (f, n, p, b, u, v) := x in - let (f', n', p', b', u', v') := y in - eqb f f' && eqb n n' && eqb b b' && eqb p p' && eqb u u' && eqb v v'. - -Instance reflect_mutual_inductive_body : ReflectEq mutual_inductive_body. -Proof. - refine {| eqb := eqb_mutual_inductive_body |}. - intros [] []. - unfold eqb_mutual_inductive_body; finish_reflect. -Defined. - -Definition eqb_global_decl x y := - match x, y with - | ConstantDecl cst, ConstantDecl cst' => eqb cst cst' - | InductiveDecl mib, InductiveDecl mib' => eqb mib mib' - | _, _ => false - end. - -Instance reflect_global_decl : ReflectEq global_decl. -Proof. - refine {| eqb := eqb_global_decl |}. - unfold eqb_global_decl. - intros [] []; finish_reflect. -Defined. diff --git a/template-coq/theories/ReflectAst.v b/template-coq/theories/ReflectAst.v new file mode 100644 index 000000000..0c07c76f6 --- /dev/null +++ b/template-coq/theories/ReflectAst.v @@ -0,0 +1,233 @@ +(* Distributed under the terms of the MIT license. *) +(* For primitive integers and floats *) +From Coq Require Numbers.Cyclic.Int63.Int63 Floats.PrimFloat Floats.FloatAxioms. +From MetaCoq.Template Require Import utils AstUtils BasicAst Ast Reflect Environment Induction. +Require Import ssreflect. +From Equations Require Import Equations. + +Local Infix "==?" := eqb (at level 20). + +Local Ltac finish := + let h := fresh "h" in + right ; + match goal with + | e : ?t <> ?u |- _ => + intro h ; apply e ; now inversion h + end. + +Local Ltac fcase c := + let e := fresh "e" in + case c ; intro e ; [ subst ; try (left ; reflexivity) | finish ]. + +Local Ltac term_dec_tac term_dec := + repeat match goal with + | t : term, u : term |- _ => fcase (term_dec t u) + | u : Universe.t, u' : Universe.t |- _ => fcase (eq_dec u u') + | x : Instance.t, y : Instance.t |- _ => + fcase (eq_dec x y) + | x : list Level.t, y : Instance.t |- _ => + fcase (eq_dec x y) + | x : list aname, y : list aname |- _ => + fcase (eq_dec x y) + | n : nat, m : nat |- _ => fcase (Nat.eq_dec n m) + | i : ident, i' : ident |- _ => fcase (string_dec i i') + | i : kername, i' : kername |- _ => fcase (kername_eq_dec i i') + | i : string, i' : kername |- _ => fcase (string_dec i i') + | n : name, n' : name |- _ => fcase (eq_dec n n') + | n : aname, n' : aname |- _ => fcase (eq_dec n n') + | i : inductive, i' : inductive |- _ => fcase (eq_dec i i') + | x : inductive * nat, y : inductive * nat |- _ => + fcase (eq_dec x y) + | x : case_info, y : case_info |- _ => + fcase (eq_dec x y) + | x : projection, y : projection |- _ => fcase (eq_dec x y) + | x : cast_kind, y : cast_kind |- _ => fcase (eq_dec x y) + end. + +Instance eq_predicate {term} `{EqDec term} : EqDec (predicate term). +Proof. + intros [] []. + fcase (eq_dec pparams pparams0). + fcase (eq_dec puinst puinst0). + fcase (eq_dec pcontext pcontext0). + fcase (eq_dec preturn preturn0). +Defined. + +Derive NoConfusion NoConfusionHom for term. + +Instance EqDec_term : EqDec term. +Proof. + intro x; induction x using term_forall_list_rect ; intro t ; + destruct t ; try (right ; discriminate). + all: term_dec_tac term_dec. + - induction X in args |- *. + + destruct args. + * left. reflexivity. + * right. discriminate. + + destruct args. + * right. discriminate. + * destruct (IHX args) ; nodec. + destruct (p t) ; nodec. + subst. left. inversion e. reflexivity. + - destruct (IHx1 t1) ; nodec. + destruct (IHx2 t2) ; nodec. + subst. left. reflexivity. + - destruct (IHx1 t1) ; nodec. + destruct (IHx2 t2) ; nodec. + subst. left. reflexivity. + - destruct (IHx1 t1) ; nodec. + destruct (IHx2 t2) ; nodec. + subst. left. reflexivity. + - destruct (IHx1 t1) ; nodec. + destruct (IHx2 t2) ; nodec. + destruct (IHx3 t3) ; nodec. + subst. left. reflexivity. + - destruct (IHx t) ; nodec. + subst. induction X in args |- *. + + destruct args. all: nodec. + left. reflexivity. + + destruct args. all: nodec. + destruct (IHX args). all: nodec. + destruct (p t0). all: nodec. + subst. inversion e. subst. + left. reflexivity. + - destruct (IHx t) ; nodec. + destruct p0, type_info; subst; cbn. + term_dec_tac term_dec. + destruct X as (?&?). + destruct (s preturn0); cbn in * ; nodec. + subst. + assert ({pparams = pparams0} + {pparams <> pparams0}) as []; nodec. + { revert pparams0. + clear -a. + induction a. + - intros []; [left; reflexivity|right; discriminate]. + - intros []; [right; discriminate|]. + destruct (p t) ; nodec. + destruct (IHa l0) ; nodec. + subst; left; reflexivity. } + subst. + revert branches. clear -X0. + induction X0 ; intro l0. + + destruct l0. + * left. reflexivity. + * right. discriminate. + + destruct l0. + * right. discriminate. + * destruct (IHX0 l0) ; nodec. + destruct (p (bbody b)) ; nodec. + destruct (eq_dec (bcontext x) (bcontext b)) ; nodec. + destruct x, b. + left. + cbn in *. subst. inversion e. reflexivity. + - destruct (IHx t) ; nodec. + left. subst. reflexivity. + - revert mfix. induction X ; intro m0. + + destruct m0. + * left. reflexivity. + * right. discriminate. + + destruct p as [p1 p2]. + destruct m0. + * right. discriminate. + * destruct (p1 (dtype d)) ; nodec. + destruct (p2 (dbody d)) ; nodec. + destruct (IHX m0) ; nodec. + destruct x, d ; subst. cbn in *. + destruct (eq_dec dname dname0) ; nodec. + subst. inversion e1. subst. + destruct (eq_dec rarg rarg0) ; nodec. + subst. left. reflexivity. + - revert mfix. induction X ; intro m0. + + destruct m0. + * left. reflexivity. + * right. discriminate. + + destruct p as [p1 p2]. + destruct m0. + * right. discriminate. + * destruct (p1 (dtype d)) ; nodec. + destruct (p2 (dbody d)) ; nodec. + destruct (IHX m0) ; nodec. + destruct x, d ; subst. cbn in *. + destruct (eq_dec dname dname0) ; nodec. + subst. inversion e1. subst. + destruct (eq_dec rarg rarg0) ; nodec. + subst. left. reflexivity. + - destruct (Int63.eqs i i0) ; nodec. + subst. left. reflexivity. + - destruct (eq_dec f f0) ; nodec. + subst. left. reflexivity. +Defined. + +Instance reflect_term : ReflectEq term := + let h := EqDec_ReflectEq term in _. + +Instance eqb_ctx : ReflectEq context := _. + +Definition eqb_constant_body (x y : constant_body) := + let (tyx, bodyx, univx) := x in + let (tyy, bodyy, univy) := y in + eqb tyx tyy && eqb bodyx bodyy && eqb univx univy. + +Instance reflect_constant_body : ReflectEq constant_body. +Proof. + refine {| eqb := eqb_constant_body |}. + intros [] []. + unfold eqb_constant_body; finish_reflect. +Defined. + +Definition eqb_constructor_body (x y : constructor_body) := + x.(cstr_name) ==? y.(cstr_name) && + x.(cstr_args) ==? y.(cstr_args) && + x.(cstr_indices) ==? y.(cstr_indices) && + x.(cstr_type) ==? y.(cstr_type) && + x.(cstr_arity) ==? y.(cstr_arity). + +Instance reflect_constructor_body : ReflectEq constructor_body. +Proof. + refine {| eqb := eqb_constructor_body |}. + intros [] []. + unfold eqb_constructor_body; cbn -[eqb]. finish_reflect. +Defined. + +Definition eqb_one_inductive_body (x y : one_inductive_body) := + x.(ind_name) ==? y.(ind_name) && + x.(ind_indices) ==? y.(ind_indices) && + x.(ind_sort) ==? y.(ind_sort) && + x.(ind_type) ==? y.(ind_type) && + x.(ind_kelim) ==? y.(ind_kelim) && + x.(ind_ctors) ==? y.(ind_ctors) && + x.(ind_projs) ==? y.(ind_projs) && + x.(ind_relevance) ==? y.(ind_relevance). + +Instance reflect_one_inductive_body : ReflectEq one_inductive_body. +Proof. + refine {| eqb := eqb_one_inductive_body |}. + intros [] []. + unfold eqb_one_inductive_body; cbn -[eqb]; finish_reflect. +Defined. + +Definition eqb_mutual_inductive_body (x y : mutual_inductive_body) := + let (f, n, p, b, u, v) := x in + let (f', n', p', b', u', v') := y in + eqb f f' && eqb n n' && eqb b b' && eqb p p' && eqb u u' && eqb v v'. + +Instance reflect_mutual_inductive_body : ReflectEq mutual_inductive_body. +Proof. + refine {| eqb := eqb_mutual_inductive_body |}. + intros [] []. + unfold eqb_mutual_inductive_body; finish_reflect. +Defined. + +Definition eqb_global_decl x y := + match x, y with + | ConstantDecl cst, ConstantDecl cst' => eqb cst cst' + | InductiveDecl mib, InductiveDecl mib' => eqb mib mib' + | _, _ => false + end. + +Instance reflect_global_decl : ReflectEq global_decl. +Proof. + refine {| eqb := eqb_global_decl |}. + unfold eqb_global_decl. + intros [] []; finish_reflect. +Defined. diff --git a/template-coq/theories/TermEquality.v b/template-coq/theories/TermEquality.v index 57dab3b9c..07dfd24cb 100644 --- a/template-coq/theories/TermEquality.v +++ b/template-coq/theories/TermEquality.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import CMorphisms. -From MetaCoq.Template Require Import config utils Reflect Ast AstUtils Induction LiftSubst Reflect. +From MetaCoq.Template Require Import config utils Reflect Environment Ast AstUtils Induction LiftSubst Reflect. Require Import ssreflect. From Equations.Prop Require Import DepElim. @@ -78,7 +78,7 @@ Definition global_variance Σ gr napp := | ConstructRef ind k => match lookup_constructor Σ ind k with | Some (mdecl, idecl, cdecl) => - if (cdecl.2 + mdecl.(ind_npars))%nat <=? napp then + if (cdecl.(cstr_arity) + mdecl.(ind_npars))%nat <=? napp then (** Fully applied constructors are always compared at the same supertype, which implies that no universe equality needs to be checked here. *) Some [] @@ -169,14 +169,16 @@ Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) eq_term_upto_univ_napp Σ Re Rle 0 u u' -> eq_term_upto_univ_napp Σ Re Rle napp (tLetIn na t ty u) (tLetIn na' t' ty' u') -| eq_Case indn p p' c c' brs brs' : - eq_term_upto_univ_napp Σ Re Re 0 p p' -> +| eq_Case ind p p' c c' brs brs' : + All2 (eq_term_upto_univ_napp Σ Re Re 0) p.(pparams) p'.(pparams) -> + R_universe_instance Re p.(puinst) p'.(puinst) -> + eq_term_upto_univ_napp Σ Re Re 0 p.(preturn) p'.(preturn) -> eq_term_upto_univ_napp Σ Re Re 0 c c' -> All2 (fun x y => - (fst x = fst y) * - eq_term_upto_univ_napp Σ Re Re 0 (snd x) (snd y) + bcontext x = bcontext y × + eq_term_upto_univ_napp Σ Re Re 0 (bbody x) (bbody y) ) brs brs' -> - eq_term_upto_univ_napp Σ Re Rle napp (tCase indn p c brs) (tCase indn p' c' brs') + eq_term_upto_univ_napp Σ Re Rle napp (tCase ind p c brs) (tCase ind p' c' brs') | eq_Proj p c c' : eq_term_upto_univ_napp Σ Re Re 0 c c' -> @@ -236,7 +238,7 @@ Proof. - apply Forall2_same; eauto. Qed. -Instance eq_binder_annot_equiv {A} : RelationClasses.Equivalence (@eq_binder_annot A). +Instance eq_binder_annot_equiv {A} : RelationClasses.Equivalence (@eq_binder_annot A A). Proof. split. - red. reflexivity. @@ -245,7 +247,7 @@ Proof. congruence. Qed. -Definition eq_binder_annot_refl {A} x : @eq_binder_annot A x x. +Definition eq_binder_annot_refl {A} x : @eq_binder_annot A A x x. Proof. reflexivity. Qed. Hint Resolve @eq_binder_annot_refl : core. @@ -266,10 +268,13 @@ Proof. intros. easy. - now apply R_global_instance_refl. - now apply R_global_instance_refl. - - red in X. eapply All_All2. 1:eassumption. + - destruct X as [Ppars Preturn]. eapply All_All2. 1:eassumption. intros; easy. + - destruct X as [Ppars Preturn]. now apply Preturn. - eapply All_All2. 1: eassumption. simpl. + intros [? ?] x. repeat split ; auto. + - eapply All_All2. 1: eassumption. intros x [? ?]. repeat split ; auto. - eapply All_All2. 1: eassumption. intros x [? ?]. repeat split ; auto. @@ -329,7 +334,7 @@ Proof. end]. - eapply R_global_instance_impl_same_napp; eauto. - eapply R_global_instance_impl_same_napp; eauto. - - induction a; constructor; auto. intuition auto. + - induction a0; constructor; auto. intuition auto. - induction a; constructor; auto. intuition auto. - induction a; constructor; auto. intuition auto. Qed. @@ -351,8 +356,8 @@ Proof. - clear X. induction a; constructor; eauto using eq_term_upto_univ_morphism0. - eapply R_global_instance_impl_same_napp; eauto. - eapply R_global_instance_impl_same_napp; eauto. - - clear X1 X2. induction a; constructor; eauto using eq_term_upto_univ_morphism0. - destruct r. split; eauto using eq_term_upto_univ_morphism0. + - clear X1 X2. induction a0; constructor; eauto using eq_term_upto_univ_morphism0. + destruct r0. split; eauto using eq_term_upto_univ_morphism0. - induction a; constructor; eauto using eq_term_upto_univ_morphism0. destruct r as [[[? ?] ?] ?]. repeat split; eauto using eq_term_upto_univ_morphism0. @@ -421,10 +426,15 @@ Proof. eapply R_global_instance_impl. 5:eauto. all:auto. - inversion 1; subst; constructor. eapply R_global_instance_impl. 5:eauto. all:eauto. - - inversion 1; subst; constructor; eauto. + - destruct X as [IHpars IHret]. + inversion 1; subst; constructor; eauto. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x ? y [? ?]. split; eauto. + eapply R_universe_instance_impl; eauto. + eapply All2_impl'; eauto. + cbn. + eapply All_impl; eauto. + intros x ? y [? ?]. split; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. diff --git a/template-coq/theories/Typing.v b/template-coq/theories/Typing.v index ba8633dfb..d36bf9727 100644 --- a/template-coq/theories/Typing.v +++ b/template-coq/theories/Typing.v @@ -2,8 +2,9 @@ (** This defines relation operators in Type *) From Equations.Type Require Import Relation. From Coq Require Import ssreflect Wellfounded Relation_Operators CRelationClasses. -From MetaCoq.Template Require Import config utils Ast AstUtils LiftSubst UnivSubst - EnvironmentTyping Reflect TermEquality. +From MetaCoq.Template Require Import config utils Ast AstUtils Environment + LiftSubst UnivSubst EnvironmentTyping Reflect ReflectAst TermEquality. +From Equations Require Import Equations. (** * Typing derivations @@ -26,21 +27,7 @@ Fixpoint isArity T := | _ => False end. -Fixpoint smash_context (Γ Γ' : context) : context := - match Γ' with - | {| decl_body := Some b |} :: Γ' => smash_context (subst_context [b] 0 Γ) Γ' - | {| 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. - - now rewrite IHtl subst_context_length. - - rewrite IHtl app_length. simpl. lia. -Qed. - -Module TemplateLookup := Lookup TemplateTerm TemplateEnvironment. +Module TemplateLookup := Lookup TemplateTerm Env. Include TemplateLookup. (** Inductive substitution, to produce a constructors' type *) @@ -64,9 +51,9 @@ Proof. now rewrite app_length /= Nat.add_1_r IHl mapi_rec_app /= rev_app_distr /= Nat.add_0_r. Qed. -Definition type_of_constructor mdecl (cdecl : ident * term * nat) (c : inductive * nat) (u : list Level.t) := +Definition type_of_constructor mdecl cdecl (c : inductive * nat) (u : list Level.t) := let mind := inductive_mind (fst c) in - subst0 (inds mind u mdecl.(ind_bodies)) (subst_instance_constr u (snd (fst cdecl))). + subst0 (inds mind u mdecl.(ind_bodies)) (subst_instance u cdecl.(cstr_type)). (** ** Reduction *) @@ -125,10 +112,135 @@ Lemma fix_context_length mfix : #|fix_context mfix| = #|mfix|. Proof. unfold fix_context. now rewrite List.rev_length mapi_length. Qed. Definition tDummy := tVar "". +Definition dummy_branch : branch term := mk_branch [] tDummy. Definition iota_red npar c args brs := - (mkApps (snd (List.nth c brs (0, tDummy))) (List.skipn npar args)). + subst (List.skipn npar args) 0 (bbody (List.nth c brs dummy_branch)). + +(** For cases typing *) + +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_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_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. + + +(** Compute the type of a case from the predicate [p], actual parameters [pars] and + an inductive declaration. *) + +Fixpoint instantiate_params_subst + (params : context) + (pars s : list term) + (ty : term) : option (list term × term) := + match params with + | [] => match pars with + | [] => Some (s, ty) + | _ :: _ => None (* Too many arguments to substitute *) + end + | d :: params => + match d.(decl_body), ty with + | None, tProd _ _ B => + match pars with + | hd :: tl => instantiate_params_subst params tl (hd :: s) B + | [] => None (* Not enough arguments to substitute *) + end + | Some b, tLetIn _ _ _ b' => instantiate_params_subst params pars (subst0 s b :: s) b' + | _, _ => None (* Not enough products in the type *) + end + end. +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. + induction params in pars, s, ty |- *. + - split. destruct pars => /= // => [= -> ->]. + constructor. + intros. depelim H. reflexivity. + - split. + * destruct a as [na [b|] ?] => /=. + destruct ty => //. + move/IHparams. + intros. now constructor. + destruct ty => //. + destruct pars => //. + move/IHparams. + now constructor. + * intros H; depelim H; simpl. + now apply IHparams. + now apply IHparams. +Qed. + + + (* (* +Variant case_predicate_context ind mdecl idecl params uinst : context -> Type := +| mk_case_predicate_context s ty ictx inds : + instantiate_params_subst_spec (List.rev (subst_instance uinst (ind_params mdecl))) params [] + (subst_instance uinst (ind_type idecl)) s ty -> + let sty := subst s 0 ty in + sty = it_mkProd_or_LetIn ictx (tSort inds) -> + case_predicate_context ind mdecl idecl params uinst (ictx ,, inddecl). + +Variant case_branch_context ind mdecl cdecl p : context -> Type := +| mk_case_branch_context s ty argctx indices : + instantiate_params_subst_spec (List.rev (subst_instance p.(puinst) (ind_params mdecl))) p.(pparams) [] + (subst_instance p.(puinst) (cdecl.1.2)) s ty -> + let sty := subst s 0 ty in + sty = it_mkProd_or_LetIn argctx (mkApps (tInd ind p.(puinst)) (map (lift0 #|argctx|) p.(pparams) ++ indices)) -> + case_branch_context ind mdecl cdecl p argctx. + +Definition case_branches_contexts ind mdecl idecl p : list context -> Type := + All2 (fun cdecl brctx => case_branch_context ind mdecl cdecl p brctx) idecl.(ind_ctors). + +Variant case_branch_type ind mdecl (cdecl : constructor_body) i p pctx : context -> term -> Type := +| mk_case_branch_type s ty argctx indices : + instantiate_params_subst_spec (List.rev (subst_instance p.(puinst) (ind_params mdecl))) p.(pparams) [] + (subst_instance p.(puinst) (cdecl.1.2)) s ty -> + let sty := subst s 0 ty in + sty = it_mkProd_or_LetIn argctx (mkApps (tInd ind p.(puinst)) (map (lift0 #|argctx|) p.(pparams) ++ indices)) -> + let cstr := tConstruct ind i p.(puinst) in + let args := to_extended_list argctx in + let cstrapp := mkApps cstr (map (lift0 #|argctx|) p.(pparams) ++ args) in + let ptm := it_mkLambda_or_LetIn pctx p.(preturn) in + let ty := mkApps (lift0 #|argctx| ptm) (indices ++ [cstrapp]) in + case_branch_type ind mdecl cdecl i p pctx argctx ty. + +Definition case_branches_types ind mdecl idecl p pctx : list (context * term) -> Type := + All2i (fun i cdecl '(brctx, brty) => case_branch_type ind mdecl cdecl i p pctx brctx brty) 0 idecl.(ind_ctors). *) + +(* If [ty] is [Π params . B] *) +(* and [⊢ pars : params] *) +(* then [instantiate_params] is [B{pars}] *) +Definition instantiate_params (params : context) (pars : list term) (ty : term) : option term := + match instantiate_params_subst (List.rev params) pars [] ty with + | Some (s, ty) => Some (subst0 s ty) + | None => None + end. + +Lemma instantiate_params_ params pars ty : + instantiate_params params pars ty + = option_map (fun '(s, ty) => subst0 s ty) + (instantiate_params_subst (List.rev params) pars [] ty). +Proof. + unfold instantiate_params. + repeat (destruct ?; cbnr). +Qed. + +(* [params] and output already instantiated by [u] *) +Definition build_case_predicate_context ind mdecl idecl params u : option context := + index_part <- instantiate_params (subst_instance u (ind_params mdecl)) params + (subst_instance u (ind_type idecl)) ;; + '(Γ, _) <- destArity [] index_part ;; + let inddecl := + {| decl_name := mkBindAnn (nNamed idecl.(ind_name)) idecl.(ind_relevance); + decl_body := None; + decl_type := mkApps (tInd ind u) (map (lift0 #|Γ|) params ++ to_extended_list Γ) |} in + ret (Γ,, inddecl). *) (** *** One step strong beta-zeta-iota-fix-delta reduction @@ -139,7 +251,6 @@ Local Open Scope type_scope. Arguments OnOne2 {A} P%type l l'. (* NOTE: SPROP: we ignore relevance in the reduction for now *) - Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := (** Reductions *) (** Beta *) @@ -155,9 +266,9 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := red1 Σ Γ (tRel i) (lift0 (S i) body) (** Case *) -| red_iota ind pars r c u args p brs : - red1 Σ Γ (tCase (ind, pars, r) p (mkApps (tConstruct ind c u) args) brs) - (iota_red pars c args brs) +| red_iota ci c u args p brs : + red1 Σ Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + (iota_red ci.(ci_npar) c args brs) (** Fix unfolding, with guard *) | red_fix mfix idx args narg fn : @@ -176,22 +287,11 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := unfold_cofix mfix idx = Some (narg, fn) -> red1 Σ Γ (tProj p (mkApps (tCoFix mfix idx) args)) (tProj p (mkApps fn args)) -(* FIXME: We should really be dual to Fix: ask directly - for the constructor, applied, and project the argument: - unfold_cofix mfix idx = Some (narg, mkApps (tConstruct ind c u) args') -> - nth_error args' (pars + narg) = Some arg -> - red1 Σ Γ (tProj (i, pars, narg) (mkApps (tCoFix mfix idx) args)) - (mkApps arg args) - - Otherwise confluence fails, AFAICT. - - (tProj (i, pars, narg) (mkApps fn args)) -*) (** Constant unfolding *) | red_delta c decl body (isdecl : declared_constant Σ c decl) u : decl.(cst_body) = Some body -> - red1 Σ Γ (tConst c u) (subst_instance_constr u body) + red1 Σ Γ (tConst c u) (subst_instance u body) (** Proj *) | red_proj i pars narg args u arg: @@ -206,10 +306,23 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := | letin_red_ty na b t b' r : red1 Σ Γ t r -> red1 Σ Γ (tLetIn na b t b') (tLetIn na b r b') | letin_red_body na b t b' r : red1 Σ (Γ ,, vdef na b t) b' r -> red1 Σ Γ (tLetIn na b t b') (tLetIn na b t r) -| case_red_pred ind p p' c brs : red1 Σ Γ p p' -> red1 Σ Γ (tCase ind p c brs) (tCase ind p' c brs) +| case_red_pred_param ind params params' puinst pcontext preturn c brs : + OnOne2 (red1 Σ Γ) params params' -> + red1 Σ Γ (tCase ind (mk_predicate puinst params pcontext preturn) c brs) + (tCase ind (mk_predicate puinst params' pcontext preturn) c brs) + +| case_red_pred_return ind mdecl idecl (isdecl : declared_inductive Σ ind.(ci_ind) mdecl idecl) + params puinst pcontext preturn preturn' c brs : + red1 Σ (Γ ,,, case_predicate_context ind.(ci_ind) mdecl idecl params puinst pcontext) preturn preturn' -> + red1 Σ Γ (tCase ind (mk_predicate puinst params pcontext preturn) c brs) + (tCase ind (mk_predicate puinst params pcontext preturn') 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 p c brs brs' : - OnOne2 (on_Trel_eq (red1 Σ Γ) snd fst) brs 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') + (case_branches_contexts idecl p) brs brs' -> red1 Σ Γ (tCase ind p c brs) (tCase ind p c brs') | proj_red p c c' : red1 Σ Γ c c' -> red1 Σ Γ (tProj p c) (tProj p c') @@ -253,15 +366,16 @@ Lemma red1_ind_all : (forall (Γ : context) (i : nat) (body : term), option_map decl_body (nth_error Γ i) = Some (Some body) -> P Γ (tRel i) ((lift0 (S i)) body)) -> - (forall (Γ : context) (ind : inductive) (pars c : nat) (r : relevance) (u : Instance.t) (args : list term) - (p : term) (brs : list (nat * term)), - P Γ (tCase (ind, pars,r) p (mkApps (tConstruct ind c u) args) brs) (iota_red pars c args brs)) -> + (forall (Γ : context) (ci : case_info) (c : nat) (u : Instance.t) (args : list term) + (p : predicate term) (brs : list (branch term)), + P Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) (iota_red ci.(ci_npar) c args brs)) -> (forall (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term), unfold_fix mfix idx = Some (narg, fn) -> is_constructor narg args = true -> P Γ (tApp (tFix mfix idx) args) (mkApps fn args)) -> - (forall (Γ : context) (ip : inductive * nat * relevance) (p : term) (mfix : mfixpoint term) (idx : nat) - (args : list term) (narg : nat) (fn : term) (brs : list (nat * term)), + + (forall (Γ : context) (ip : case_info) (p : predicate term) (mfix : mfixpoint term) (idx : nat) + (args : list term) (narg : nat) (fn : term) (brs : list (branch term)), unfold_cofix mfix idx = Some (narg, fn) -> P Γ (tCase ip p (mkApps (tCoFix mfix idx) args) brs) (tCase ip p (mkApps fn args) brs)) -> @@ -271,7 +385,7 @@ Lemma red1_ind_all : (forall (Γ : context) c (decl : constant_body) (body : term), declared_constant Σ c decl -> - forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance_constr u body)) -> + forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance u body)) -> (forall (Γ : context) (i : inductive) (pars narg : nat) (args : list term) (u : Instance.t) (arg : term), @@ -293,14 +407,26 @@ Lemma red1_ind_all : (forall (Γ : context) (na : aname) (b t b' r : term), red1 Σ (Γ,, vdef na b t) b' r -> P (Γ,, vdef na b t) b' r -> P Γ (tLetIn na b t b') (tLetIn na b t r)) -> - (forall (Γ : context) (ind : inductive * nat * relevance) (p p' c : term) (brs : list (nat * term)), - red1 Σ Γ p p' -> P Γ p p' -> P Γ (tCase ind p c brs) (tCase ind p' c brs)) -> - - (forall (Γ : context) (ind : inductive * nat * relevance) (p c c' : term) (brs : list (nat * term)), + (forall (Γ : context) (ind : case_info) params params' puinst pcontext preturn c brs, + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) params params' -> + P Γ (tCase ind (mk_predicate puinst params pcontext preturn) c brs) + (tCase ind (mk_predicate puinst params' pcontext preturn) c brs)) -> + + (forall (Γ : context) (ci : case_info) + idecl mdecl (isdecl : declared_inductive Σ ci.(ci_ind) mdecl idecl) + params puinst pcontext preturn preturn' c brs, + red1 Σ (Γ ,,, case_predicate_context ci.(ci_ind) mdecl idecl params puinst pcontext) preturn preturn' -> + P (Γ ,,, case_predicate_context ci.(ci_ind) mdecl idecl params puinst pcontext) preturn preturn' -> + P Γ (tCase ci (mk_predicate puinst params pcontext preturn) 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 : inductive * nat * relevance) (p c : term) (brs brs' : list (nat * term)), - OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) snd fst) brs 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') + (case_branches_contexts idecl p) brs brs' -> P Γ (tCase ind p c brs) (tCase ind p c brs')) -> (forall (Γ : context) (p : projection) (c c' : term), red1 Σ Γ c c' -> P Γ c c' -> P Γ (tProj p c) (tProj p c')) -> @@ -348,53 +474,59 @@ Lemma red1_ind_all : forall (Γ : context) (t t0 : term), red1 Σ Γ t t0 -> P Γ t t0. Proof. - intros. rename X29 into Xlast. revert Γ t t0 Xlast. + intros. rename X30 into Xlast. revert Γ t t0 Xlast. fix aux 4. intros Γ t T. move aux at top. - destruct 1; match goal with - | |- P _ (tFix _ _) (tFix _ _) => idtac - | |- P _ (tCoFix _ _) (tCoFix _ _) => idtac - | |- P _ (tApp (tFix _ _) _) _ => idtac - | |- P _ (tCase _ _ (mkApps (tCoFix _ _) _) _) _ => idtac - | |- P _ (tProj _ (mkApps (tCoFix _ _) _)) _ => idtac - | H : _ |- _ => eapply H; eauto - end. - - eapply X3; eauto. - - eapply X4; eauto. - - eapply X5; eauto. - - - revert brs brs' o. + destruct 1; + try solve [ + match goal with + | H : _ |- _ => eapply H; eauto; fail + end]. + + - apply X13. + revert params params' o. fix auxl 3. - intros l l' Hl. destruct Hl. - + constructor. intuition eauto. + intros params params' []. + + constructor. split; auto. + constructor. auto. - - - revert M2 N2 o. + + - eapply X16; eauto. + revert brs brs' o. + generalize (case_branches_contexts idecl p). + fix auxl 4. + intros i l l' Hl. destruct Hl. + + constructor; intros. + intuition auto. auto. + + constructor. eapply auxl. apply Hl. + + - apply X19. + revert M2 N2 o. fix auxl 3. intros l l' Hl. destruct Hl. - constructor. split; auto. - constructor. auto. + + constructor. split; auto. + + constructor. auto. - - revert l l' o. + - apply X22. + revert l l' o. fix auxl 3. intros l l' Hl. destruct Hl. constructor. split; auto. constructor. auto. - - eapply X25. + - apply X26. revert mfix0 mfix1 o; fix auxl 3; intros l l' Hl; destruct Hl; constructor; try split; auto; intuition. - - eapply X26. + - apply X27. revert o. generalize (fix_context mfix0). intros c H28. revert mfix0 mfix1 H28; fix auxl 3; intros l l' Hl; destruct Hl; constructor; try split; auto; intuition. - - eapply X27. + - eapply X28. revert mfix0 mfix1 o; fix auxl 3; intros l l' Hl; destruct Hl; constructor; try split; auto; intuition. - - eapply X28. + - eapply X29. revert o. generalize (fix_context mfix0). intros c H28. revert mfix0 mfix1 H28; fix auxl 3; intros l l' Hl; destruct Hl; constructor; try split; auto; intuition. @@ -425,10 +557,6 @@ Definition eq_term_nocast `{checker_flags} (Σ : global_env) (φ : ConstraintSet Definition leq_term_nocast `{checker_flags} (Σ : global_env) (φ : ConstraintSet.t) (t u : term) := leq_term Σ φ (strip_casts t) (strip_casts u). -(** ** Utilities for typing *) - -(** Decompose an arity into a context and a sort *) - Reserved Notation " Σ ;;; Γ |- t : T " (at level 50, Γ, t, T at next level). Reserved Notation " Σ ;;; Γ |- t <= u " (at level 50, Γ, t, u at next level). Reserved Notation " Σ ;;; Γ |- t = u " (at level 50, Γ, t, u at next level). @@ -449,7 +577,7 @@ where " Σ ;;; Γ |- t <= u " := (cumul Σ Γ t u) : type_scope. Reduction to terms in the eq_term relation *) - Inductive conv `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> term -> Type := +Inductive conv `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> term -> Type := | conv_refl t u : eq_term Σ (global_ext_constraints Σ) t u -> Σ ;;; Γ |- t = u | conv_red_l t u v : red1 Σ.1 Γ t v -> Σ ;;; Γ |- v = u -> Σ ;;; Γ |- t = u | conv_red_r t u v : Σ ;;; Γ |- t = v -> red1 Σ.1 Γ u v -> Σ ;;; Γ |- t = u @@ -481,9 +609,17 @@ Definition eq_context `{checker_flags} Σ φ (Γ Δ : context) := (** ** Typing relation *) -Module TemplateEnvTyping := EnvTyping TemplateTerm TemplateEnvironment. +Module TemplateEnvTyping := EnvTyping TemplateTerm Env. Include TemplateEnvTyping. +Module TemplateConversionPar <: ConversionParSig TemplateTerm Env TemplateEnvTyping. + Definition conv := @conv. + Definition cumul := @cumul. +End TemplateConversionPar. + +Module TemplateConversion := Conversion TemplateTerm Env TemplateEnvTyping TemplateConversionPar. +Include TemplateConversion. + Definition extends (Σ Σ' : global_env) := { Σ'' & Σ' = Σ'' ++ Σ }. Class GuardChecker := @@ -512,7 +648,7 @@ Class GuardChecker := fix_guard_subst_instance {cf:checker_flags} Σ Γ mfix u univs : consistent_instance_ext (Σ.1, univs) Σ.2 u -> fix_guard Σ Γ mfix -> - fix_guard (Σ.1, univs) (subst_instance_context u Γ) (map (map_def (subst_instance_constr u) (subst_instance_constr u)) + fix_guard (Σ.1, univs) (subst_instance u Γ) (map (map_def (subst_instance u) (subst_instance u)) mfix) ; fix_guard_extends Σ Γ mfix (Σ' : global_env_ext) : @@ -540,7 +676,7 @@ Class GuardChecker := cofix_guard_subst_instance {cf:checker_flags} Σ Γ mfix u univs : consistent_instance_ext (Σ.1, univs) Σ.2 u -> cofix_guard Σ Γ mfix -> - cofix_guard (Σ.1, univs) (subst_instance_context u Γ) (map (map_def (subst_instance_constr u) (subst_instance_constr u)) + cofix_guard (Σ.1, univs) (subst_instance u Γ) (map (map_def (subst_instance u) (subst_instance u)) mfix) ; cofix_guard_extends Σ Γ mfix (Σ' : global_env_ext) : @@ -552,52 +688,23 @@ Class GuardChecker := Axiom guard_checking : GuardChecker. Existing Instance guard_checking. -(** Compute the type of a case from the predicate [p], actual parameters [pars] and - an inductive declaration. *) - -Fixpoint instantiate_params_subst params pars s ty := - match params with - | [] => match pars with - | [] => Some (s, ty) - | _ :: _ => None (* Too many arguments to substitute *) - end - | d :: params => - match d.(decl_body), ty with - | None, tProd _ _ B => - match pars with - | hd :: tl => instantiate_params_subst params tl (hd :: s) B - | [] => None (* Not enough arguments to substitute *) - end - | Some b, tLetIn _ _ _ b' => instantiate_params_subst params pars (subst0 s b :: s) b' - | _, _ => None (* Not enough products in the type *) - end - end. - -(* If [ty] is [Π params . B] *) -(* and [⊢ pars : params] *) -(* then [instantiate_params] is [B{pars}] *) - -Definition instantiate_params (params : context) (pars : list term) (ty : term) : option term := - match instantiate_params_subst (List.rev params) pars [] ty with - | Some (s, ty) => Some (subst0 s ty) +(* +Definition build_branch_context ind mdecl (cty: term) p : option context := + let inds := inds ind.(inductive_mind) p.(puinst) mdecl.(ind_bodies) in + let ty := subst0 inds (subst_instance p.(puinst) cty) in + match instantiate_params (subst_instance p.(puinst) mdecl.(ind_params)) p.(pparams) ty with + | Some ty => + let '(sign, ccl) := decompose_prod_assum [] ty in + Some sign | None => None end. -Lemma instantiate_params_ params pars ty : - instantiate_params params pars ty - = option_map (fun '(s, ty) => subst0 s ty) - (instantiate_params_subst (List.rev params) pars [] ty). -Proof. - unfold instantiate_params. - repeat (destruct ?; cbnr). -Qed. - (* [params], [p] and output are already instanciated by [u] *) -Definition build_branches_type ind mdecl idecl params u p : list (option (nat × term)) := +Definition build_branches_type ind mdecl idecl params u p : list (option (nat * context * term)) := let inds := inds ind.(inductive_mind) u mdecl.(ind_bodies) in let branch_type i '(id, t, ar) := - let ty := subst0 inds (subst_instance_constr u t) in - match instantiate_params (subst_instance_context u mdecl.(ind_params)) params ty with + let ty := subst0 inds (subst_instance u t) in + match instantiate_params (subst_instance u mdecl.(ind_params)) params ty with | Some ty => let '(sign, ccl) := decompose_prod_assum [] ty in let nargs := List.length sign in @@ -605,7 +712,7 @@ Definition build_branches_type ind mdecl idecl params u p : list (option (nat × let '(paramrels, args) := chop mdecl.(ind_npars) allargs in let cstr := tConstruct ind i u in let args := (args ++ [mkApps cstr (paramrels ++ to_extended_list sign)]) in - Some (ar, it_mkProd_or_LetIn sign (mkApps (lift0 nargs p) args)) + Some (ar, sign, mkApps (lift0 nargs p) args) | None => None end in mapi branch_type idecl.(ind_ctors). @@ -614,7 +721,7 @@ Lemma build_branches_type_ ind mdecl idecl params u p : build_branches_type ind mdecl idecl params u p = let inds := inds ind.(inductive_mind) u mdecl.(ind_bodies) in let branch_type i '(id, t, ar) := - let ty := subst0 inds (subst_instance_constr u t) in + let ty := subst0 inds (subst_instance u t) in option_map (fun ty => let '(sign, ccl) := decompose_prod_assum [] ty in let nargs := List.length sign in @@ -622,26 +729,15 @@ Lemma build_branches_type_ ind mdecl idecl params u p : let '(paramrels, args) := chop mdecl.(ind_npars) allargs in let cstr := tConstruct ind i u in let args := (args ++ [mkApps cstr (paramrels ++ to_extended_list sign)]) in - (ar, it_mkProd_or_LetIn sign (mkApps (lift0 nargs p) args))) - (instantiate_params (subst_instance_context u mdecl.(ind_params)) + (ar, sign, (mkApps (lift0 nargs p) args))) + (instantiate_params (subst_instance u mdecl.(ind_params)) params ty) in mapi branch_type idecl.(ind_ctors). Proof. apply mapi_ext. intros ? [[? ?] ?]; cbnr. repeat (destruct ?; cbnr). Qed. - -(* [params] and output already instanciated by [u] *) -Definition build_case_predicate_type ind mdecl idecl params u ps : option term := - X <- instantiate_params (subst_instance_context u (ind_params mdecl)) params - (subst_instance_constr u (ind_type idecl)) ;; - X <- destArity [] X ;; - let inddecl := - {| decl_name := mkBindAnn (nNamed idecl.(ind_name)) idecl.(ind_relevance); - decl_body := None; - decl_type := mkApps (tInd ind u) (map (lift0 #|X.1|) params ++ to_extended_list X.1) |} in - ret (it_mkProd_or_LetIn (X.1 ,, inddecl) (tSort ps)). - +*) Definition destInd (t : term) := match t with | tInd ind u => Some (ind, u) @@ -768,40 +864,44 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> wf_local Σ Γ -> forall decl (isdecl : declared_constant Σ.1 cst decl), consistent_instance_ext Σ decl.(cst_universes) u -> - Σ ;;; Γ |- (tConst cst u) : subst_instance_constr u decl.(cst_type) + Σ ;;; Γ |- (tConst cst u) : subst_instance u decl.(cst_type) | type_Ind ind u : wf_local Σ Γ -> - forall mdecl idecl (isdecl : declared_inductive Σ.1 mdecl ind idecl), + forall mdecl idecl (isdecl : declared_inductive Σ.1 ind mdecl idecl), consistent_instance_ext Σ mdecl.(ind_universes) u -> - Σ ;;; Γ |- (tInd ind u) : subst_instance_constr u idecl.(ind_type) + Σ ;;; Γ |- (tInd ind u) : subst_instance u idecl.(ind_type) | type_Construct ind i u : wf_local Σ Γ -> - forall mdecl idecl cdecl (isdecl : declared_constructor Σ.1 mdecl idecl (ind, i) cdecl), + forall mdecl idecl cdecl (isdecl : declared_constructor Σ.1 (ind, i) mdecl idecl cdecl), consistent_instance_ext Σ mdecl.(ind_universes) u -> Σ ;;; Γ |- (tConstruct ind i u) : type_of_constructor mdecl cdecl (ind, i) u -| type_Case (indnparrel : inductive * nat * relevance) u p c brs args : - let ind := indnparrel.1.1 in - let npar := indnparrel.1.2 in - forall mdecl idecl (isdecl : declared_inductive Σ.1 mdecl ind idecl), - mdecl.(ind_npars) = npar -> - let params := List.firstn npar args in - forall ps pty, build_case_predicate_type ind mdecl idecl params u ps = Some pty -> - Σ ;;; Γ |- p : pty -> +| type_Case (ci : case_info) p c brs indices ps : + forall mdecl idecl (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl), + mdecl.(ind_npars) = ci.(ci_npar) -> + #|idecl.(ind_indices)| = #|p.(pcontext)| -> + context_assumptions idecl.(ind_indices) = #|p.(pparams)| -> + let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p.(pparams) p.(puinst) p.(pcontext) in + Σ ;;; Γ ,,, predctx |- p.(preturn) : tSort ps -> is_allowed_elimination Σ ps idecl.(ind_kelim) -> + Σ ;;; Γ |- c : mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices) -> isCoFinite mdecl.(ind_finite) = false -> - Σ ;;; Γ |- c : mkApps (tInd ind u) args -> - forall btys, map_option_out (build_branches_type ind mdecl idecl params u p) = Some btys -> - All2 (fun br bty => (br.1 = bty.1) * (Σ ;;; Γ |- br.2 : bty.2) * (∑ s, Σ ;;; Γ |- bty.2 : tSort s)) brs btys -> - Σ ;;; Γ |- tCase indnparrel p c brs : mkApps p (skipn npar args ++ [c]) + let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in + All2 (fun br brctxty => + (Forall2 (fun na decl => eq_binder_annot na decl.(decl_name)) br.(bcontext) brctxty.1) * + (Σ ;;; Γ ,,, brctxty.1 |- br.(bbody) : brctxty.2) * + (Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps)) + brs + (case_branches_types ci.(ci_ind) idecl p ptm) -> + Σ ;;; Γ |- tCase ci p c brs : mkApps ptm (indices ++ [c]) | type_Proj p c u : - forall mdecl idecl pdecl (isdecl : declared_projection Σ.1 mdecl idecl p pdecl) args, + forall mdecl idecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl pdecl) args, Σ ;;; Γ |- c : mkApps (tInd (fst (fst p)) u) args -> #|args| = ind_npars mdecl -> - Σ ;;; Γ |- tProj p c : subst0 (c :: List.rev args) (subst_instance_constr u pdecl.2) + Σ ;;; Γ |- tProj p c : subst0 (c :: List.rev args) (subst_instance u pdecl.2) | type_Fix mfix n decl : fix_guard Σ Γ mfix -> @@ -850,34 +950,24 @@ Definition unlift_opt_pred (P : global_env_ext -> context -> option term -> term fun Σ Γ t T => P Σ Γ (Some t) T. -Module TemplateTyping <: Typing TemplateTerm TemplateEnvironment TemplateEnvTyping. +Module TemplateTyping <: Typing TemplateTerm Env TemplateEnvTyping + TemplateConversionPar TemplateConversion. Definition typing := @typing. Definition wf_universe := @wf_universe. Definition conv := @conv. Definition cumul := @cumul. - Definition smash_context := smash_context. - Definition expand_lets := expand_lets. - Definition expand_lets_ctx := expand_lets_ctx. - Definition lift := lift. - Definition subst := subst. - Definition lift_context := lift_context. - Definition subst_context := subst_context. - Definition extended_subst := extended_subst. - Definition subst_instance_constr := subst_instance_constr. - Definition subst_instance_context := subst_instance_context. - Definition subst_telescope := subst_telescope. Definition inds := inds. - Definition noccur_between := noccur_between. - Definition closedn := closedn. Definition destArity := destArity []. End TemplateTyping. Module TemplateDeclarationTyping := DeclarationTyping TemplateTerm - TemplateEnvironment + Env TemplateEnvTyping + TemplateConversionPar + TemplateConversion TemplateTyping TemplateLookup. Include TemplateDeclarationTyping. @@ -908,6 +998,7 @@ Proof. | H : All2 _ _ _ |- _ => idtac | H : All_local_env _ _ |- _ => idtac | H : All _ _ |- _ => idtac + | H : Alli _ _ _ |- _ => idtac | H : typing_spine _ _ _ _ _ |- _ => idtac | H : _ + _ |- _ => idtac | H1 : size, H2 : size, H3 : size |- _ => exact (S (Nat.max H1 (Nat.max H2 H3))) @@ -922,7 +1013,7 @@ Proof. - exact (S (S (wf_local_size _ typing_size _ a))). - exact (S (S (wf_local_size _ typing_size _ a))). - exact (S (Nat.max d1 (Nat.max d2 - (all2_size _ (fun x y p => Nat.max (typing_size Σ Γ (snd x) (snd y) (snd (fst p))) (typing_size _ _ _ _ (snd p).π2)) a)))). + (all2_size _ (fun x y p => Nat.max (typing_size _ _ _ _ p.1.2) (typing_size _ _ _ _ p.2)) a)))). - exact (S (Nat.max (Nat.max (wf_local_size _ typing_size _ a) (all_size _ (fun x p => typing_size Σ _ _ _ p.π2) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). - exact (S (Nat.max (Nat.max (wf_local_size _ typing_size _ a) (all_size _ (fun x p => typing_size Σ _ _ _ p.π2) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). Defined. @@ -948,22 +1039,42 @@ Arguments lexprod [A B]. Definition wf `{checker_flags} := Forall_decls_typing typing. Definition wf_ext `{checker_flags} := on_global_env_ext (lift_typing typing). -Definition env_prop `{checker_flags} (P : forall Σ Γ t T, Type) := - forall Σ (wfΣ : wf Σ.1) Γ (wfΓ : wf_local Σ Γ) t T, Σ ;;; Γ |- t : T -> - Forall_decls_typing P Σ.1 * P Σ Γ t T. - -Lemma env_prop_typing `{checker_flags} P : env_prop P -> - forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t T : term), - Σ ;;; Γ |- t : T -> P Σ Γ t T. -Proof. intros. now apply X. Qed. +Lemma typing_wf_local `{checker_flags} {Σ} {Γ t T} : + Σ ;;; Γ |- t : T -> wf_local Σ Γ. +Proof. + induction 1; eauto. +Defined. +Hint Resolve typing_wf_local : wf. Lemma type_Prop `{checker_flags} Σ : Σ ;;; [] |- tSort Universe.lProp : tSort Universe.type1. - change ( Σ ;;; [] |- tSort (Universe.of_levels (inl PropLevel.lProp)) : tSort Universe.type1); + change ( Σ ;;; [] |- tSort (Universe.lProp) : tSort Universe.type1); constructor;auto. constructor. constructor. Defined. -Lemma env_prop_sigma `{checker_flags} P : env_prop P -> +Lemma type_Prop_wf `{checker_flags} Σ Γ : + wf_local Σ Γ -> + Σ ;;; Γ |- tSort Universe.lProp : tSort Universe.type1. +Proof. + constructor;auto. constructor. +Defined. + +Definition env_prop `{checker_flags} (P : forall Σ Γ t T, Type) (PΓ : forall Σ Γ (wfΓ : wf_local Σ Γ), Type):= + forall Σ (wfΣ : wf Σ.1) Γ (wfΓ : wf_local Σ Γ) t T (ty : Σ ;;; Γ |- t : T), + Forall_decls_typing P Σ.1 * + (PΓ Σ Γ (typing_wf_local ty) * + P Σ Γ t T). + +Lemma env_prop_typing `{checker_flags} {P PΓ} : env_prop P PΓ -> + forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t T : term), + Σ ;;; Γ |- t : T -> P Σ Γ t T. +Proof. intros. now apply X. Qed. + +Lemma env_prop_wf_local `{checker_flags} {P PΓ} : env_prop P PΓ -> + forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), PΓ Σ Γ wfΓ. +Proof. intros. red in X. now apply (X _ wfΣ _ wfΓ _ _ (type_Prop_wf Σ Γ wfΓ)). Qed. + +Lemma env_prop_sigma `{checker_flags} {P PΓ} : env_prop P PΓ -> forall Σ (wfΣ : wf Σ), Forall_decls_typing P Σ. Proof. intros. eapply (X (empty_ext Σ)). @@ -978,13 +1089,6 @@ Proof. Defined. Hint Resolve wf_local_app_l : wf. -Lemma typing_wf_local `{checker_flags} {Σ} {Γ t T} : - Σ ;;; Γ |- t : T -> wf_local Σ Γ. -Proof. - induction 1; eauto using wf_local_app_l. -Defined. -Hint Resolve typing_wf_local : wf. - Lemma typing_wf_local_size `{checker_flags} {Σ} {Γ t T} (d :Σ ;;; Γ |- t : T) : wf_local_size Σ (@typing_size _) _ (typing_wf_local d) < typing_size d. @@ -992,7 +1096,6 @@ Proof. induction d; simpl; change (fun (x : global_env_ext) (x0 : context) (x1 x2 : term) (x3 : x;;; x0 |- x1 : x2) => typing_size x3) with (@typing_size H); try lia. - - destruct indnparrel as ((ind' & npar') & ?); cbn in *; subst ind npar. lia. Qed. Lemma wf_local_inv `{checker_flags} {Σ Γ'} (w : wf_local Σ Γ') : @@ -1053,13 +1156,18 @@ Inductive Forall_typing_spine `{checker_flags} Σ Γ (P : term -> term -> Type) Lemma typing_ind_env `{cf : checker_flags} : forall (P : global_env_ext -> context -> term -> term -> Type) - (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T), + (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T) + (PΓ : forall Σ Γ, wf_local Σ Γ -> Type), + + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), + All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ wfΓ) -> + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl, nth_error Γ n = Some decl -> - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> wf_universe Σ u -> P Σ Γ (tSort u) (tSort (Universe.super u))) -> @@ -1068,7 +1176,7 @@ Lemma typing_ind_env `{cf : checker_flags} : Σ ;;; Γ |- t : tSort s -> P Σ Γ t (tSort s) -> Σ ;;; Γ |- c : t -> P Σ Γ c t -> P Σ Γ (tCast c k t) t) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 s2 : Universe.t), - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> Σ ;;; Γ |- t : tSort s1 -> P Σ Γ t (tSort s1) -> Σ ;;; Γ,, vass n t |- b : tSort s2 -> @@ -1076,14 +1184,14 @@ Lemma typing_ind_env `{cf : checker_flags} : (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 : Universe.t) (bty : term), - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> Σ ;;; Γ |- t : tSort s1 -> P Σ Γ t (tSort s1) -> Σ ;;; Γ,, vass n t |- b : bty -> P Σ (Γ,, vass n t) b bty -> P Σ Γ (tLambda n t b) (tProd n t bty)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (b b_ty b' : term) (s1 : Universe.t) (b'_ty : term), - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> Σ ;;; Γ |- b_ty : tSort s1 -> P Σ Γ b_ty (tSort s1) -> Σ ;;; Γ |- b : b_ty -> @@ -1100,59 +1208,66 @@ Lemma typing_ind_env `{cf : checker_flags} : (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) cst u (decl : constant_body), Forall_decls_typing P Σ.1 -> - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> declared_constant Σ.1 cst decl -> consistent_instance_ext Σ decl.(cst_universes) u -> - P Σ Γ (tConst cst u) (subst_instance_constr u (cst_type decl))) -> + P Σ Γ (tConst cst u) (subst_instance u (cst_type decl))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u - mdecl idecl (isdecl : declared_inductive Σ.1 mdecl ind idecl), + mdecl idecl (isdecl : declared_inductive Σ.1 ind mdecl idecl), Forall_decls_typing P Σ.1 -> - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> consistent_instance_ext Σ mdecl.(ind_universes) u -> - P Σ Γ (tInd ind u) (subst_instance_constr u (ind_type idecl))) -> + P Σ Γ (tInd ind u) (subst_instance u (ind_type idecl))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) (i : nat) u - mdecl idecl cdecl (isdecl : declared_constructor Σ.1 mdecl idecl (ind, i) cdecl), + mdecl idecl cdecl (isdecl : declared_constructor Σ.1 (ind, i) mdecl idecl cdecl), Forall_decls_typing P Σ.1 -> - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> consistent_instance_ext Σ mdecl.(ind_universes) u -> P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u r (npar : nat) - (p c : term) (brs : list (nat * term)) - (args : list term) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) - (isdecl : declared_inductive (fst Σ) mdecl ind idecl), - Forall_decls_typing P Σ.1 -> All_local_env_over typing Pdecl Σ Γ wfΓ -> - ind_npars mdecl = npar -> - let params := firstn npar args in - forall ps pty, build_case_predicate_type ind mdecl idecl params u ps = Some pty -> - Σ ;;; Γ |- p : pty -> - P Σ Γ p pty -> - is_allowed_elimination (global_ext_constraints Σ) ps idecl.(ind_kelim) -> - Σ ;;; Γ |- c : mkApps (tInd ind u) args -> - P Σ Γ c (mkApps (tInd ind u) args) -> + (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 -> + PΓ Σ Γ wfΓ -> + mdecl.(ind_npars) = ci.(ci_npar) -> + #|idecl.(ind_indices)| = #|p.(pcontext)| -> + context_assumptions idecl.(ind_indices) = #|p.(pparams)| -> + let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p.(pparams) p.(puinst) p.(pcontext) in + forall pret : Σ ;;; Γ ,,, predctx |- p.(preturn) : tSort ps, + P Σ (Γ ,,, predctx) p.(preturn) (tSort ps) -> + PΓ Σ (Γ ,,, predctx) (typing_wf_local pret) -> + is_allowed_elimination Σ ps idecl.(ind_kelim) -> + Σ ;;; Γ |- c : mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices) -> + P Σ Γ c (mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices)) -> isCoFinite mdecl.(ind_finite) = false -> - forall btys, map_option_out (build_branches_type ind mdecl idecl params u p) = Some btys -> - All2 (fun br bty => (br.1 = bty.1) * - (Σ ;;; Γ |- br.2 : bty.2) * P Σ Γ br.2 bty.2 * - ∑ s, (Σ ;;; Γ |- bty.2 : tSort s) * P Σ Γ bty.2 (tSort s)) - brs btys -> - P Σ Γ (tCase (ind, npar, r) p c brs) (mkApps p (skipn npar args ++ [c]))) -> + let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in + All2 (fun br brctxty => + Forall2 (fun na decl => eq_binder_annot na decl.(decl_name)) br.(bcontext) brctxty.1 * + (Σ ;;; Γ ,,, brctxty.1 |- br.(bbody) : brctxty.2) * + P Σ (Γ ,,, brctxty.1) br.(bbody) brctxty.2 * + (Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps) * + P Σ (Γ ,,, brctxty.1) brctxty.2 (tSort ps)) + brs + (case_branches_types ci.(ci_ind) idecl p ptm) -> + 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 pdecl (isdecl : declared_projection Σ.1 mdecl idecl p pdecl) args, - Forall_decls_typing P Σ.1 -> All_local_env_over typing Pdecl Σ Γ wfΓ -> + mdecl idecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl pdecl) args, + Forall_decls_typing P Σ.1 -> + PΓ Σ Γ wfΓ -> Σ ;;; Γ |- c : mkApps (tInd (fst (fst p)) u) args -> P Σ Γ c (mkApps (tInd (fst (fst p)) u) args) -> #|args| = ind_npars mdecl -> - let ty := snd pdecl in P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (subst_instance_constr u ty))) -> + let ty := snd pdecl in P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (subst_instance u ty))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (mfix : list (def term)) (n : nat) decl, let types := fix_context mfix in fix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> All (fun d => {s & (Σ ;;; Γ |- d.(dtype) : tSort s)%type * P Σ Γ d.(dtype) (tSort s)})%type mfix -> All (fun d => (Σ ;;; Γ ,,, types |- d.(dbody) : lift0 #|types| d.(dtype))%type * P Σ (Γ ,,, types) d.(dbody) (lift0 #|types| d.(dtype)))%type mfix -> @@ -1163,7 +1278,7 @@ Lemma typing_ind_env `{cf : checker_flags} : let types := fix_context mfix in cofix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> All (fun d => {s & (Σ ;;; Γ |- d.(dtype) : tSort s)%type * P Σ Γ d.(dtype) (tSort s)})%type mfix -> All (fun d => (Σ ;;; Γ ,,, types |- d.(dbody) : lift0 #|types| d.(dtype))%type * P Σ (Γ ,,, types) d.(dbody) (lift0 #|types| d.(dtype)))%type mfix -> @@ -1171,7 +1286,7 @@ Lemma typing_ind_env `{cf : checker_flags} : P Σ Γ (tCoFix mfix n) decl.(dtype)) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, - All_local_env_over typing Pdecl Σ Γ wfΓ -> + PΓ Σ Γ wfΓ -> Σ ;;; Γ |- t : A -> P Σ Γ t A -> Σ ;;; Γ |- B : tSort s -> @@ -1179,21 +1294,23 @@ Lemma typing_ind_env `{cf : checker_flags} : Σ ;;; Γ |- A <= B -> P Σ Γ t B) -> - env_prop P. + env_prop P PΓ. Proof. - intros P Pdecl; unfold env_prop. + intros P Pdecl PΓ; unfold env_prop. + intros XΓ. intros X X0 Xcast X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ wfΓ t T H. (* NOTE (Danil): while porting to 8.9, I had to split original "pose" into 2 pieces, otherwise it takes forever to execure the "pose", for some reason *) - pose (@Fix_F ({ Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & { wfΓ : wf_local Σ Γ & - { t : term & { T : term & Σ ;;; Γ |- t : T }}}}}})) as p0. + pose (@Fix_F ({ Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & + { t : term & { T : term & Σ ;;; Γ |- t : T }}}}})) as p0. specialize (p0 (lexprod (precompose lt (fun Σ => globenv_size (fst Σ))) - (fun Σ => precompose lt (fun x => typing_size (projT2 (projT2 (projT2 (projT2 (projT2 x))))))))) as p. - set(foo := existT _ Σ (existT _ wfΣ (existT _ Γ (existT _ wfΓ (existT _ t (existT _ _ H))))) : { Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & { wfΓ & { t : term & { T : term & Σ ;;; Γ |- t : T }}}}}}). + (fun Σ => precompose lt (fun x => typing_size (projT2 (projT2 (projT2 (projT2 x)))))))) as p. + set(foo := existT _ Σ (existT _ wfΣ (existT _ Γ (existT _ t (existT _ _ H)))) : { Σ : _ & { wfΣ : wf Σ.1 & { Γ : context & { t : term & { T : term & Σ ;;; Γ |- t : T }}}}}). change Σ with (projT1 foo). change Γ with (projT1 (projT2 (projT2 foo))). - change t with (projT1 (projT2 (projT2 (projT2 (projT2 foo))))). - change T with (projT1 (projT2 (projT2 (projT2 (projT2 (projT2 foo)))))). + change t with (projT1 (projT2 (projT2 (projT2 foo)))). + change T with (projT1 (projT2 (projT2 (projT2 (projT2 foo))))). + change H with (projT2 (projT2 (projT2 (projT2 (projT2 foo))))). revert foo. match goal with |- let foo := _ in @?P foo => specialize (p (fun x => P x)) @@ -1201,7 +1318,7 @@ Proof. forward p; [ | apply p; apply wf_lexprod; intros; apply wf_precompose; apply lt_wf]. clear p. clear Σ wfΣ Γ wfΓ t T H. - intros (Σ & wfΣ & Γ & wfΓ & t & t0 & H). simpl. + intros (Σ & wfΣ & Γ & t & t0 & H). simpl. intros IH. simpl in IH. split. destruct Σ as [Σ φ]. destruct Σ. @@ -1210,33 +1327,32 @@ Proof. inv wfΣ. rename X14 into Xg. constructor; auto. unfold Forall_decls_typing in IH. - - simple refine (let IH' := IH ((Σ, udecl); (X13; []; _; (tSort Universe.lProp ); _; _)) in _). - constructor. shelve. apply type_Prop. - cbn in IH'; forward IH'. constructor 1; cbn. lia. + - simple refine (let IH' := IH ((Σ, udecl); (X13; []; (tSort Universe.lProp); _; _)) in _). + shelve. simpl. apply type_Prop. + forward IH'. constructor 1; cbn. lia. apply IH'; auto. - simpl. simpl in *. destruct d. + destruct c; simpl in *. - destruct cst_body; simpl in *. + destruct cst_body0; simpl in *. simpl. intros. red in Xg. simpl in Xg. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ localenv_nil (existT _ _ (existT _ _ Xg))))))). + specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Xg)))))). simpl in IH. forward IH. constructor 1. simpl; lia. apply IH. red. simpl. red in Xg; simpl in Xg. destruct Xg as [s Hs]. red. simpl. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ localenv_nil (existT _ _ (existT _ _ Hs))))))). + specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hs)))))). simpl in IH. forward IH. constructor 1. simpl; lia. exists s. eapply IH. + red in Xg. destruct Xg as [onI onP onnp]; constructor; eauto. * eapply Alli_impl; eauto. clear onI onP onnp; intros n x Xg. - refine {| ind_indices := Xg.(ind_indices); - ind_arity_eq := Xg.(ind_arity_eq); - ind_cshapes := Xg.(ind_cshapes) |}. + refine {| ind_arity_eq := Xg.(ind_arity_eq); + ind_cunivs := Xg.(ind_cunivs) |}. -- apply onArity in Xg. destruct Xg as [s Hs]. exists s; auto. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ localenv_nil (existT _ _ (existT _ _ Hs))))))). + specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hs)))))). simpl in IH. simpl. apply IH; constructor 1; simpl; lia. -- pose proof Xg.(onConstructors) as Xg'. eapply All2_impl; eauto. intros. @@ -1244,23 +1360,21 @@ Proof. unshelve econstructor; eauto. destruct onctyp as [s Hs]. pose proof (typing_wf_local (Σ:= (Σ, udecl)) Hs). simpl in Hs. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ X14 (existT _ _ (existT _ _ Hs))))))). + specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hs)))))). simpl in IH. red. simpl. exists s. simpl. apply IH; constructor 1; simpl; auto with arith. eapply sorts_local_ctx_impl; eauto. simpl. intros. red in X14. destruct T. - pose proof (typing_wf_local X14). - specialize (IH ((Σ, udecl); (X13; _; X17; _; _; X14))). + specialize (IH ((Σ, udecl); (X13; _; _; _; X14))). apply IH. simpl. constructor 1. simpl. auto with arith. destruct X14 as [u Hu]. exists u. - pose proof (typing_wf_local Hu). - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ X14 (existT _ _ (existT _ _ Hu))))))). + specialize (IH ((Σ, udecl); (X13; _; _; _; Hu))). apply IH. simpl. constructor 1. simpl. auto with arith. clear -X13 IH oncind. revert oncind. - generalize (List.rev (lift_context #|cshape_args y| 0 (ind_indices Xg))). - generalize (cshape_indices y). induction 1; constructor; auto. - red in p0 |- *. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ (typing_wf_local p0) (existT _ _ (existT _ _ p0))))))). + generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))). + generalize (cstr_indices x0). induction 1; constructor; auto. + red in t2 |- *. + specialize (IH ((Σ, udecl); (X13; (_; (_; (_; t2)))))). simpl in IH. apply IH. simpl. constructor 1. simpl. auto with arith. -- intros Hprojs; pose proof (onProjections Xg Hprojs); auto. -- destruct Xg. simpl. unfold check_ind_sorts in *. @@ -1270,72 +1384,67 @@ Proof. eapply type_local_ctx_impl. eapply ind_sorts0. intros. red in X14. destruct T. - pose proof (typing_wf_local X14). - specialize (IH ((Σ, udecl); (X13; _; X17; _; _; X14))). + specialize (IH ((Σ, udecl); (X13; _; _; _; X14))). apply IH. simpl. constructor 1. simpl. auto with arith. destruct X14 as [u Hu]. exists u. - pose proof (typing_wf_local Hu). - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ X14 (existT _ _ (existT _ _ Hu))))))). + specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hu)))))). apply IH. simpl. constructor 1. simpl. auto with arith. -- apply (onIndices Xg). * red in onP |- *. eapply All_local_env_impl; eauto. intros. destruct T; simpl in X14. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ (typing_wf_local (Σ:=(Σ, udecl)) X14) - (existT _ _ (existT _ _ X14))))))). + specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ X14)))))). simpl in IH. apply IH. constructor 1. simpl. lia. destruct X14 as [u Hu]. - specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ (typing_wf_local (Σ:=(Σ, udecl)) Hu) - (existT _ _ (existT _ _ Hu))))))). + specialize (IH (existT _ (Σ, udecl) (existT _ X13 (existT _ _ (existT _ _ (existT _ _ Hu)))))). simpl in IH. simpl. exists u. apply IH. constructor 1. simpl. lia. - - assert (forall Γ (wfΓ : wf_local Σ Γ) t T (Hty : Σ ;;; Γ |- t : T), + - assert (forall Γ t T (Hty : Σ ;;; Γ |- t : T), typing_size Hty < typing_size H -> Forall_decls_typing P Σ.1 * P Σ Γ t T). - intros. - specialize (IH (existT _ Σ (existT _ wfΣ (existT _ _ (existT _ wfΓ0 (existT _ _ (existT _ _ Hty))))))). - simpl in IH. - forward IH. - constructor 2. simpl. apply H0. - apply IH. clear IH. + { intros. + specialize (IH (existT _ Σ (existT _ wfΣ (existT _ _ (existT _ _ (existT _ _ Hty)))))). + simpl in IH. + forward IH. + constructor 2. simpl. apply H0. + intuition. } + rename X13 into X14. - assert (All_local_env_over typing Pdecl Σ Γ (typing_wf_local H)). - { clear -Pdecl wfΓ wfΣ X14. - pose proof (typing_wf_local_size H). clear wfΓ. - set (foo := typing_wf_local H) in *. - clearbody foo. - revert foo H0. generalize Γ at 1 2 4. - induction foo; simpl in *; try destruct t2 as [u Hu]; simpl in *; constructor. + assert (forall Γ' t T (Hty : Σ ;;; Γ' |- t : T), + typing_size Hty <= typing_size H -> + PΓ Σ Γ' (typing_wf_local Hty)). + { intros. apply XΓ; auto. + clear -Pdecl wfΣ X14 H0. + pose proof (typing_wf_local_size Hty). + set (foo := typing_wf_local Hty) in *. + clearbody foo. assert (wf_local_size Σ (@typing_size cf) Γ' foo < typing_size H) by lia. + clear H1 H0 Hty. + revert foo H2. + induction foo; simpl in *; try destruct t3 as [u Hu]; simpl in *; constructor. - simpl in *. apply IHfoo. lia. - - red. eapply (X14 _ foo _ _ Hu). lia. + - red. apply (X14 _ _ _ Hu). lia. - simpl in *. apply IHfoo. lia. - - red. apply (X14 _ foo _ _ t3). lia. - - red. simpl. apply (X14 _ foo _ _ Hu). lia. } - - destruct H; + - red. apply (X14 _ _ _ t4). lia. + - red. simpl. apply (X14 _ _ _ Hu). lia. } + + clear IH. + assert (pΓ : PΓ Σ Γ (typing_wf_local H)). + { apply (X13 _ _ _ H). lia. } + split; auto. + set (wfΓ := typing_wf_local H); clearbody wfΓ. + + destruct H; simpl in pΓ; try solve [ match reverse goal with - H : _ |- _ => eapply H - end; eauto; - unshelve eapply X14; simpl; auto with arith]. + H : _ |- _ => eapply H + end; eauto; + unshelve eapply X14; simpl; auto with arith]. -- match reverse goal with H : _ |- _ => eapply H - end; eauto; + end; eauto; unshelve eapply X14; simpl; eauto with arith wf. - -- match reverse goal with - H : _ |- _ => eapply H - end; eauto; - unshelve eapply X14; simpl; auto with arith. - econstructor; simpl; eauto. - - -- match reverse goal with - H : _ |- _ => eapply H - end; eauto; - unshelve eapply X14; simpl; auto with arith. lia. - econstructor; eauto. eexists; eassumption. lia. - -- clear X X0 Xcast X1 X2 X3 X5 X6 X7 X8 X9 X10 X11 X12 X13. eapply X4 with t_ty t0; eauto. clear X4. unshelve eapply X14; simpl; auto with arith. @@ -1350,46 +1459,46 @@ Proof. typing_size x3) Σ Γ t_ty l t' t0)) -> Forall_decls_typing P Σ.1 * P Σ Γ0 t1 T). { intros. unshelve eapply X14; eauto. lia. } - clear X14. clear n e H. + clear X14. simpl in pΓ. clear n e H pΓ. induction t0; constructor. unshelve eapply X; clear X; simpl; auto with arith. unshelve eapply X; clear X; simpl; auto with arith. eapply IHt0; eauto. intros. eapply (X _ X0 _ _ Hty) ; eauto. simpl. lia. -- eapply X5; eauto. - specialize (X14 [] localenv_nil _ _ (type_Prop _)). + specialize (X14 [] _ _ (type_Prop _)). simpl in X14. forward X14; auto. lia. apply X14. -- eapply X6; eauto. - specialize (X14 [] localenv_nil _ _ (type_Prop _)). + specialize (X14 [] _ _ (type_Prop _)). simpl in X14. forward X14; auto. lia. apply X14. -- eapply X7; eauto. - specialize (X14 [] localenv_nil _ _ (type_Prop _)). + specialize (X14 [] _ _ (type_Prop _)). simpl in X14. forward X14; auto. lia. apply X14. - -- destruct indnparrel as ((ind' & npar') & ?); - cbn in ind; cbn in npar; subst ind; subst npar. - eapply X8; eauto. - ++ eapply (X14 _ wfΓ _ _ H); eauto. simpl; auto with arith. - ++ eapply (X14 _ wfΓ _ _ H); eauto. simpl; auto with arith. + -- simpl in pΓ. + eapply (X8 Σ wfΣ Γ (typing_wf_local H0) ci); eauto. + ++ eapply (X14 _ _ _ H0); eauto. simpl; auto with arith. lia. + ++ simpl in X13. simpl in pΓ. eapply (X14 _ _ _ H); eauto. simpl; auto with arith. ++ simpl in *. - eapply (X14 _ wfΓ _ _ H0); eauto. lia. - ++ clear X13. revert a wfΓ X14. simpl. clear. intros. - induction a; simpl in *. - ** constructor. - ** destruct r as [[? ?] ?]. constructor. - --- intuition eauto. - +++ eapply (X14 _ wfΓ _ _ t); eauto. simpl; auto with arith. - lia. - +++ destruct s as [s Hs]. exists s; split; [auto|]. - eapply (X14 _ wfΓ _ _ Hs); eauto. simpl; auto with arith. - lia. - --- apply IHa. auto. intros. - eapply (X14 _ wfΓ0 _ _ Hty). lia. + eapply (X13 _ _ _ H); eauto. simpl. subst predctx. lia. + ++ eapply (X14 _ _ _ H0); simpl. lia. + ++ clear X13. revert a X14. simpl. clear. intros. + subst ptm predctx. + induction a; simpl in *. + ** constructor. + ** destruct r as [[? ?] ?]. constructor. + --- intuition eauto. + +++ eapply (X14 _ _ _ t); eauto. simpl; auto with arith. + lia. + +++ eapply (X14 _ _ _ t0); eauto. simpl; auto with arith. + lia. + --- apply IHa. auto. intros. + eapply (X14 _ _ _ Hty). lia. -- eapply X9; eauto. - specialize (X14 [] localenv_nil _ _ (type_Prop _)). + specialize (X14 [] _ _ (type_Prop _)). simpl in X14. forward X14; auto. pose (typing_size_pos H). lia. apply X14. unshelve eapply X14; eauto. @@ -1403,8 +1512,8 @@ Proof. (p : ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) => typing_size p.π2) a0) -> Forall_decls_typing P Σ.1 * P Σ Γ t T). - intros; eauto. eapply (X14 _ a _ _ Hty); eauto. lia. - clear X13 X14 a. + intros; eauto. eapply (X14 _ _ _ Hty); eauto. lia. + clear X13 X14 a pΓ. clear -a0 X. induction a0; constructor. destruct p as [s Hs]. exists s; split; auto. @@ -1421,9 +1530,9 @@ Proof. )%type (fun (x : def term) p => typing_size p) a1) -> Forall_decls_typing P Σ.1 * P Σ Γ0 t T). - {intros. eapply (X14 _ X _ _ Hty); eauto. lia. } + {intros. eapply (X14 _ _ _ Hty); eauto. lia. } clear X14 X13. - clear e decl i a0 i0. + clear e decl i a0 i0 pΓ. remember (fix_context mfix) as mfixcontext. clear Heqmfixcontext. induction a1; econstructor; eauto. @@ -1442,8 +1551,8 @@ Proof. (p : ∑ s : Universe.t, Σ;;; Γ |- dtype x : tSort s) => typing_size p.π2) a0) -> Forall_decls_typing P Σ.1 * P Σ Γ t T). - intros; eauto. eapply (X14 _ a _ _ Hty); eauto. lia. - clear X13 X14 a. + intros; eauto. eapply (X14 _ _ _ Hty); eauto. lia. + clear X13 X14 a pΓ. clear -a0 X. induction a0; constructor. destruct p as [s Hs]. exists s; split; auto. @@ -1459,9 +1568,9 @@ Proof. (all_size (fun x : def term => (Σ;;; Γ ,,, fix_context mfix |- dbody x : lift0 #|fix_context mfix| (dtype x))%type) (fun (x : def term) p => typing_size p) a1) -> Forall_decls_typing P Σ.1 * P Σ Γ0 t T). - {intros. eapply (X14 _ X _ _ Hty); eauto. lia. } + { intros. eapply (X14 _ _ _ Hty); eauto. lia. } clear X14 X13. - clear e decl a0 i i0. + clear e decl a0 i i0 pΓ. remember (fix_context mfix) as mfixcontext. clear Heqmfixcontext. induction a1; econstructor; eauto. diff --git a/template-coq/theories/TypingWf.v b/template-coq/theories/TypingWf.v index ade75bae3..82df7a9b9 100644 --- a/template-coq/theories/TypingWf.v +++ b/template-coq/theories/TypingWf.v @@ -45,6 +45,50 @@ Proof. -- constructor. Qed. +Lemma on_global_env_impl `{checker_flags} Σ P Q : + (forall Σ Γ t T, on_global_env P Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) -> + on_global_env P Σ -> on_global_env Q Σ. +Proof. + intros X X0. + simpl in *. induction X0; constructor; auto. + clear IHX0. destruct d; simpl. + - destruct c; simpl. destruct cst_body0; simpl in *. + red in o |- *. simpl in *. now eapply X. + red in o |- *. simpl in *. now eapply X. + - simpl in *. + destruct o0 as [onI onP onNP]. + constructor; auto. + -- eapply Alli_impl. exact onI. eauto. intros. + refine {| ind_arity_eq := X1.(ind_arity_eq); + ind_cunivs := X1.(ind_cunivs) |}. + --- apply onArity in X1. unfold on_type in *; simpl in *. + now eapply X. + --- pose proof X1.(onConstructors) as X11. red in X11. + eapply All2_impl; eauto. + simpl. intros. destruct X2 as [? ? ? ?]; unshelve econstructor; eauto. + * apply X; eauto. + * clear -X0 X on_cargs. revert on_cargs. + generalize (cstr_args x0), y. + induction c; destruct y0; simpl; auto; + destruct a as [na [b|] ty]; simpl in *; auto; + split; intuition eauto. + * clear -X0 X on_cindices. + revert on_cindices. + generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))). + generalize (cstr_indices x0). + induction 1; simpl; constructor; auto. + --- simpl; intros. apply (onProjections X1 H0). + --- destruct X1. simpl. unfold check_ind_sorts in *. + destruct Universe.is_prop; auto. + destruct Universe.is_sprop; auto. + split. apply ind_sorts. destruct indices_matter; auto. + eapply type_local_ctx_impl. eapply ind_sorts. auto. + --- apply (onIndices X1). + -- red in onP. red. + eapply All_local_env_impl. eauto. + intros. now apply X. +Qed. + Lemma All_local_env_wf_decl_inv: forall (a : context_decl) (Γ : list context_decl) (X : All_local_env wf_decl_pred (a :: Γ)), @@ -122,14 +166,14 @@ Proof. unfold cofix_subst. generalize #|mfix|; intros. induction n; auto. Qed. -Lemma wf_subst_instance_constr u c : - Ast.wf c -> Ast.wf (subst_instance_constr u c). +Lemma wf_subst_instance u c : + Ast.wf c -> Ast.wf (subst_instance u c). Proof. induction 1 using term_wf_forall_list_ind; simpl; try solve [ constructor; auto using Forall_map ]. - constructor; auto. destruct t; simpl in *; try congruence. destruct l; simpl in *; congruence. now apply Forall_map. - - constructor; auto. solve_all. + - constructor; auto; simpl; solve_all. - constructor. solve_all. - constructor. solve_all. Qed. @@ -174,6 +218,314 @@ Lemma All_Alli {A} {P : A -> Type} {Q : nat -> A -> Type} {l n} : Proof. intro H. revert n. induction H; constructor; eauto. Qed. +Ltac wf := intuition try (eauto with wf || congruence || solve [constructor]). +Hint Unfold wf_decl vass vdef : wf. +Hint Extern 10 => progress simpl : wf. +Hint Unfold snoc : wf. +Hint Extern 3 => apply wf_lift || apply wf_subst || apply wf_subst_instance : wf. +Hint Extern 10 => constructor : wf. +Hint Resolve All_skipn : wf. + +Lemma declared_inductive_wf {cf:checker_flags} : + forall (Σ : global_env) ind + (mdecl : mutual_inductive_body) (idecl : one_inductive_body), + Forall_decls_typing (fun (_ : global_env_ext) (_ : context) (t T : term) => Ast.wf t /\ Ast.wf T) Σ -> + declared_inductive Σ ind mdecl idecl -> Ast.wf (ind_type idecl). +Proof. + intros. + destruct H as [Hmdecl Hidecl]. red in Hmdecl. + eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. + apply onInductives in prf. + eapply nth_error_alli in Hidecl; eauto. + eapply onArity in Hidecl. + destruct Hidecl as [s Hs]; wf. +Qed. + +Lemma it_mkProd_or_LetIn_wf Γ t + : Ast.wf (it_mkProd_or_LetIn Γ t) -> Forall wf_decl Γ /\ Ast.wf t. +Proof. + revert t. induction Γ; [simpl; auto with wf|]. intros t XX. + destruct a, decl_body; simpl in *. + apply IHΓ in XX as []. depelim H0; simpl in *; split; auto with wf. + apply IHΓ in XX as []. depelim H0. simpl in *. + split; auto. constructor; auto with wf. +Qed. + +Lemma declared_inductive_wf_indices {cf:checker_flags} : + forall (Σ : global_env) ind + (mdecl : mutual_inductive_body) (idecl : one_inductive_body), + Forall_decls_typing (fun (_ : global_env_ext) (_ : context) (t T : term) => Ast.wf t /\ Ast.wf T) Σ -> + declared_inductive Σ ind mdecl idecl -> Forall wf_decl (ind_indices idecl). +Proof. + intros. + destruct H as [Hmdecl Hidecl]. red in Hmdecl. + eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. + apply onInductives in prf. + eapply nth_error_alli in Hidecl; eauto. + pose proof (onArity Hidecl). + rewrite Hidecl.(ind_arity_eq) in X. + destruct X as [s Hs]; wf. + eapply it_mkProd_or_LetIn_wf in H as [? H]. + now eapply it_mkProd_or_LetIn_wf in H. +Qed. + +Lemma declared_inductive_wf_ctors {cf:checker_flags} : + forall (Σ : global_env) ind + (mdecl : mutual_inductive_body) (idecl : one_inductive_body), + Forall_decls_typing (fun (_ : global_env_ext) (_ : context) (t T : term) => Ast.wf t /\ Ast.wf T) Σ -> + declared_inductive Σ ind mdecl idecl -> + Forall (fun ctor => Forall wf_decl ctor.(cstr_args)) (ind_ctors idecl). +Proof. + intros. + destruct H as [Hmdecl Hidecl]. red in Hmdecl. + eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. + apply onInductives in prf. + eapply nth_error_alli in Hidecl; eauto. + pose proof (onConstructors Hidecl). red in X. + solve_all. destruct X. + clear -on_cargs. + induction (cstr_args x) as [|[na [b|] ty] args] in on_cargs, y |- * ; + try destruct on_cargs; + constructor; intuition eauto; simpl in *. red. simpl. + destruct y => //. intuition auto. + destruct y => //. eapply IHargs. intuition eauto. +Qed. + +Lemma All_local_env_wf_decls ctx : + TemplateEnvTyping.All_local_env wf_decl_pred ctx -> + Forall wf_decl ctx. +Proof. + induction 1; constructor; auto. + destruct t0 as [s Hs]. split; simpl; intuition auto. +Qed. + +Lemma declared_inductive_wf_params {cf:checker_flags} : + forall (Σ : global_env) ind + (mdecl : mutual_inductive_body) (idecl : one_inductive_body), + on_global_env (fun Σ => wf_decl_pred) Σ -> + declared_inductive Σ ind mdecl idecl -> Forall wf_decl (ind_params mdecl). +Proof. + intros. + destruct H as [Hmdecl Hidecl]. red in Hmdecl. + eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. + apply onParams in prf. red in prf. + now apply All_local_env_wf_decls in prf. +Qed. + +Lemma declared_constructor_wf {cf:checker_flags}: + forall (Σ : global_env) (ind : inductive) (i : nat) (u : list Level.t) + (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body), + Forall_decls_typing (fun (_ : global_env_ext) (_ : context) (t T : term) => Ast.wf t /\ Ast.wf T) Σ -> + declared_constructor Σ (ind, i) mdecl idecl cdecl -> + Ast.wf (cstr_type cdecl). +Proof. + intros Σ ind i u mdecl idecl cdecl X isdecl. + destruct isdecl as [[Hmdecl Hidecl] Hcdecl]. red in Hmdecl. + eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. red in prf. + apply onInductives in prf. + eapply nth_error_alli in Hidecl; eauto. simpl in *. + pose proof (onConstructors Hidecl) as h. unfold on_constructors in h. + eapply All2_nth_error_Some in Hcdecl. 2: eassumption. + destruct Hcdecl as [cs [Hnth [? ? ? [? [? ?]] ?]]]. + assumption. +Qed. + +Lemma destArity_spec ctx T : + match destArity ctx T with + | Some (ctx', s) => it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s) + | None => True + end. +Proof. + induction T in ctx |- *; simpl; try easy. + - specialize (IHT2 (ctx,, vass na T1)). now destruct destArity. + - specialize (IHT3 (ctx,, vdef na T1 T2)). now destruct destArity. +Qed. + +Lemma destArity_it_mkProd_or_LetIn ctx ctx' t : + destArity ctx (it_mkProd_or_LetIn ctx' t) = + destArity (ctx ,,, ctx') t. +Proof. + induction ctx' in ctx, t |- *; simpl; auto. + rewrite IHctx'. destruct a as [na [b|] ty]; reflexivity. +Qed. + +Lemma it_mkProd_or_LetIn_inj ctx s ctx' s' : + it_mkProd_or_LetIn ctx (tSort s) = it_mkProd_or_LetIn ctx' (tSort s') -> + ctx = ctx' /\ s = s'. +Proof. + move/(f_equal (destArity [])). + rewrite !destArity_it_mkProd_or_LetIn /=. + now rewrite !app_context_nil_l => [= -> ->]. +Qed. + +(* +Lemma case_predicate_contextP ind mdecl idecl params uinst pctx : + build_case_predicate_context ind mdecl idecl params uinst = Some pctx <~> + case_predicate_context ind mdecl idecl params uinst pctx. +Proof. + unfold build_case_predicate_context. + unfold instantiate_params. + destruct instantiate_params_subst as [[ictx p]|] eqn:ipars => /= //. + 2:{ split => //. intros H. depelim H. + eapply instantiate_params_substP in i. + rewrite ipars in i. discriminate. } + move: (destArity_spec [] (subst0 ictx p)). + destruct destArity as [[idctx inds]|] eqn:da => //. + simpl. intros eqs. + split. + eapply instantiate_params_substP in ipars. + intros [= <-]. econstructor. eauto. eauto. + intros H. depelim H. subst sty. + eapply instantiate_params_substP in i. + rewrite ipars in i. noconf i. rewrite eqs in e. + eapply it_mkProd_or_LetIn_inj in e as [<- <-]. + reflexivity. + split => // [] [] s ty ictxt inds. + move/instantiate_params_substP. + rewrite ipars /= => [=] <- <- H. + rewrite H destArity_it_mkProd_or_LetIn in da. + noconf da. +Qed. +*) +Lemma wf_reln n acc Γ : Forall Ast.wf acc -> Forall Ast.wf (reln acc n Γ). +Proof. + induction Γ in acc, n |- * => wfacc /= //. + destruct a as [? [|] ?] => //. now eapply IHΓ. + eapply IHΓ. constructor; auto. constructor. +Qed. + +Hint Resolve wf_reln : wf. + +Lemma wf_instantiate_params_subst_spec params pars s ty s' ty' : + instantiate_params_subst_spec params pars s ty s' ty' -> + Forall wf_decl params -> + Ast.wf ty -> + Forall Ast.wf pars -> + Forall Ast.wf s -> + Forall Ast.wf s' /\ Ast.wf ty'. +Proof. + intros ipars. induction ipars; intros wfparams wfty wfpars wfs => //. + depelim wfparams. depelim wfpars. depelim wfty. + apply IHipars; auto. + depelim wfparams. depelim wfty. destruct H; simpl in *. + apply IHipars; auto with wf. +Qed. + +Lemma wf_map2_set_binder_name l l' : + Forall wf_decl l' -> + Forall wf_decl (map2 set_binder_name l l'). +Proof. + induction 1 in l |- *; destruct l; simpl; constructor. + apply H. apply IHForall. +Qed. + +Definition lift_context_snoc0 n k Γ d : lift_context n k (d :: Γ) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d. +Proof. unfold lift_context. now rewrite fold_context_k_snoc0. Qed. +Hint Rewrite lift_context_snoc0 : lift. + +Lemma lift_context_snoc n k Γ d : lift_context n k (Γ ,, d) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d. +Proof. + unfold snoc. apply lift_context_snoc0. +Qed. +Hint Rewrite lift_context_snoc : lift. + +Lemma wf_subst_context s k Γ : Forall wf_decl Γ -> Forall Ast.wf s -> Forall wf_decl (subst_context s k Γ). +Proof. + intros wfΓ. induction wfΓ in s |- *. + - intros. constructor. + - rewrite subst_context_snoc. constructor; auto. + destruct H. destruct x as [? [] ?]; constructor; simpl in *; wf. +Qed. + +Lemma wf_lift_context n k Γ : Forall wf_decl Γ -> Forall wf_decl (lift_context n k Γ). +Proof. + intros wfΓ. induction wfΓ in n, k |- *. + - intros. constructor. + - rewrite lift_context_snoc0. constructor; auto. + destruct H. destruct x as [? [] ?]; constructor; simpl in *; wf. +Qed. + +Lemma wf_subst_instance_context u Γ : + Forall wf_decl Γ -> + Forall wf_decl (subst_instance u Γ). +Proof. + induction 1; constructor; auto. + destruct x as [na [b|] ty]; simpl in *. + destruct H. now split; apply wf_subst_instance. + destruct H. now split; auto; apply wf_subst_instance. +Qed. + +Lemma wf_extended_subst Γ n : + Forall wf_decl Γ -> + Forall Ast.wf (extended_subst Γ n). +Proof. + induction 1 in n |- *. + - simpl; constructor. + - destruct x as [na [b|] ty]; simpl; constructor; auto. + 2:constructor. + eapply wf_subst; auto. + eapply wf_lift. apply H. +Qed. + +Lemma wf_case_predicate_context ind mdecl idecl params uinst pctx : + Forall wf_decl mdecl.(ind_params) -> + Forall wf_decl (ind_indices idecl) -> + Forall Ast.wf params -> + Forall wf_decl (case_predicate_context ind mdecl idecl params uinst pctx). +Proof. + intros wfparams wfindty wfpars. + unfold case_predicate_context. + apply wf_map2_set_binder_name. constructor. + simpl; split; auto. simpl. auto. simpl. + eapply wf_mkApps. constructor. + apply app_Forall. + solve_all; auto with wf. now apply wf_reln. + eapply wf_subst_context => //. + apply wf_subst_instance_context, wf_subst_context. + now apply wf_lift_context. + now apply wf_extended_subst. +Qed. + +Lemma on_global_wf_Forall_decls {cf:checker_flags} Σ : + on_global_env + (fun _ : Env.global_env_ext => wf_decl_pred) Σ -> + Forall_decls_typing + (fun (_ : global_env_ext) (_ : context) (t T : term) => + Ast.wf t /\ Ast.wf T) Σ. +Proof. + apply on_global_env_impl => Σ' Γ t []; simpl; unfold wf_decl_pred; + intros; auto. + exists (Universe.lProp). wf. +Qed. + +Lemma Forall_decls_on_global_wf {cf:checker_flags} Σ : + Forall_decls_typing + (fun (_ : global_env_ext) (_ : context) (t T : term) => + Ast.wf t /\ Ast.wf T) Σ -> + on_global_env (fun _ : Env.global_env_ext => wf_decl_pred) Σ. + Proof. + apply on_global_env_impl => Σ' Γ t []; simpl; unfold wf_decl_pred; + intros; auto. destruct X0 as [s ?]; intuition auto. +Qed. + +Hint Resolve on_global_wf_Forall_decls : wf. + +Lemma wf_case_branches_context {cf:checker_flags} Σ ind mdecl idecl p : + on_global_env (fun Σ => wf_decl_pred) Σ -> + declared_inductive Σ ind mdecl idecl -> + Forall Ast.wf (pparams p) -> + Forall (fun ctor => Forall wf_decl (cstr_args ctor)) (ind_ctors idecl) -> + Forall (fun ctx => Forall wf_decl ctx) (case_branches_contexts idecl p). +Proof. + intros ong decli wfpars. + unfold case_branches_contexts. + intros Hforall. eapply Forall_map. + eapply Forall_impl; eauto. intros. simpl in H. + unfold case_branch_context_gen. + apply wf_subst_context; auto. + now apply wf_subst_instance_context. +Qed. + Lemma wf_red1 {cf:checker_flags} Σ Γ M N : on_global_env (fun Σ => wf_decl_pred) Σ -> List.Forall wf_decl Γ -> @@ -184,7 +536,8 @@ Proof. intros wfΣ wfΓ wfM H. induction H using red1_ind_all in wfM, wfΓ |- *. all: inv wfM. - all: try solve[ constructor; auto with wf ]. + all: try solve[ constructor; intuition auto with wf ]. + all:auto. - inv H1. inv H2. eauto with wf. @@ -194,37 +547,50 @@ Proof. eapply nth_error_forall in wfΓ; eauto. unfold wf_decl in *. apply some_inj in H; rewrite H in wfΓ; apply wfΓ. - unfold iota_red. - apply wf_mkApps_inv in H0. - apply wf_mkApps; auto. - induction brs in c, H1 |- *; destruct c; simpl in *. constructor. constructor. - inv H1; auto. inv H1; auto. - induction H0 in pars |- *; destruct pars; try constructor; auto. simpl. auto. + apply wf_mkApps_inv in H1. + apply wf_subst. now eapply Forall_skipn. + induction brs in c, H2 |- *; destruct c; simpl in *; try constructor. + inv H2; auto. inv H2; auto. - apply unfold_fix_wf in H; auto. eapply wf_mkApps; auto. - - constructor; auto. apply wf_mkApps_napp in H1 as [Hcof Hargs]; auto. + - constructor; auto. apply wf_mkApps_napp in H2 as [Hcof Hargs]; auto. apply unfold_cofix_wf in H; auto. apply wf_mkApps; intuition auto. - constructor; auto. apply wf_mkApps_napp in H0 as [Hcof Hargs]; auto. apply unfold_cofix_wf in H; auto. apply wf_mkApps; intuition auto. - - apply wf_subst_instance_constr. + - apply wf_subst_instance. unfold declared_constant in H. eapply lookup_on_global_env in H as [Σ' [onΣ' prf]]; eauto. destruct decl; simpl in *. - subst cst_body; simpl in *; compute in prf; intuition auto. + subst cst_body0; simpl in *; compute in prf; intuition auto. - apply wf_mkApps_inv in H0. eapply nth_error_forall in H0; eauto. - - constructor; auto. apply IHred1; auto. constructor; simpl; auto. - constructor; cbn; easy. - - constructor; auto. apply IHred1; auto. constructor; simpl; auto. + - simpl in *. induction X; constructor; inv H; intuition auto. + simpl. constructor; auto. simpl in *. depelim H; simpl in *. constructor; auto. - - constructor; auto. induction X; constructor; inv H1; intuition auto. - - apply wf_mkApps; auto. - - constructor; auto. induction X; congruence. - clear H0. induction X; inv H2; constructor; intuition auto. - - constructor; auto. apply IHred1; auto. constructor; simpl; auto. - constructor; cbn; easy. - - constructor; auto. induction X; inv H; constructor; intuition auto. - - auto. + - constructor; auto; simpl in *. + apply IHred1; eauto. + apply app_Forall => //. + apply wf_case_predicate_context; auto. + eapply declared_inductive_wf_params in isdecl; auto. + eapply declared_inductive_wf_indices; eauto; wf. + - constructor; auto. + pose proof (wf_case_branches_context _ _ _ _ _ wfΣ isdecl H). + solve_all. eapply OnOne2All_All_mix_left in X; eauto. simpl in X. + forward H3. + eapply declared_inductive_wf_ctors; eauto; wf. + clear -wfΓ X H2 H3. + induction X; try congruence. + inv H2. destruct p0 as [[? ?] ?]. constructor; intuition eauto. + apply b0; auto. depelim H3. + apply app_Forall => //. solve_all. + inv H2; constructor; intuition auto. + apply X1 => //. now depelim H3. + - now eapply wf_mkApps. + - constructor; auto. induction X; auto; congruence. + clear H H1 H0. induction X; inv H2; constructor; intuition auto; try congruence. + - constructor. + induction X; inv H; constructor; intuition auto. - constructor; auto. induction X; inv H; constructor; intuition auto; congruence. - constructor; auto. solve_all. @@ -234,13 +600,14 @@ Proof. simpl in *. inversion e. subst. clear e. intuition eauto. - + eapply ih. 2: assumption. - solve_all. apply All_app_inv. 2: assumption. - unfold fix_context. apply All_rev. eapply All_mapi. - eapply All_Alli. 1: exact H'. - cbn. unfold wf_decl. simpl. - intros ? [? ? ? ?] ?. simpl in *. - intuition eauto with wf. + eapply ih. 2: assumption. + solve_all. + apply All_app_inv. 2: assumption. + unfold fix_context. apply All_rev. eapply All_mapi. + eapply All_Alli. 1: exact H'. + cbn. unfold wf_decl. simpl. + intros ? [? ? ? ?] ?. simpl in *. + intuition eauto with wf. - constructor; auto. induction X; inv H; constructor; intuition auto; congruence. - constructor; auto. solve_all. @@ -259,14 +626,6 @@ Proof. intuition eauto with wf. Qed. -Ltac wf := intuition try (eauto with wf || congruence || solve [constructor]). -Hint Unfold wf_decl vass vdef : wf. -Hint Extern 10 => progress simpl : wf. -Hint Unfold snoc : wf. -Hint Extern 3 => apply wf_lift || apply wf_subst || apply wf_subst_instance_constr : wf. -Hint Extern 10 => constructor : wf. -Hint Resolve All_skipn : wf. - Lemma wf_inds mind bodies u : Forall Ast.wf (inds mind u bodies). Proof. unfold inds. generalize #|bodies|. induction n. constructor. @@ -295,39 +654,7 @@ Proof. - destruct l; simpl in *; congruence. Qed. -Lemma declared_inductive_wf {cf:checker_flags} : - forall (Σ : global_env) ind - (mdecl : mutual_inductive_body) (idecl : one_inductive_body), - Forall_decls_typing (fun (_ : global_env_ext) (_ : context) (t T : term) => Ast.wf t /\ Ast.wf T) Σ -> - declared_inductive Σ mdecl ind idecl -> Ast.wf (ind_type idecl). -Proof. - intros. - destruct H as [Hmdecl Hidecl]. red in Hmdecl. - eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. - apply onInductives in prf. - eapply nth_error_alli in Hidecl; eauto. - eapply onArity in Hidecl. - destruct Hidecl as [s Hs]; wf. -Qed. -Lemma declared_constructor_wf {cf:checker_flags}: - forall (Σ : global_env) (ind : inductive) (i : nat) (u : list Level.t) - (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : ident * term * nat), - Forall_decls_typing (fun (_ : global_env_ext) (_ : context) (t T : term) => Ast.wf t /\ Ast.wf T) Σ -> - declared_constructor Σ mdecl idecl (ind, i) cdecl -> - Ast.wf (cdecl_type cdecl). -Proof. - intros Σ ind i u mdecl idecl cdecl X isdecl. - destruct isdecl as [[Hmdecl Hidecl] Hcdecl]. red in Hmdecl. - eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. red in prf. - apply onInductives in prf. - eapply nth_error_alli in Hidecl; eauto. simpl in *. - pose proof (onConstructors Hidecl) as h. unfold on_constructors in h. - eapply All2_nth_error_Some in Hcdecl. 2: eassumption. - destruct Hcdecl as [cs [Hnth [? ? ? [? [? ?]] ?]]]. - assumption. -Qed. - Lemma on_inductive_wf_params {cf:checker_flags} {Σ : global_env_ext} {ind mdecl} : forall (oib : on_inductive (lift_typing (fun _ _ (t T : term) => Ast.wf t /\ Ast.wf T)) Σ @@ -341,32 +668,23 @@ Proof. destruct X0; intuition auto. Qed. -Lemma declared_inductive_wf_shapes {cf:checker_flags} {Σ : global_env_ext} {ind mdecl idecl} : - forall (oib : on_ind_body - (lift_typing (fun _ _ (t T : term) => Ast.wf t /\ Ast.wf T)) Σ +Lemma declared_inductive_wf_ctors' {cf:checker_flags} {Σ : global_env_ext} {ind mdecl idecl} : + forall (oib : on_ind_body (lift_typing (fun _ _ (t T : term) => Ast.wf t /\ Ast.wf T)) Σ (inductive_mind ind) mdecl (inductive_ind ind) idecl), - Forall (fun cs => Forall wf_decl (cshape_args cs)) oib.(ind_cshapes). + Forall (fun cs => Forall wf_decl (cstr_args cs)) idecl.(ind_ctors). Proof. intros oib. pose proof (onConstructors oib) as h. unfold on_constructors in h. induction h; constructor; auto. destruct r. clear -on_cargs. - revert on_cargs. generalize (cshape_sorts y). - induction (cshape_args y) as [|[? [] ?] ?]; simpl; - destruct l; intuition auto; + revert on_cargs. revert y. generalize (cstr_args x). + induction c as [|[? [] ?] ?]; simpl; + destruct y; intuition auto; constructor; try red; simpl; intuition eauto. Qed. -Lemma wf_subst_context s k Γ : Forall wf_decl Γ -> Forall Ast.wf s -> Forall wf_decl (subst_context s k Γ). -Proof. - intros wfΓ. induction wfΓ in s |- *. - - intros. constructor. - - rewrite subst_context_snoc. constructor; auto. - destruct H. destruct x as [? [] ?]; constructor; simpl in *; wf. -Qed. - Lemma wf_smash_context Γ Δ : Forall wf_decl Γ -> Forall wf_decl Δ -> Forall wf_decl (smash_context Δ Γ). Proof. @@ -386,7 +704,7 @@ Proof. Lemma declared_projection_wf {cf:checker_flags}: forall (Σ : global_env) (p : projection) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (pdecl : ident * term), - declared_projection Σ mdecl idecl p pdecl -> + declared_projection Σ p mdecl idecl pdecl -> Forall_decls_typing (fun (_ : global_env_ext) (_ : context) (t T : term) => Ast.wf t /\ Ast.wf T) Σ -> Ast.wf (snd pdecl). Proof. @@ -398,12 +716,12 @@ Proof. eapply nth_error_alli in Hidecl; eauto. intuition auto. pose proof (onProjections Hidecl) as on_projs. forward on_projs by now eapply nth_error_Some_non_nil in H. - destruct (ind_cshapes Hidecl) as [|? [|]] eqn:Heq; try contradiction. + destruct (ind_ctors idecl) as [|? [|]] eqn:Heq; try contradiction. destruct on_projs. eapply nth_error_alli in on_projs; eauto. red in on_projs. hnf in on_projs. simpl in on_projs. destruct (nth_error (smash_context _ _) _) eqn:Heq'; try contradiction. - pose proof (declared_inductive_wf_shapes Hidecl). + pose proof (declared_inductive_wf_ctors' Hidecl). eapply Forall_All in H1. simpl in Heq. rewrite Heq in H1. inv H1. clear X0. destruct on_projs as [onna on_projs]. rewrite on_projs. @@ -441,19 +759,6 @@ Proof. - destruct h'. intuition eauto. Qed. - -Lemma destArity_spec ctx T : - match destArity ctx T with - | Some (ctx', s) => it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s) - | None => True - end. -Proof. - induction T in ctx |- *; simpl; try easy. - - specialize (IHT2 (ctx,, vass na T1)). now destruct destArity. - - specialize (IHT3 (ctx,, vdef na T1 T2)). now destruct destArity. -Qed. - - Lemma wf_it_mkProd_or_LetIn `{checker_flags} Σ Γ (wfΓ : wf_local Σ Γ) : All_local_env_over typing (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ) @@ -467,26 +772,41 @@ Proof. - intros t0 Ht0. apply IHX. constructor. apply p. apply p. assumption. Qed. -Lemma it_mkProd_or_LetIn_wf Γ t - : Ast.wf (it_mkProd_or_LetIn Γ t) -> Ast.wf t. +Lemma wf_Lambda_or_LetIn {d t} : + wf_decl d -> + Ast.wf t -> + Ast.wf (mkLambda_or_LetIn d t). Proof. - revert t. induction Γ; [trivial|]. intros t XX. - destruct a, decl_body; simpl in *. - apply IHΓ in XX. now inv XX. - apply IHΓ in XX. now inv XX. + destruct d as [? [|] ?]; simpl; wf; + unfold wf_decl, mkLambda_or_LetIn in *; simpl in *. + constructor; intuition auto. + constructor; intuition auto. Qed. +Lemma wf_it_mkLambda_or_LetIn {Γ t} : + Forall wf_decl Γ -> + Ast.wf t -> + Ast.wf (it_mkLambda_or_LetIn Γ t). +Proof. + intros wfΓ wft; induction wfΓ in t, wft |- *; simpl. + - trivial. + - apply IHwfΓ. now apply wf_Lambda_or_LetIn. +Qed. -Lemma typing_wf_gen {cf:checker_flags} : env_prop (fun Σ Γ t T => Ast.wf t /\ Ast.wf T). +Lemma typing_wf_gen {cf:checker_flags} : + env_prop + (fun Σ Γ t T => Ast.wf t /\ Ast.wf T) + (fun Σ Γ wfΓ => Forall wf_decl Γ). Proof. apply typing_ind_env; intros; auto with wf; specialize_goal; try solve [split; try constructor; intuition auto with wf]. + - eapply All_local_env_wf_decls. + induction X; constructor; auto; red; intuition auto. - split; wf. apply wf_lift. - pose proof (nth_error_All_local_env_over H X) as XX. - cbn in XX. - destruct decl as [na [body|] ty]; simpl in *; intuition auto. + pose proof (nth_error_forall H H0) as XX. + apply XX. - split. constructor; auto. wf. clear H0 H1 X. induction X0. wf. constructor. wf. @@ -494,25 +814,30 @@ Proof. clear H0 H1 X. induction X0. wf. apply IHX0. constructor. wf. apply wf_subst. wf. wf. now inv H. - - split. wf. apply wf_subst_instance_constr. wf. - red in H. - eapply lookup_on_global_env in H as [Σ' [wfΣ' prf]]; eauto. - red in prf. destruct decl; destruct cst_body; red in prf; simpl in *; wf. + - split. wf. apply wf_subst_instance. wf. + eapply lookup_on_global_env in X as [Σ' [wfΣ' prf]]; eauto. + red in prf. destruct decl; destruct cst_body0; red in prf; simpl in *; wf. destruct prf. apply a. - - split. wf. apply wf_subst_instance_constr. + - split. wf. apply wf_subst_instance. eapply declared_inductive_wf; eauto. - split. wf. unfold type_of_constructor. - apply wf_subst; auto with wf. apply wf_subst_instance_constr. + apply wf_subst; auto with wf. apply wf_subst_instance. eapply declared_constructor_wf; eauto. - - split. wf. constructor; eauto. solve_all. - apply wf_mkApps. wf. solve_all. apply wf_mkApps_inv in H8. solve_all. - apply All_app_inv; solve_all. now apply All_skipn. + - destruct H3 as [wfret wps]. + destruct H6 as [wfc wfapps]. + eapply wf_mkApps_inv in wfapps. + eapply Forall_app in wfapps as [wfp wfindices]. + assert (Forall wf_decl predctx). + { now apply Forall_app in H4 as [? ?]. } + split; [constructor; simpl; auto; solve_all|]. + apply wf_mkApps. subst ptm. wf. apply wf_it_mkLambda_or_LetIn; auto. + apply app_Forall; auto. - split. wf. apply wf_subst. solve_all. constructor. wf. - apply wf_mkApps_inv in H2. apply All_rev. solve_all. + apply wf_mkApps_inv in H3. apply All_rev. solve_all. subst ty. eapply declared_projection_wf in isdecl; eauto. - now eapply wf_subst_instance_constr. + now eapply wf_subst_instance. - subst types. clear H. @@ -520,79 +845,28 @@ Proof. + constructor. solve_all. destruct a. intuition. - + eapply All_nth_error in X0; eauto. destruct X0 as [s ?]; intuition. + + eapply All_nth_error in X; eauto. destruct X as [s ?]; intuition. - subst types. split. + constructor. solve_all. destruct a. intuition. - + eapply All_nth_error in X0; eauto. destruct X0 as [s ?]; intuition. + + eapply All_nth_error in X; eauto. destruct X as [s ?]; intuition. Qed. Lemma typing_all_wf_decl {cf:checker_flags} Σ (wfΣ : wf Σ.1) Γ (wfΓ : wf_local Σ Γ) : Forall wf_decl Γ. Proof. - induction wfΓ. - - constructor. - - constructor; auto. red. simpl. split; wf. - destruct t0 as [u t0]. - apply typing_wf_gen in t0; eauto. apply t0; auto. - - constructor; auto. red; simpl. apply typing_wf_gen in t1; auto. - intuition auto. + eapply (env_prop_wf_local typing_wf_gen); eauto. Qed. Hint Resolve typing_all_wf_decl : wf. -Lemma on_global_env_impl `{checker_flags} Σ P Q : - (forall Σ Γ t T, on_global_env P Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) -> - on_global_env P Σ -> on_global_env Q Σ. -Proof. - intros X X0. - simpl in *. induction X0; constructor; auto. - clear IHX0. destruct d; simpl. - - destruct c; simpl. destruct cst_body; simpl in *. - red in o |- *. simpl in *. now eapply X. - red in o |- *. simpl in *. now eapply X. - - simpl in *. - destruct o0 as [onI onP onNP]. - constructor; auto. - -- eapply Alli_impl. exact onI. eauto. intros. - refine {| ind_indices := X1.(ind_indices); - ind_arity_eq := X1.(ind_arity_eq); - ind_cshapes := X1.(ind_cshapes) |}. - --- apply onArity in X1. unfold on_type in *; simpl in *. - now eapply X. - --- pose proof X1.(onConstructors) as X11. red in X11. - eapply All2_impl; eauto. - simpl. intros. destruct X2 as [? ? ? ?]; unshelve econstructor; eauto. - * apply X; eauto. - * clear -X0 X on_cargs. revert on_cargs. - generalize (cshape_args y), (cshape_sorts y). - induction c; destruct l; simpl; auto; - destruct a as [na [b|] ty]; simpl in *; auto; - split; intuition eauto. - * clear -X0 X on_cindices. - revert on_cindices. - generalize (List.rev (lift_context #|cshape_args y| 0 (ind_indices X1))). - generalize (cshape_indices y). - induction 1; simpl; constructor; auto. - --- simpl; intros. apply (onProjections X1 H0). - --- destruct X1. simpl. unfold check_ind_sorts in *. - destruct Universe.is_prop; auto. - destruct Universe.is_sprop; auto. - split. apply ind_sorts. destruct indices_matter; auto. - eapply type_local_ctx_impl. eapply ind_sorts. auto. - --- apply (onIndices X1). - -- red in onP. red. - eapply All_local_env_impl. eauto. - intros. now apply X. -Qed. - Lemma typing_wf_sigma {cf:checker_flags} Σ (wfΣ : wf Σ) : on_global_env (fun _ => wf_decl_pred) Σ. Proof. intros. - pose proof (env_prop_sigma _ typing_wf_gen _ wfΣ). red in X. + pose proof (env_prop_sigma typing_wf_gen _ wfΣ). red in X. unfold lift_typing in X. do 2 red in wfΣ. eapply on_global_env_impl; eauto; simpl; intros. destruct T. red. apply X1. red. destruct X1 as [x [a wfs]]. split; auto. @@ -651,7 +925,7 @@ Proof. eapply IHparams ; try exact e ; try assumption. constructor ; assumption. Qed. - +(* Lemma wf_instantiate_params : forall params args t t', Forall wf_decl params -> @@ -668,18 +942,18 @@ Proof. apply wf_instantiate_params_subst_ctx in eq as h2 ; trivial. - eapply wf_subst ; trivial. - eapply rev_Forall. assumption. -Qed. +Qed. *) Record wf_inductive_body idecl := { wf_ind_type : Ast.wf (ind_type idecl); - wf_ind_ctors : Forall (fun cdecl => Ast.wf (cdecl_type cdecl)) (ind_ctors idecl); + wf_ind_ctors : Forall (fun cdecl => Ast.wf (cstr_type cdecl)) (ind_ctors idecl); wf_ind_projs : Forall (fun pdecl => Ast.wf pdecl.2) (ind_projs idecl) }. Lemma declared_minductive_declared {cf:checker_flags} {Σ : global_env_ext} {mind} {mdecl} : wf Σ.1 -> declared_minductive Σ mind mdecl -> - (Alli (fun i decl => declared_inductive Σ mdecl {| inductive_mind := mind; inductive_ind := i |} decl) + (Alli (fun i decl => declared_inductive Σ {| inductive_mind := mind; inductive_ind := i |} mdecl decl) 0 (ind_bodies mdecl)). Proof. intros; eapply forall_nth_error_Alli. intros; split; auto. @@ -688,9 +962,9 @@ Qed. Lemma declared_inductive_declared {cf:checker_flags} {Σ : global_env_ext} {ind mdecl idecl} : wf Σ.1 -> - declared_inductive Σ mdecl ind idecl -> - (Alli (fun i decl => declared_constructor Σ mdecl idecl (ind, i) decl) 0 (ind_ctors idecl)) * - (Alli (fun i decl => declared_projection Σ mdecl idecl ((ind, ind_npars mdecl), i) decl) 0 (ind_projs idecl)). + declared_inductive Σ ind mdecl idecl -> + (Alli (fun i decl => declared_constructor Σ (ind, i) mdecl idecl decl) 0 (ind_ctors idecl)) * + (Alli (fun i decl => declared_projection Σ ((ind, ind_npars mdecl), i) mdecl idecl decl) 0 (ind_projs idecl)). Proof. intros; split; eapply forall_nth_error_Alli; intros; split; auto. Qed. diff --git a/template-coq/theories/UnivSubst.v b/template-coq/theories/UnivSubst.v index 19838d06e..9e4bdaac2 100644 --- a/template-coq/theories/UnivSubst.v +++ b/template-coq/theories/UnivSubst.v @@ -1,141 +1,97 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq Require Import utils Ast AstUtils Induction LiftSubst. +From MetaCoq Require Import utils Ast AstUtils Environment Induction LiftSubst. (** * Universe substitution Substitution of universe levels for universe level variables, used to implement universe polymorphism. *) +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. -Instance subst_instance_constr : UnivSubst term := - fix subst_instance_constr u c {struct c} : term := - match c with - | tRel _ | tVar _ | tInt _ | tFloat _ => c - | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) - | tSort s => tSort (subst_instance_univ u s) - | tConst c u' => tConst c (subst_instance_instance u u') - | tInd i u' => tInd i (subst_instance_instance u u') - | tConstruct ind k u' => tConstruct ind k (subst_instance_instance u u') - | tLambda na T M => tLambda na (subst_instance_constr u T) (subst_instance_constr u M) - | tApp f v => tApp (subst_instance_constr u f) (List.map (subst_instance_constr u) v) - | tProd na A B => tProd na (subst_instance_constr u A) (subst_instance_constr u B) - | tCast c kind ty => tCast (subst_instance_constr u c) kind (subst_instance_constr u ty) - | tLetIn na b ty b' => tLetIn na (subst_instance_constr u b) (subst_instance_constr u ty) - (subst_instance_constr u b') - | tCase ind p c brs => - let brs' := List.map (on_snd (subst_instance_constr u)) brs in - tCase ind (subst_instance_constr u p) (subst_instance_constr u c) brs' - | tProj p c => tProj p (subst_instance_constr u c) - | tFix mfix idx => - let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in - tFix mfix' idx - | tCoFix mfix idx => - let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in - tCoFix mfix' idx - end. - -Instance subst_instance_decl : UnivSubst context_decl - := map_decl ∘ subst_instance_constr. - -Instance subst_instance_context : UnivSubst context - := map_context ∘ subst_instance_constr. - -Lemma lift_subst_instance_constr u c n k : - lift n k (subst_instance_constr u c) = subst_instance_constr u (lift n k c). +Lemma subst_instance_lift u c n k : + lift n k (subst_instance u c) = subst_instance u (lift n k c). 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; - try solve [f_equal; eauto; solve_all; eauto]. + rewrite ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + ?map_predicate_map_predicate, ?map_predicate_subst_instance_predicate, + ?map_branch_map_branch; + f_equal; eauto; solve_all; eauto. Qed. -Lemma subst_instance_constr_mkApps u f a : - subst_instance_constr u (mkApps f a) = - mkApps (subst_instance_constr u f) (map (subst_instance_constr u) a). +Lemma subst_instance_mkApps u f a : + subst_instance u (mkApps f a) = + mkApps (subst_instance u f) (map (subst_instance u) a). Proof. + unfold subst_instance; cbn. induction a in f |- *; auto. simpl map. simpl. destruct f; try reflexivity. - simpl. f_equal. rewrite map_app. reflexivity. + simpl; now rewrite map_app. Qed. -Lemma subst_instance_constr_it_mkProd_or_LetIn u ctx t : - subst_instance_constr u (it_mkProd_or_LetIn ctx t) = - it_mkProd_or_LetIn (subst_instance_context u ctx) (subst_instance_constr u t). +Lemma subst_instance_it_mkProd_or_LetIn u ctx t : + subst_instance u (it_mkProd_or_LetIn ctx t) = + it_mkProd_or_LetIn (subst_instance u ctx) (subst_instance u t). Proof. induction ctx in u, t |- *; simpl; try congruence. rewrite IHctx. unfold mkProd_or_LetIn; cbn. f_equal. destruct (decl_body a); eauto. Qed. -Lemma subst_instance_context_length u ctx - : #|subst_instance_context u ctx| = #|ctx|. +Lemma subst_instance_length u ctx + : #|subst_instance u ctx| = #|ctx|. Proof. - unfold subst_instance_context, map_context. + unfold subst_instance, subst_instance_context, map_context; simpl. now rewrite map_length. Qed. -Lemma subst_subst_instance_constr u c N k : - subst (map (subst_instance_constr u) N) k (subst_instance_constr u c) = - subst_instance_constr u (subst N k c). +Lemma subst_instance_subst u c N k : + subst (map (subst_instance u) N) k (subst_instance u c) = + subst_instance u (subst N k c). 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]. - elim (Nat.leb k n). rewrite nth_error_map. - destruct (nth_error N (n - k)). simpl. - apply lift_subst_instance_constr. reflexivity. reflexivity. - - rewrite subst_instance_constr_mkApps. f_equal; auto. - rewrite map_map_compose. solve_all. + - 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. -Lemma map_subst_instance_constr_to_extended_list_k u ctx k : - map (subst_instance_constr u) (to_extended_list_k ctx k) +Lemma map_subst_instance_to_extended_list_k u ctx k : + map (subst_instance u) (to_extended_list_k ctx k) = to_extended_list_k ctx k. Proof. pose proof (to_extended_list_k_spec ctx k). solve_all. now destruct H as [n [-> _]]. Qed. -(** Tests that the term is closed over [k] universe variables *) -Fixpoint closedu (k : nat) (t : term) : bool := - match t with - | tSort univ => closedu_universe k univ - | tInd _ u => closedu_instance k u - | tConstruct _ _ u => closedu_instance k u - | tConst _ u => closedu_instance k u - | tRel i => true - | tEvar ev args => forallb (closedu k) args - | tLambda _ T M | tProd _ T M => closedu k T && closedu k M - | tApp u v => closedu k u && forallb (closedu k) v - | tCast c kind t => closedu k c && closedu k t - | tLetIn na b t b' => closedu k b && closedu k t && closedu k b' - | tCase ind p c brs => - let brs' := forallb (test_snd (closedu k)) brs in - closedu k p && closedu k c && brs' - | tProj p c => closedu k c - | tFix mfix idx => - forallb (test_def (closedu k) (closedu k)) mfix - | tCoFix mfix idx => - forallb (test_def (closedu k) (closedu k)) mfix - | x => true - end. - -Lemma closedu_subst_instance_constr u t - : closedu 0 t -> subst_instance_constr u t = t. +Lemma closedu_subst_instance u t + : closedu 0 t -> subst_instance u t = t. Proof. + unfold subst_instance; cbn. induction t in |- * using term_forall_list_ind; simpl; auto; intros H'; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; - try f_equal; eauto with substu; unfold test_def in *; - try solve [f_equal; eauto; repeat (rtoProp; solve_all)]. + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + ?map_predicate_map_predicate, ?map_branch_map_branch; + try f_equal; eauto with substu; unfold test_def, test_predicate in *; + try solve [f_equal; eauto; repeat (rtoProp; solve_all; eauto with substu)]. Qed. -Lemma subst_instance_constr_closedu (u : Instance.t) (Hcl : closedu_instance 0 u) t : - closedu #|u| t -> closedu 0 (subst_instance_constr u t). +Lemma subst_instance_closedu (u : Instance.t) (Hcl : closedu_instance 0 u) t : + closedu #|u| t -> closedu 0 (subst_instance u t). Proof. induction t in |- * using term_forall_list_ind; simpl; auto; intros H'; - rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?forallb_map; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?forallb_map, + ?map_predicate_map_predicate; try f_equal; auto with substu; - unfold test_def, map_def in *; + unfold test_def, test_predicate in *; simpl; try solve [f_equal; eauto; repeat (rtoProp; solve_all); intuition auto with substu]. Qed. diff --git a/template-coq/theories/Universes.v b/template-coq/theories/Universes.v index 6c4bc0004..44022c929 100644 --- a/template-coq/theories/Universes.v +++ b/template-coq/theories/Universes.v @@ -1768,8 +1768,8 @@ Section UniverseClosedSubst. apply UnivExprSet.for_all_spec in H; proper. now apply H. Qed. - Lemma closedu_subst_instance_instance u t - : closedu_instance 0 t -> subst_instance_instance u t = t. + Lemma closedu_subst_instance u t + : closedu_instance 0 t -> subst_instance u t = t. Proof. intro H. apply forall_map_id_spec. apply Forall_forall; intros l Hl. @@ -1780,7 +1780,7 @@ Section UniverseClosedSubst. End UniverseClosedSubst. Hint Resolve closedu_subst_instance_level closedu_subst_instance_level_expr - closedu_subst_instance_univ closedu_subst_instance_instance : substu. + closedu_subst_instance_univ closedu_subst_instance : substu. (** Substitution of a universe-closed instance of the right size produces a universe-closed term. *) @@ -1821,8 +1821,8 @@ Section SubstInstanceClosed. now apply H. Qed. - Lemma subst_instance_instance_closedu t : - closedu_instance #|u| t -> closedu_instance 0 (subst_instance_instance u t). + Lemma subst_instance_closedu t : + closedu_instance #|u| t -> closedu_instance 0 (subst_instance u t). Proof. intro H. etransitivity. eapply forallb_map. eapply forallb_impl; tea. @@ -1831,7 +1831,7 @@ Section SubstInstanceClosed. End SubstInstanceClosed. Hint Resolve subst_instance_level_closedu subst_instance_level_expr_closedu - subst_instance_univ_closedu subst_instance_instance_closedu : substu. + subst_instance_univ_closedu subst_instance_closedu : substu. Definition string_of_level (l : Level.t) : string := diff --git a/template-coq/theories/WcbvEval.v b/template-coq/theories/WcbvEval.v index 6aa05b0b9..1e55cdb8c 100644 --- a/template-coq/theories/WcbvEval.v +++ b/template-coq/theories/WcbvEval.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import CRelationClasses. -From MetaCoq.Template Require Import config utils Ast AstUtils Reflect LiftSubst MCList +From MetaCoq.Template Require Import config utils Environment Ast AstUtils Reflect LiftSubst MCList UnivSubst WfInv Typing. Require Import ssreflect ssrbool. @@ -71,7 +71,7 @@ Definition isConstruct t := | _ => false end. -Definition isAssRel Γ x := +Definition isAssRel (Γ : context) x := match x with | tRel i => match option_map decl_body (nth_error Γ i) with @@ -141,7 +141,7 @@ Section Wcbv. (** Constant unfolding *) | eval_delta c decl body (isdecl : declared_constant Σ c decl) u res : decl.(cst_body) = Some body -> - eval (subst_instance_constr u body) res -> + eval (subst_instance u body) res -> eval (tConst c u) res (** Axiom *) @@ -150,17 +150,17 @@ Section Wcbv. eval (tConst c u) (tConst c u) (** Case *) - | eval_iota ind pars r discr c u args p brs res : - eval discr (mkApps (tConstruct ind c u) args) -> - eval (iota_red pars c args brs) res -> - eval (tCase ((ind, pars), r) p discr brs) res + | eval_iota ci discr c u args p brs res : + eval discr (mkApps (tConstruct ci.(ci_ind) c u) args) -> + eval (iota_red ci.(ci_npar) c args brs) res -> + eval (tCase ci p discr brs) res (** Proj *) - | eval_proj i pars arg discr args u a res : - eval discr (mkApps (tConstruct i 0 u) args) -> - nth_error args (pars + arg) = Some a -> + | eval_proj indnpararg discr args u a res : + eval discr (mkApps (tConstruct indnpararg.1.1 0 u) args) -> + nth_error args (indnpararg.1.2 + indnpararg.2) = Some a -> eval a res -> - eval (tProj (i, pars, arg) discr) res + eval (tProj indnpararg discr) res (** Fix unfolding, with guard *) | eval_fix f mfix idx fixargsv args argsv narg fn res : @@ -228,19 +228,24 @@ Section Wcbv. declared_constant Σ c decl -> forall (u : Instance.t) (res : term), cst_body decl = Some body -> - eval (subst_instance_constr u body) res -> P (subst_instance_constr u body) res -> P (tConst c u) res) -> + eval (subst_instance u body) res -> P (subst_instance u body) res -> P (tConst c u) res) -> (forall c (decl : constant_body), declared_constant Σ c decl -> forall u : Instance.t, cst_body decl = None -> P (tConst c u) (tConst c u)) -> - (forall (ind : inductive) (pars : nat) r (discr : term) (c : nat) (u : Instance.t) - (args : list term) (p : term) (brs : list (nat × term)) (res : term), + (forall ci (discr : term) (c : nat) (u : Instance.t) + (args : list term) (p : predicate term) (brs : list (branch term)) (res : term), + let ind := ci.(ci_ind) in + let npar := ci.(ci_npar) in eval discr (mkApps (tConstruct ind c u) args) -> P discr (mkApps (tConstruct ind c u) args) -> - eval (iota_red pars c args brs) res -> P (iota_red pars c args brs) res -> P (tCase ((ind, pars), r) p discr brs) res) -> - (forall (i : inductive) (pars arg : nat) (discr : term) (args : list term) (u : Instance.t) + eval (iota_red npar c args brs) res -> P (iota_red npar c args brs) res -> + P (tCase ci p discr brs) res) -> + (forall (indnpararg : ((inductive × nat) × nat)) (discr : term) (args : list term) (u : Instance.t) (a res : term), - eval discr (mkApps (tConstruct i 0 u) args) -> - P discr (mkApps (tConstruct i 0 u) args) -> - nth_error args (pars + arg) = Some a -> eval a res -> P a res -> P (tProj (i, pars, arg) discr) res) -> + eval discr (mkApps (tConstruct indnpararg.1.1 0 u) args) -> + P discr (mkApps (tConstruct indnpararg.1.1 0 u) args) -> + nth_error args (indnpararg.1.2 + indnpararg.2) = Some a -> + eval a res -> P a res -> + P (tProj indnpararg discr) res) -> (forall (f : term) (mfix : mfixpoint term) (idx : nat) (fixargsv args argsv : list term) (narg : nat) (fn res : term), eval f (mkApps (tFix mfix idx) fixargsv) -> @@ -261,8 +266,9 @@ Section Wcbv. unfold_fix mfix idx = Some (narg, fn) -> ~~ is_constructor narg (fixargsv ++ argsv) -> P (mkApps f args) (mkApps (tFix mfix idx) (fixargsv ++ argsv))) -> - (forall (ip : (inductive × nat) × relevance) (mfix : mfixpoint term) (idx : nat) (p : term) (args : list term) - (narg : nat) (fn : term) (brs : list (nat × term)) (res : term), + (forall (ip : case_info) (mfix : mfixpoint term) (idx : nat) + (p : predicate term) (args : list term) + (narg : nat) (fn : term) (brs : list (branch term)) (res : term), unfold_cofix mfix idx = Some (narg, fn) -> eval (tCase ip p (mkApps fn args) brs) res -> P (tCase ip p (mkApps fn args) brs) res -> P (tCase ip p (mkApps (tCoFix mfix idx) args) brs) res) -> @@ -583,7 +589,7 @@ Section Wcbv. eval (tConst c u) v -> ∑ decl, declared_constant Σ c decl * match cst_body decl with - | Some body => eval (subst_instance_constr u body) v + | Some body => eval (subst_instance u body) v | None => v = tConst c u end. Proof. @@ -789,7 +795,7 @@ Tactic Notation "redt" uconstr(y) := eapply (transitivity (R:=red _ _) (y:=y)). (* eapply red1_red. econstructor. *) (* auto. *) -(* - redt (subst_instance_constr u body); auto. *) +(* - redt (subst_instance u body); auto. *) (* eapply red1_red. econstructor; eauto. *) (* - redt (tCase (ind, pars) p _ brs). *) diff --git a/template-coq/theories/WfInv.v b/template-coq/theories/WfInv.v index 9fff63947..1be40b27e 100644 --- a/template-coq/theories/WfInv.v +++ b/template-coq/theories/WfInv.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import ssreflect ssrbool. -From MetaCoq.Template Require Import config utils Ast AstUtils. +From MetaCoq.Template Require Import config utils Ast AstUtils Environment. (** * Inversion lemmas for the well-formedness judgement *) @@ -15,7 +15,7 @@ Fixpoint wf_Inv (t : term) := | tLetIn na t b b' => wf t /\ wf b /\ wf b' | tApp t u => isApp t = false /\ u <> nil /\ wf t /\ Forall wf u | tConst _ _ | tInd _ _ | tConstruct _ _ _ => True - | tCase ci p c brs => wf p /\ wf c /\ Forall (wf ∘ snd) brs + | tCase ci p c brs => Forall wf (pparams p) /\ wf (preturn p) /\ wf c /\ Forall (wf ∘ bbody) brs | tProj p t => wf t | tFix mfix k => Forall (fun def => wf def.(dtype) /\ wf def.(dbody)) mfix | tCoFix mfix k => Forall (fun def => wf def.(dtype) /\ wf def.(dbody)) mfix @@ -59,7 +59,7 @@ Proof. induction l; simpl; auto. Qed. -Fixpoint wf_term (t : term) : bool := +(* Fixpoint wf_term (t : term) : bool := match t with | tRel _ | tVar _ | tInt _ | tFloat _ => true | tEvar n l => forallb wf_term l @@ -70,13 +70,14 @@ Fixpoint wf_term (t : term) : bool := | tLetIn na t b b' => wf_term t && wf_term b && wf_term b' | tApp t u => ~~ isApp t && ~~ is_empty u && wf_term t && forallb wf_term u | tConst _ _ | tInd _ _ | tConstruct _ _ _ => true - | tCase ci p c brs => wf_term p && wf_term c && forallb (wf_term ∘ snd) brs + | tCase ci p c brs => forallb wf_term (pparams p) && wf_term (preturn p) + && wf_term c && forallb (wf_term ∘ snd) brs | tProj p t => wf_term t | tFix mfix k => forallb (fun def => wf_term def.(dtype) && wf_term def.(dbody) && isLambda def.(dbody)) mfix | tCoFix mfix k => forallb (fun def => wf_term def.(dtype) && wf_term def.(dbody)) mfix - end. + end. *) Lemma mkApps_tApp f args : ~~ isApp f -> @@ -86,7 +87,7 @@ Proof. intros. destruct args, f; try discriminate; auto. Qed. - +(* Lemma decompose_app_inv' f l hd args : wf_term f -> decompose_app (mkApps f l) = (hd, args) -> ∑ n, ~~ isApp hd /\ l = skipn n args /\ f = mkApps hd (firstn n args). @@ -107,9 +108,9 @@ Proof. rewrite decompose_app_mkApps in fl; auto. now apply negbT. inversion fl. subst; exists 0. split; auto. now eapply negbT. -Qed. +Qed. *) -Lemma mkApps_elim t l : wf_term t -> +(* Lemma mkApps_elim t l : wf_term t -> let app' := decompose_app (mkApps t l) in mkApps_spec app'.1 app'.2 t l (mkApps t l). Proof. @@ -120,7 +121,7 @@ Proof. subst t. have H' := mkApps_intro hd args x. rewrite Hl'. rewrite mkApps_nested. now rewrite firstn_skipn. -Qed. +Qed. *) Lemma nApp_mkApps {t l} : ~~ isApp (mkApps t l) -> ~~ isApp t /\ l = []. Proof. diff --git a/template-coq/theories/monad_utils.v b/template-coq/theories/monad_utils.v index dc52a1d9a..6c2d10eb1 100644 --- a/template-coq/theories/monad_utils.v +++ b/template-coq/theories/monad_utils.v @@ -54,6 +54,15 @@ Instance option_monad : Monad option := | None => None end |}. + +Instance option_monad_exc : MonadExc unit option := +{| raise T _ := None ; + catch T m f := + match m with + | Some a => Some a + | None => f tt + end +|}. Open Scope monad. @@ -108,6 +117,19 @@ Section MonadOperations. Definition monad_map_i := @monad_map_i_aux 0. End MonadOperations. +Section MonadOperations. + Context {T} {M : Monad T} {E} {ME : MonadExc E T}. + Context {A B C} (f : A -> B -> T C) (e : E). + 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' <- f x y ;; + xs' <- monad_map2 l l' ;; + ret (x' :: xs') + | _, _ => raise e + end. +End MonadOperations. Definition monad_iter {T : Type -> Type} {M A} (f : A -> T unit) (l : list A) : T unit := @monad_fold_left T M _ _ (fun _ => f) l tt. diff --git a/template-coq/theories/utils/All_Forall.v b/template-coq/theories/utils/All_Forall.v index f1ce69c67..33e0edc1e 100644 --- a/template-coq/theories/utils/All_Forall.v +++ b/template-coq/theories/utils/All_Forall.v @@ -1,5 +1,5 @@ -From Coq Require Import List Bool Arith ssreflect Lia. -From MetaCoq.Template Require Import MCPrelude MCList MCRelations MCProd MCOption. +From Coq Require Import List Bool Arith ssreflect Morphisms Lia. +From MetaCoq.Template Require Import MCPrelude MCReflect MCList MCRelations MCProd MCOption. From Equations Require Import Equations. Import ListNotations. @@ -12,6 +12,7 @@ Inductive All {A} (P : A -> Type) : list A -> Type := All_nil : All P [] | All_cons : forall (x : A) (l : list A), P x -> All P l -> All P (x :: l). +Arguments All {A} P%type _. Arguments All_nil {_ _}. Arguments All_cons {_ _ _ _}. Derive Signature NoConfusion for All. @@ -33,14 +34,130 @@ Arguments All2_cons {_ _ _ _ _ _ _}. Derive Signature for All2. Derive NoConfusionHom for All2. -Fixpoint alli {A} (p : nat -> A -> bool) (l : list A) (n : nat) : bool := +Inductive All2i {A B : Type} (R : nat -> A -> B -> Type) (n : nat) + : list A -> list B -> Type := +| All2i_nil : All2i R n [] [] +| All2i_cons : + forall x y l r, + R n x y -> + All2i R (S n) l r -> + All2i R n (x :: l) (y :: r). +Arguments All2i_nil {_ _ _ _}. +Arguments All2i_cons {_ _ _ _ _ _ _ _}. + +Derive Signature NoConfusionHom for All2i. + +Inductive All3 {A B C : Type} (R : A -> B -> C -> Type) : list A -> list B -> list C -> Type := + All3_nil : All3 R [] [] [] +| All3_cons : forall (x : A) (y : B) (z : C) (l : list A) (l' : list B) (l'' : list C), + R x y z -> All3 R l l' l'' -> All3 R (x :: l) (y :: l') (z :: l''). +Arguments All3_nil {_ _ _ _}. +Arguments All3_cons {_ _ _ _ _ _ _ _ _ _}. +Derive Signature NoConfusionHom for All3. + +Section alli. + Context {A} (p : nat -> A -> bool). + Fixpoint alli (n : nat) (l : list A) : bool := match l with | [] => true - | hd :: tl => p n hd && alli p tl (S n) + | hd :: tl => p n hd && alli (S n) tl end. +End alli. + +Lemma alli_ext {A} (p q : nat -> A -> bool) n (l : list A) : + (forall i, p i =1 q i) -> + alli p n l = alli q n l. +Proof. + intros hfg. + induction l in n |- *; simpl; auto. + now rewrite IHl. +Qed. + +Instance alli_proper {A} : + Proper ((pointwise_relation nat (pointwise_relation A eq)) ==> eq ==> eq ==> eq) alli. +Proof. + intros f g fg. + intros ? ? -> ? ? ->. + now apply alli_ext. +Qed. + +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. + intros hpq. induction l in n |- *; simpl; auto. + move/andb_and => [pna a']. + rewrite (hpq _ _ pna). + now apply IHl. +Qed. + +Lemma allbiP {A} (P : nat -> A -> Type) (p : nat -> A -> bool) n l : + (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. + move/andb_and => [pa pl]. + constructor; auto. now destruct (Hp n a). +Qed. + +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). + - intros. destruct (p i x); now constructor. + - split; eauto. + - split; eauto. by []. +Qed. + +Lemma alli_shiftn {A} n k p (l : list A) : + alli p (n + k) l = alli (fun i => p (n + i)) k l. +Proof. + induction l in n, k, p |- *; simpl; auto. f_equal. + rewrite (IHl (S n) k p) (IHl 1 k _). + apply alli_ext => x. + now rewrite Nat.add_succ_r. +Qed. + +Section alli. + Context {A} (p q : nat -> A -> bool) (l l' : list A). + + Lemma alli_app n : + alli p n (l ++ l') = + alli p n l && alli p (#|l| + n) l'. + Proof. + induction l in n |- *; simpl; auto. + now rewrite IHl0 Nat.add_succ_r andb_assoc. + Qed. + + Lemma alli_shift n : + alli p n l = alli (fun i => p (n + i)) 0 l. + Proof. + induction l in n, p |- *; simpl; auto. + rewrite IHl0 (IHl0 _ 1) Nat.add_0_r. + f_equal. apply alli_ext => x. + now rewrite Nat.add_succ_r. + Qed. + + Lemma alli_map {B} (f : B -> A) n bs : alli p n (map f bs) = alli (fun i => p i ∘ f) n bs. + Proof. + induction bs in n |- *; simpl; auto. + now rewrite IHbs. + Qed. +End alli. + +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. + now rewrite IHl. +Qed. Section Forallb2. - Context {A} (f : A -> A -> bool). + Context {A B} (f : A -> B -> bool). Fixpoint forallb2 l l' := match l, l' with @@ -63,16 +180,14 @@ Proof. Qed. Lemma forallb2_map : - forall A B (R : A -> A -> bool) f g (l : list B) (l' : list B), - forallb2 (fun x y => R (f x) (g y)) l l' -> - forallb2 R (map f l) (map g l'). + forall A B C D (R : A -> B -> bool) f g (l : list C) (l' : list D), + forallb2 R (map f l) (map g l') = + forallb2 (fun x y => R (f x) (g y)) l l'. Proof. - intros A B R f g l l' h. - induction l in l', h |- *. - - destruct l'. 2: discriminate. reflexivity. - - destruct l'. 1: discriminate. simpl in *. - apply andb_true_iff in h as [e1 e2]. rewrite e1. simpl. - eapply IHl. assumption. + intros A B C D R f g l l'. + induction l in l' |- *. + - destruct l' => //. + - destruct l' => /= //; rewrite IHl //. Qed. Lemma forall_map_spec {A B} {l} {f g : A -> B} : @@ -114,6 +229,18 @@ Proof. constructor; auto. now destruct (Hp a). Qed. +Lemma forallb_ext {A} (p q : A -> bool) : p =1 q -> forallb p =1 forallb q. +Proof. + intros hpq l. + induction l; simpl; auto. + now rewrite (hpq a) IHl. +Qed. + +Instance forallb_proper {A} : Proper (`=1` ==> eq ==> eq) (@forallb A). +Proof. + intros f g Hfg ? ? ->. now apply forallb_ext. +Qed. + 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). @@ -126,6 +253,27 @@ Proof. constructor; auto. now destruct (Hp _ H). 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. + induction l in n, Hnth, HPl |- * => //. + - rewrite nth_error_nil in Hnth => //. + - destruct n => /=; noconf Hnth. + * now move: HPl => /= /andb_and. + * eapply IHl; tea. now move: HPl => /andb_and. +Qed. + +Lemma forallb_nth_error {A} P l n : + @forallb A P l -> on_Some_or_None P (nth_error l n). +Proof. + induction l in n |- *. + - intros _. destruct n; constructor. + - intro H. apply forallb_Forall in H. + inv H. destruct n; cbn; auto. + now apply forallb_Forall in H1; eauto. +Qed. + Lemma map_eq_inj {A B} (f g : A -> B) l: map f l = map g l -> All (fun x => f x = g x) l. Proof. @@ -161,8 +309,8 @@ Proof. - constructor; auto. Qed. -Lemma forallb2_All2 {A : Type} {p : A -> A -> bool} - {l l' : list A} : +Lemma forallb2_All2 {A B : Type} {p : A -> B -> bool} + {l : list A} {l' : list B}: is_true (forallb2 p l l') -> All2 (fun x y => is_true (p x y)) l l'. Proof. induction l in l' |- *; destruct l'; simpl; intros; try congruence. @@ -171,15 +319,21 @@ Proof. apply IHl. revert H; rewrite andb_and; intros [px pl]. auto. Qed. -Lemma All2_forallb2 {A : Type} {p : A -> A -> bool} - {l l' : list A} : +Lemma All2_forallb2 {A B : Type} {p : A -> B -> bool} + {l : list A} {l' : list B} : All2 (fun x y => is_true (p x y)) l l' -> is_true (forallb2 p l l'). Proof. induction 1; simpl; intros; try congruence. rewrite andb_and. intuition auto. Qed. -Lemma forallb2_app {A} (p : A -> A -> bool) l l' q q' : +Lemma All2P {A B : Type} {p : A -> B -> bool} {l l'} : + reflectT (All2 p l l') (forallb2 p l l'). +Proof. + apply equiv_reflectT. apply All2_forallb2. apply forallb2_All2. +Qed. + +Lemma forallb2_app {A B} (p : A -> B -> bool) l l' q q' : is_true (forallb2 p l l' && forallb2 p q q') -> is_true (forallb2 p (l ++ q) (l' ++ q')). Proof. @@ -233,6 +387,33 @@ Proof. apply IHX0. inv X; intuition auto. Qed. +Lemma All2i_All_mix_left {A B} {P : A -> Type} {Q : nat -> A -> B -> Type} + {n} {l : list A} {l' : list B} : + All P l -> All2i Q n l l' -> All2i (fun i x y => (P x * Q i x y)%type) n l l'. +Proof. + induction 2; simpl; intros; constructor. + inv X; intuition auto. + apply IHX0. inv X; intuition auto. +Qed. + +Lemma All2i_All_mix_right {A B} {P : B -> Type} {Q : nat -> A -> B -> Type} + {n} {l : list A} {l' : list B} : + All P l' -> All2i Q n l l' -> All2i (fun i x y => (Q i x y * P y)%type) n l l'. +Proof. + induction 2; simpl; intros; constructor. + inv X; intuition auto. + apply IHX0. inv X; intuition auto. +Qed. + +Lemma All2i_All2_mix_left {A B} {P : A -> B -> Type} {Q : nat -> A -> B -> Type} + {n} {l : list A} {l' : list B} : + All2 P l l' -> All2i Q n l l' -> All2i (fun i x y => (P x y * Q i x y)%type) n l l'. +Proof. + induction 2; simpl; intros; constructor. + inv X; intuition auto. + apply IHX0. inv X; intuition auto. +Qed. + Lemma Forall_All {A : Type} (P : A -> Prop) l : Forall P l -> All P l. Proof. @@ -292,6 +473,22 @@ Proof. intros HF H. induction HF; constructor; eauto. Qed. +Lemma All2i_All_left {A B} {P : nat -> A -> B -> Type} {Q : A -> Type} {n l l'} : + All2i P n l l' -> + (forall i x y, P i x y -> Q x) -> + All Q l. +Proof. + intros HF H. induction HF; constructor; eauto. +Qed. + +Lemma All2i_All_right {A B} {P : nat -> A -> B -> Type} {Q : B -> Type} {n l l'} : + All2i P n l l' -> + (forall i x y, P i x y -> Q y) -> + All Q l'. +Proof. + intros HF H. induction HF; constructor; eauto. +Qed. + Lemma All2_right {A B} {P : B -> Type} {l : list A} {l'} : All2 (fun x y => P y) l l' -> All P l'. Proof. @@ -476,7 +673,6 @@ Proof. now replace (Nat.pred (#|l| + 1) - S n) with (Nat.pred #|l| - n) by lia. Qed. - Lemma Alli_app_inv {A} {P} {l l' : list A} {n} : Alli P n l -> Alli P (n + #|l|) l' -> Alli P n (l ++ l'). Proof. induction 1; simpl; auto. now rewrite Nat.add_0_r. @@ -520,7 +716,6 @@ Proof. induction 1; constructor; try inversion X0; intuition auto. Qed. - Inductive OnOne2 {A : Type} (P : A -> A -> Type) : list A -> list A -> Type := | OnOne2_hd hd hd' tl : P hd hd' -> OnOne2 P (hd :: tl) (hd' :: tl) | OnOne2_tl hd tl tl' : OnOne2 P tl tl' -> OnOne2 P (hd :: tl) (hd :: tl'). @@ -689,6 +884,404 @@ Proof. intros [= ->]. exists t'; intuition auto. Qed. + + +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. + intros HPQ. + induction 1; intros H; depelim H; constructor; auto. + now eapply HPQ. +Qed. + +Inductive OnOne2i {A : Type} (P : nat -> A -> A -> Type) : nat -> list A -> list A -> Type := +| OnOne2i_hd i hd hd' tl : P i hd hd' -> OnOne2i P i (hd :: tl) (hd' :: tl) +| OnOne2i_tl i hd tl tl' : OnOne2i P (S i) tl tl' -> OnOne2i P i (hd :: tl) (hd :: tl'). +Derive Signature NoConfusion for OnOne2i. + +Lemma OnOne2i_All_mix_left {A} {P : nat -> A -> A -> Type} {Q : A -> Type} {i l l'} : + All Q l -> OnOne2i P i l l' -> OnOne2i (fun i x y => (P i x y * Q x)%type) i l l'. +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' -> + OnOne2i P i (l ++ tl) (l ++ tl'). +Proof. induction l in i |- *; simpl; try constructor; eauto. + eapply IHl. now rewrite Nat.add_succ_r. +Qed. + +Lemma OnOne2i_app_r {A} (P : nat -> A -> A -> Type) i l l' tl : + OnOne2i P i l l' -> + OnOne2i P i (l ++ tl) (l' ++ tl). +Proof. induction 1; constructor; auto. Qed. + +Lemma OnOne2i_length {A} {P} {i} {l l' : list A} : OnOne2i P i l l' -> #|l| = #|l'|. +Proof. induction 1; simpl; congruence. Qed. + +Lemma OnOne2i_mapP {A B} {P} {i} {l l' : list A} (f : A -> B) : + OnOne2i (fun i => on_rel (P i) f) i l l' -> OnOne2i P i (map f l) (map f l'). +Proof. induction 1; simpl; constructor; try congruence. apply p. Qed. + +Lemma OnOne2i_map {A B} {P : nat -> B -> B -> Type} {i} {l l' : list A} (f : A -> B) : + OnOne2i (fun i => on_Trel (P i) f) i l l' -> OnOne2i P i (map f l) (map f l'). +Proof. induction 1; simpl; constructor; try congruence. apply p. Qed. + +Lemma OnOne2i_sym {A} (P : nat -> A -> A -> Type) i l l' : OnOne2i (fun i x y => P i y x) i l' l -> OnOne2i P i l l'. +Proof. + induction 1; constructor; auto. +Qed. + +Lemma OnOne2i_exist {A} (P : nat -> A -> A -> Type) (Q : nat -> A -> A -> Type) i l l' : + OnOne2i P i l l' -> + (forall i x y, P i x y -> ∑ z, Q i x z × Q i y z) -> + ∑ r, (OnOne2i Q i l r × OnOne2i Q i l' r). +Proof. + intros H HPQ. induction H. + - destruct (HPQ _ _ _ p). destruct p0. + now exists (x :: tl); intuition constructor. + - destruct IHOnOne2i as [r [? ?]]. + now exists (hd :: r); intuition constructor. +Qed. + +(* Induction principle on OnOne2i when the relation also depends + on one of the lists, and should not change. + *) +Lemma OnOne2i_ind_l : + forall A (R : list A -> nat -> A -> A -> Type) + (P : forall L i l l', OnOne2i (R L) i l l' -> Type), + (forall L i x y l (r : R L i x y), P L i (x :: l) (y :: l) (OnOne2i_hd _ _ _ _ l r)) -> + (forall L i x l l' (h : OnOne2i (R L) (S i) l l'), + P L (S i) l l' h -> + P L i (x :: l) (x :: l') (OnOne2i_tl _ i x _ _ h) + ) -> + forall i l l' h, P l i l l' h. +Proof. + intros A R P hhd htl i l l' h. induction h ; eauto. +Qed. + +Lemma OnOne2i_impl_exist_and_All : + forall A i (l1 l2 l3 : list A) R1 R2 R3, + OnOne2i R1 i l1 l2 -> + All2 R2 l3 l2 -> + (forall i x x' y, R1 i x y -> R2 x' y -> ∑ z : A, R3 i x z × R2 x' z) -> + ∑ l4, OnOne2i R3 i l1 l4 × All2 R2 l3 l4. +Proof. + intros A i l1 l2 l3 R1 R2 R3 h1 h2 h. + induction h1 in l3, h2 |- *. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (h _ _ _ _ p X) as hh. + destruct hh as [? [? ?]]. + eexists. constructor. + * constructor. eassumption. + * constructor ; eauto. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (IHh1 _ X0). destruct IHh1 as [? [? ?]]. + eexists. constructor. + * eapply OnOne2i_tl. eassumption. + * constructor ; eauto. +Qed. + +Lemma OnOne2i_impl_exist_and_All_r : + forall A i (l1 l2 l3 : list A) R1 R2 R3, + OnOne2i R1 i l1 l2 -> + All2 R2 l2 l3 -> + (forall i x x' y, R1 i x y -> R2 y x' -> ∑ z : A, R3 i x z × R2 z x') -> + ∑ l4, ( OnOne2i R3 i l1 l4 × All2 R2 l4 l3 ). +Proof. + intros A i l1 l2 l3 R1 R2 R3 h1 h2 h. + induction h1 in l3, h2 |- *. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (h _ _ _ _ p X) as hh. + destruct hh as [? [? ?]]. + eexists. split. + * constructor. eassumption. + * constructor ; eauto. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (IHh1 _ X0). destruct IHh1 as [? [? ?]]. + eexists. split. + * eapply OnOne2i_tl. eassumption. + * constructor ; eauto. +Qed. + +Lemma OnOne2i_split : + forall A (P : nat -> A -> A -> Type) i l l', + OnOne2i P i l l' -> + ∑ i x y u v, + P i x y × + (l = u ++ x :: v /\ + l' = u ++ y :: v). +Proof. + intros A P i l l' h. + induction h. + - exists i, hd, hd', [], tl. + intuition eauto. + - destruct IHh as [i' [x [y [u [v ?]]]]]. + exists i', x, y, (hd :: u), v. + intuition eauto. all: subst. all: reflexivity. +Qed. + +Lemma OnOne2i_impl {A} {P Q} {i} {l l' : list A} : + OnOne2i P i l l' -> + (forall i x y, P i x y -> Q i x y) -> + OnOne2i Q i l l'. +Proof. + induction 1; constructor; intuition eauto. +Qed. + +Lemma OnOne2i_nth_error {A} (l l' : list A) i n t P : + 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')). +Proof. + induction 1 in n |- *. + destruct n; simpl. + - intros [= ->]. exists hd'; rewrite Nat.add_0_r; intuition auto. + - exists t. intuition auto. + - destruct n; simpl; rewrite ?Nat.add_succ_r /=; auto. + intros [= ->]. exists t; intuition auto. + apply IHX. +Qed. + +Lemma OnOne2i_nth_error_r {A} i (l l' : list A) n t' P : + 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')). +Proof. + induction 1 in n |- *. + destruct n; simpl. + - intros [= ->]. rewrite Nat.add_0_r; exists hd; intuition auto. + - exists t'. intuition auto. + - destruct n; simpl; auto. + intros [= ->]. exists t'; intuition auto. + rewrite Nat.add_succ_r; apply IHX. +Qed. + +Inductive OnOne2All {A B : Type} (P : B -> A -> A -> Type) : list B -> list A -> list A -> Type := +| OnOne2All_hd b bs hd hd' tl : P b hd hd' -> #|bs| = #|tl| -> OnOne2All P (b :: bs) (hd :: tl) (hd' :: tl) +| OnOne2All_tl b bs hd tl tl' : OnOne2All P bs tl tl' -> OnOne2All P (b :: bs) (hd :: tl) (hd :: tl'). +Derive Signature NoConfusion for OnOne2All. + +Lemma OnOne2All_All_mix_left {A B} {P : B -> A -> A -> Type} {Q : A -> Type} {i l l'} : + All Q l -> OnOne2All P i l l' -> OnOne2All (fun i x y => (P i x y * Q x)%type) i l l'. +Proof. + intros H; induction 1; constructor; try inv H; intuition. +Qed. + +Lemma OnOne2All_All2_mix_left {A B} {P : B -> A -> A -> Type} {Q : B -> A -> Type} {i l l'} : + All2 Q i l -> OnOne2All P i l l' -> OnOne2All (fun i x y => (P i x y * Q i x)%type) i l l'. +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' -> + #|i'| = #|l| -> + OnOne2All P (i' ++ i) (l ++ tl) (l ++ tl'). +Proof. induction l in i, i' |- *; simpl; try constructor; eauto. + destruct i' => //. + intros. destruct i' => //. simpl. constructor. + eapply IHl; auto. +Qed. +(* +Lemma OnOne2All_app_r {A} (P : nat -> A -> A -> Type) i l l' tl : + OnOne2All P i l l' -> + OnOne2All P i (l ++ tl) (l' ++ tl). +Proof. induction 1; simpl; constructor; auto. rewrite app_length. Qed. +*) +Lemma OnOne2All_length {A B} {P} {i : list B} {l l' : list A} : OnOne2All P i l l' -> #|l| = #|l'|. +Proof. induction 1; simpl; congruence. Qed. + +Lemma OnOne2All_length2 {A B} {P} {i : list B} {l l' : list A} : OnOne2All P i l l' -> #|i| = #|l|. +Proof. induction 1; simpl; congruence. Qed. + +Lemma OnOne2All_mapP {A B I} {P} {i : list I} {l l' : list A} (f : A -> B) : + OnOne2All (fun i => on_rel (P i) f) i l l' -> OnOne2All P i (map f l) (map f l'). +Proof. induction 1; simpl; constructor; try congruence. apply p. now rewrite map_length. Qed. + +Lemma OnOne2All_map {A I B} {P : I -> B -> B -> Type} {i : list I} {l l' : list A} (f : A -> B) : + OnOne2All (fun i => on_Trel (P i) f) i l l' -> OnOne2All P i (map f l) (map f l'). +Proof. induction 1; simpl; constructor; try congruence. apply p. now rewrite map_length. Qed. + +Lemma OnOne2All_map_all {A B I I'} {P} {i : list I} {l l' : list A} (g : I -> I') (f : A -> B) : + OnOne2All (fun i => on_Trel (P (g i)) f) i l l' -> OnOne2All P (map g i) (map f l) (map f l'). +Proof. induction 1; simpl; constructor; try congruence. apply p. now rewrite !map_length. Qed. + + +Lemma OnOne2All_sym {A B} (P : B -> A -> A -> Type) i l l' : OnOne2All (fun i x y => P i y x) i l' l -> OnOne2All P i l l'. +Proof. + induction 1; constructor; auto. +Qed. + +Lemma OnOne2All_exist {A B} (P : B -> A -> A -> Type) (Q : B -> A -> A -> Type) i l l' : + OnOne2All P i l l' -> + (forall i x y, P i x y -> ∑ z, Q i x z × Q i y z) -> + ∑ r, (OnOne2All Q i l r × OnOne2All Q i l' r). +Proof. + intros H HPQ. induction H. + - destruct (HPQ _ _ _ p). destruct p0. + now exists (x :: tl); intuition constructor. + - destruct IHOnOne2All as [r [? ?]]. + now exists (hd :: r); intuition constructor. +Qed. + +(* Induction principle on OnOne2All when the relation also depends + on one of the lists, and should not change. + *) +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|), + 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 -> + P L (b :: bs) (x :: l) (x :: l') (OnOne2All_tl _ _ _ x _ _ h) + ) -> + forall i l l' h, P l i l l' h. +Proof. + intros A B R P hhd htl i l l' h. induction h ; eauto. +Qed. + +Lemma OnOne2All_impl_exist_and_All : + forall A B (i : list B) (l1 l2 l3 : list A) R1 R2 R3, + OnOne2All R1 i l1 l2 -> + All2 R2 l3 l2 -> + (forall i x x' y, R1 i x y -> R2 x' y -> ∑ z : A, R3 i x z × R2 x' z) -> + ∑ l4, OnOne2All R3 i l1 l4 × All2 R2 l3 l4. +Proof. + intros A B i l1 l2 l3 R1 R2 R3 h1 h2 h. + induction h1 in l3, h2 |- *. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (h _ _ _ _ p X) as hh. + destruct hh as [? [? ?]]. + eexists. constructor. + * constructor; eassumption. + * constructor ; eauto. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (IHh1 _ X0). destruct IHh1 as [? [? ?]]. + eexists. constructor. + * eapply OnOne2All_tl. eassumption. + * constructor ; eauto. +Qed. + +Lemma OnOne2All_impl_exist_and_All_r : + forall A B (i : list B) (l1 l2 l3 : list A) R1 R2 R3, + OnOne2All R1 i l1 l2 -> + All2 R2 l2 l3 -> + (forall i x x' y, R1 i x y -> R2 y x' -> ∑ z : A, R3 i x z × R2 z x') -> + ∑ l4, ( OnOne2All R3 i l1 l4 × All2 R2 l4 l3 ). +Proof. + intros A B i l1 l2 l3 R1 R2 R3 h1 h2 h. + induction h1 in l3, h2 |- *. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (h _ _ _ _ p X) as hh. + destruct hh as [? [? ?]]. + eexists. split. + * constructor; eassumption. + * constructor ; eauto. + - destruct l3. + + inversion h2. + + inversion h2. subst. + specialize (IHh1 _ X0). destruct IHh1 as [? [? ?]]. + eexists. split. + * eapply OnOne2All_tl. eassumption. + * constructor ; eauto. +Qed. + +Lemma OnOne2All_split : + forall A B (P : B -> A -> A -> Type) i l l', + OnOne2All P i l l' -> + ∑ i x y u v, + P i x y × + (l = u ++ x :: v /\ + l' = u ++ y :: v). +Proof. + intros A B P i l l' h. + induction h. + - exists b, hd, hd', [], tl. + intuition eauto. + - destruct IHh as [i' [x [y [u [v ?]]]]]. + exists i', x, y, (hd :: u), v. + intuition eauto. all: subst. all: reflexivity. +Qed. + +Lemma OnOne2All_impl {A B} {P Q} {i : list B} {l l' : list A} : + OnOne2All P i l l' -> + (forall i x y, P i x y -> Q i x y) -> + OnOne2All Q i l l'. +Proof. + induction 1; constructor; intuition eauto. +Qed. + +Lemma OnOne2All_nth_error {A B} {i : list B} (l l' : list A) n t P : + 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')). +Proof. + induction 1 in n |- *. + destruct n; simpl. + - intros [= ->]. exists hd'. intuition auto. now right; exists b. + - intros hnth. exists t; intuition auto. + - destruct n; simpl; rewrite ?Nat.add_succ_r /=; auto. + intros [= ->]. exists t; intuition auto. +Qed. + +Lemma OnOne2All_nth_error_r {A B} (i : list B) (l l' : list A) n t' P : + 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')). +Proof. + induction 1 in n |- *. + destruct n; simpl. + - intros [= ->]. exists hd; intuition auto. + now right; exists b. + - exists t'. intuition auto. + - destruct n; simpl; auto. + intros [= ->]. exists t'; intuition auto. +Qed. + +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. + intros HPQ. + induction 1; intros H; depelim H; constructor; auto. + now eapply HPQ. +Qed. + +Lemma OnOne2All_nth_error_impl {A B} (P : A -> B -> B -> Type) il l l' : + OnOne2All P il l l' -> + OnOne2All (fun i x y => (∑ ni, nth_error il ni = Some i) × P i x y) il l l'. +Proof. + induction 1. + - econstructor => //. + split => //. + exists 0; reflexivity. + - constructor. eapply (OnOne2All_impl IHX). + intros i x y [[ni hni] ?]. + split; auto. exists (S ni). apply hni. +Qed. + Ltac toAll := match goal with | H : is_true (forallb _ _) |- _ => apply forallb_All in H @@ -715,6 +1308,12 @@ Ltac toAll := | H : All _ ?x, H' : All2 _ _ ?x |- _ => apply (All2_All_mix_right H) in H'; clear H + | H : All _ ?x, H' : All2i _ _ ?x _ |- _ => + apply (All2i_All_mix_left H) in H'; clear H + + | H : All _ ?x, H' : All2i _ _ _ ?x |- _ => + apply (All2i_All_mix_right H) in H'; clear H + | |- All _ (map _ _) => apply All_map | H : All _ (map _ _) |- _ => apply All_map_inv in H @@ -824,22 +1423,47 @@ Section Alli_size. End Alli_size. Section All2_size. - Context {A} (P : A -> A -> Type) (fn : forall x1 x2, P x1 x2 -> size). - Fixpoint all2_size {l1 l2 : list A} (f : All2 P l1 l2) : size := + Context {A B} (P : A -> B -> Type) (fn : forall x1 x2, P x1 x2 -> size). + Fixpoint all2_size {l1 l2} (f : All2 P l1 l2) : size := match f with | All2_nil => 0 | All2_cons rxy rll' => fn _ _ rxy + all2_size rll' end. End All2_size. +Section All2i_size. + Context {A B} (P : nat -> A -> B -> Type) (fn : forall i x1 x2, P i x1 x2 -> size). + Fixpoint all2i_size {n l1 l2} (f : All2i P n l1 l2) : size := + match f with + | All2i_nil => 0 + | All2i_cons rxy rll' => fn _ _ _ rxy + all2i_size rll' + end. +End All2i_size. + +Lemma All2i_impl {A B R R' n l l'} : + @All2i A B R n l l' -> + (forall i x y, R i x y -> R' i x y) -> + All2i R' n l l'. +Proof. + intros ha h. + induction ha. 1: constructor. + constructor. 2: assumption. + eapply h. assumption. +Qed. + Ltac close_Forall := match goal with | H : Forall _ _ |- Forall _ _ => apply (Forall_impl H); clear H; simpl | H : All _ _ |- All _ _ => apply (All_impl H); clear H; simpl | H : OnOne2 _ _ _ |- OnOne2 _ _ _ => apply (OnOne2_impl H); clear H; simpl + | H : OnOne2i _ _ _ _ |- OnOne2i _ _ _ _ => apply (OnOne2_impl H); clear H; simpl + | H : OnOne2All _ _ _ _ |- OnOne2All _ _ _ _ => apply (OnOne2All_impl H); clear H; simpl | H : All2 _ _ _ |- All2 _ _ _ => apply (All2_impl H); clear H; simpl + | H : All2i _ _ _ _ |- All2i _ _ _ _ => apply (All2i_impl H); clear H; simpl | H : All2 _ _ _ |- All _ _ => (apply (All2_All_left H) || apply (All2_All_right H)); clear H; simpl + | H : All2i _ _ _ _ |- All _ _ => + (apply (All2i_All_left H) || apply (All2i_All_right H)); clear H; simpl end. Lemma All2_non_nil {A B} (P : A -> B -> Type) (l : list A) (l' : list B) : @@ -875,16 +1499,6 @@ Proof. intros H'; eauto. rewrite <- Nat.add_succ_comm. eauto. Qed. -Lemma nth_error_forallb {A} P l n : - @forallb A P l -> on_Some_or_None P (nth_error l n). -Proof. - induction l in n |- *. - - intros _. destruct n; constructor. - - intro H. apply forallb_Forall in H. - inv H. destruct n; cbn; auto. - now apply forallb_Forall in H1; eauto. -Qed. - Lemma All_map_id' {A} {P : A -> Type} {l} {f} : All P l -> (forall x, P x -> f x = x) -> @@ -961,7 +1575,7 @@ Proof. induction 1; simpl; intuition (f_equal; auto). Qed. -Lemma forallb2_length {A} (p : A -> A -> bool) l l' : is_true (forallb2 p l l') -> length l = length l'. +Lemma forallb2_length {A B} (p : A -> B -> bool) l l' : is_true (forallb2 p l l') -> length l = length l'. Proof. induction l in l' |- *; destruct l'; simpl; try congruence. rewrite !andb_and. intros [Hp Hl]. erewrite IHl; eauto. @@ -1070,14 +1684,56 @@ Proof. + eapply IHl. inversion h. assumption. Qed. -Lemma All2_app_inv : forall (A B : Type) (R : A -> B -> Type), - forall l l1 l2, All2 R (l1 ++ l2) l -> { '(l1',l2') : _ & (l = l1' ++ l2')%list * (All2 R l1 l1') * (All2 R l2 l2')}%type. +Lemma All2_length {A B} {P : A -> B -> Type} {l l'} : All2 P l l' -> #|l| = #|l'|. +Proof. induction 1; simpl; auto. Qed. + +Lemma All2_app_inv_l : forall (A B : Type) (R : A -> B -> Type), + forall l1 l2 r, + All2 R (l1 ++ l2) r -> + ∑ r1 r2, + (r = r1 ++ r2)%list × + All2 R l1 r1 × + All2 R l2 r2. +Proof. + intros. revert l2 r X. induction l1; intros; cbn in *. + - exists [], r. eauto. + - depelim X. + apply IHl1 in X as (?&?&?&?&?). + subst. + eexists _, _. + split; [|split; eauto]; auto. +Qed. + +Lemma All2_app_inv_r : + forall A B R l r1 r2, + @All2 A B R l (r1 ++ r2) -> + ∑ l1 l2, + (l = l1 ++ l2)%list × + All2 R l1 r1 × + All2 R l2 r2. +Proof. + intros A B R l r1 r2 h. + induction r1 in l, r1, r2, h |- *. + - exists [], l; eauto. + - depelim h. + apply IHr1 in h as (?&?&?&?&?). + subst. + eexists _, _. + split; [|split; eauto]; auto. +Qed. + +Lemma All2_app_inv : + forall A B (P : A -> B -> Type) l1 l2 r1 r2, + #|l1| = #|r1| -> + All2 P (l1 ++ l2) (r1 ++ r2) -> + All2 P l1 r1 × All2 P l2 r2. Proof. - intros. revert l2 l X. induction l1; intros; cbn in *. - - exists ([], l). eauto. - - inversion X. subst. - eapply IHl1 in X1 as ( [] & ? & ?). destruct p. subst. - eexists (y :: l, l0). repeat split; eauto. + intros A B P l1 l2 r1 r2 e h. + apply All2_app_inv_l in h as (w1&w2&e1&h1&h2). + apply app_inj_length_l in e1 as (->&->); auto. + apply All2_length in h1. + apply All2_length in h2. + congruence. Qed. Lemma All2_rect_rev : forall (A B : Type) (R : A -> B -> Type) (P : forall (l : list A) (l0 : list B), Type), @@ -1088,7 +1744,7 @@ Lemma All2_rect_rev : forall (A B : Type) (R : A -> B -> Type) (P : forall (l : Proof. intros. revert l0 a. induction l using rev_ind; cbn; intros. - inv a. eauto. - - eapply All2_app_inv in a as ([] & [[]]). subst. + - eapply All2_app_inv_l in a as (?&?&?&?&?). subst. inv a0. inv X2. eauto. Qed. @@ -1243,6 +1899,13 @@ Proof. induction 1; constructor; auto. Qed. +Lemma Forall2_map_right {A B C} (P : A -> B -> Prop) (f : C -> B) (l : list A) (l' : list C) : + Forall2 P l (map f l') <-> Forall2 (fun x y => P x (f y)) l l'. +Proof. + split; intros. + + eapply Forall2_map_inv. now rewrite map_id. + + rewrite -(map_id l). now eapply Forall2_map. +Qed. Lemma Forall2_and {A B} (R R' : A -> B -> Prop) l l' : Forall2 R l l' -> Forall2 R' l l' -> Forall2 (fun x y => R x y /\ R' x y) l l'. @@ -1369,6 +2032,23 @@ Proof. now transitivity y. Qed. +Lemma All2_trans' {A B C} + (P : A -> B -> Type) (Q : B -> C -> Type) (R : A -> C -> Type) + (H : forall x y z, P x y × Q y z -> R x z) {l1 l2 l3} + : All2 P l1 l2 -> All2 Q l2 l3 -> All2 R l1 l3. +Proof. + induction 1 in l3 |- *. + - inversion 1; constructor. + - inversion 1; subst. constructor; eauto. +Qed. + +Lemma All2_map_left_inv {A B C} (P : A -> B -> Type) (l : list C) (f : C -> A) l' : + All2 P (map f l) l' -> All2 (fun x => P (f x)) l l'. +Proof. + rewrite -{1}(map_id l'). + intros. now eapply All2_map_inv in X. +Qed. + Lemma All2_nth : forall A B P l l' n (d : A) (d' : B), All2 P l l' -> @@ -1496,27 +2176,6 @@ Proof. all: destruct n ; try econstructor ; eauto. Qed. - -Lemma All2_app_inv_r : - forall A B R l r1 r2, - @All2 A B R l (r1 ++ r2) -> - ∑ l1 l2, - (l = l1 ++ l2)%list × - All2 R l1 r1 × - All2 R l2 r2. -Proof. - intros A B R l r1 r2 h. - exists (firstn #|r1| l), (skipn #|r1| l). - split ; [| split]. - - rewrite firstn_skipn. reflexivity. - - apply All2_firstn with (n := #|r1|) in h. - rewrite firstn_app in h. rewrite firstn_all in h. - replace (#|r1| - #|r1|) with 0 in h by lia. cbn in h. - rewrite app_nil_r in h. assumption. - - apply All2_skipn with (n := #|r1|) in h. - rewrite skipn_all_app in h. assumption. -Qed. - Lemma All2_impl' {A B} {P Q : A -> B -> Type} {l : list A} {l' : list B} : All2 P l l' -> All (fun x => forall y, P x y -> Q x y) l -> All2 Q l l'. Proof. @@ -1565,10 +2224,7 @@ Proof. induction Hall; destruct n; simpl; try congruence. auto. Qed. -Lemma All2_length {A B} {P : A -> B -> Type} l l' : All2 P l l' -> #|l| = #|l'|. -Proof. induction 1; simpl; auto. Qed. - -Lemma All2_same {A} (P : A -> A -> Type) l : (forall x, P x x) -> All2 P l l. +Lemma All2_same {A} {P : A -> A -> Type} l : (forall x, P x x) -> All2 P l l. Proof. induction l; constructor; auto. Qed. @@ -1671,6 +2327,13 @@ Proof. rewrite !andb_and. intros [px pl] Hx. eauto. Qed. +Lemma All_forallb_eq_forallb {A} (P : A -> Type) (p q : A -> bool) l : + All P l -> + (forall x, P x -> p x = q x) -> + forallb p l = forallb q l. +Proof. + induction 1; simpl; intuition (f_equal; auto). +Qed. Lemma forallb_nth {A} (l : list A) (n : nat) P d : forallb P l -> n < #|l| -> exists x, (nth n l d = x) /\ P x. @@ -1727,6 +2390,12 @@ Proof. split ; constructor ; auto. Qed. +Lemma All_pair {A} (P Q : A -> Type) l : + All (fun x => P x × Q x) l <~> (All P l × All Q l). +Proof. + split. induction 1; intuition auto. + move=> [] Hl Hl'. induction Hl; depelim Hl'; intuition auto. +Qed. Lemma All_prod : forall A P Q l, @@ -1741,29 +2410,6 @@ Proof. specialize (IHh1 X0). auto. Qed. - -Inductive All2i {A B : Type} (R : nat -> A -> B -> Type) (n : nat) - : list A -> list B -> Type := -| All2i_nil : All2i R n [] [] -| All2i_cons : - forall x y l r, - R n x y -> - All2i R (S n) l r -> - All2i R n (x :: l) (y :: r). -Derive Signature NoConfusionHom for All2i. - -Lemma All2i_impl : - forall A B R R' n l l', - @All2i A B R n l l' -> - (forall i x y, R i x y -> R' i x y) -> - All2i R' n l l'. -Proof. - intros A B R R' n l l' ha h. - induction ha. 1: constructor. - constructor. 2: assumption. - eapply h. assumption. -Qed. - Lemma All2i_mapi : forall A B C D R f g l l', @All2i A B (fun i x y => R i (f i x) (g i y)) 0 l l' -> @@ -1901,11 +2547,11 @@ Proof. Qed. Lemma forallb2_Forall2 : - forall A (p : A -> A -> bool) l l', + forall A B (p : A -> B -> bool) l l', forallb2 p l l' -> Forall2 (fun x y => p x y) l l'. Proof. - intros A p l l' h. + intros A B p l l' h. induction l in l', h |- *. - destruct l'. 2: discriminate. constructor. @@ -1914,6 +2560,19 @@ Proof. constructor. all: auto. 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)) -> + reflect (Forall2 P l l') (forallb2 p l l'). +Proof. + intros Hp. + apply iff_reflect; change (forallb2 p l l' = true) with (forallb2 p l l' : Prop); split. + - induction 1; rewrite /= // IHForall2 // andb_true_r. + now destruct (Hp x y). + - induction l in l' |- *; destruct l'; rewrite /= //. rewrite andb_and. + intros [pa pl]. + constructor; auto. now destruct (Hp a b). +Qed. + (** All, All2 and In interactions. *) Lemma All2_In {A B} (P : A -> B -> Type) l l' x : In x l -> @@ -1962,4 +2621,147 @@ Proof. - constructor. + apply p. + apply IHX0. +Qed. + +Lemma All2i_map {A B C D} (R : nat -> C -> D -> Type) (f : A -> C) (g : B -> D) n l l' : + All2i (fun i x y => R i (f x) (g y)) n l l' -> All2i R n (map f l) (map g l'). +Proof. induction 1; simpl; constructor; try congruence. Qed. + +Lemma All2i_map_right {B C D} (R : nat -> C -> D -> Type) (g : B -> D) n l l' : + All2i (fun i x y => R i x (g y)) n l l' -> All2i R n l (map g l'). +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 => + (if i //. + 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'. + assert (i - n = S (i - S n)) as -> by lia. simpl. now rewrite e. +Qed. + +Lemma All2i_nth_hyp {A B} (R : nat -> A -> B -> Type) l l' : + All2i R 0 l l' -> + All2i (fun i x y => nth_error l i = Some x × R i x y) 0 l l'. +Proof. + intros a. + eapply All2i_nth_impl_gen in a. simpl in a. + eapply (All2i_impl a). intros. + 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 : + All2i P k l l' -> + nth_error l n = Some x -> + ∑ c, nth_error l' n = Some c × P (k + n)%nat x c. +Proof. + induction 1 in n |- *. + * rewrite nth_error_nil => //. + * destruct n. + + simpl. intros [= <-]. + eexists; split; eauto. now rewrite Nat.add_0_r. + + simpl. intros hnth. specialize (IHX _ hnth). + now rewrite Nat.add_succ_r. +Qed. + +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. +Proof. + induction 1 in n |- *. + * rewrite nth_error_nil => //. + * destruct n. + + simpl. intros [= <-]. + eexists; split; eauto. now rewrite Nat.add_0_r. + + simpl. intros hnth. specialize (IHX _ hnth). + now rewrite Nat.add_succ_r. +Qed. + +Lemma All2i_app_inv_l {X Y} (R : nat -> X -> Y -> Type) n xs xs' l : + All2i R n (xs ++ xs') l -> + ∑ ys ys', + l = ys ++ ys' × All2i R n xs ys × All2i R (n + #|xs|) xs' ys'. +Proof. + intros a. + induction xs in n, xs, xs', l, a |- *. + - cbn; rewrite Nat.add_0_r. + eexists _, _. + split; [|split; eauto; constructor]. + auto. + - depelim a. + apply IHxs in a as (?&?&->&?&?). + cbn. + rewrite Nat.add_succ_r. + eexists _, _. + split; [|split; eauto; constructor; eauto]. + auto. +Qed. + +Lemma All2i_app_inv_r {X Y} (R : nat -> X -> Y -> Type) n l ys ys' : + All2i R n l (ys ++ ys') -> + ∑ xs xs', + l = xs ++ xs' × All2i R n xs ys × All2i R (n + #|xs|) xs' ys'. +Proof. + intros a. + induction ys in n, l, ys', a |- *. + - exists [], l. + split; auto. + cbn; rewrite Nat.add_0_r. + split; eauto. + constructor. + - depelim a. + apply IHys in a as (?&?&->&?&?). + eexists (_ :: _), _. + split; [reflexivity|]. + cbn; rewrite Nat.add_succ_r. + split; eauto. + constructor; auto. +Qed. + +Lemma All2i_length {X Y} (R : nat -> X -> Y -> Type) n xs ys : + All2i R n xs ys -> + #|xs| = #|ys|. +Proof. + intros a. + induction a; auto. + cbn; lia. +Qed. + +Lemma All2i_app_inv {X Y} (R : nat -> X -> Y -> Type) n xs xs' ys ys' : + All2i R n (xs ++ xs') (ys ++ ys') -> + #|xs| = #|ys| -> + All2i R n xs ys × All2i R (n + #|xs|) xs' ys'. +Proof. + intros a eq. + apply All2i_app_inv_l in a as (?&?&leq&?&?). + apply app_inj_length_l in leq as (?&?); subst; auto. + apply All2i_length in a. + apply All2i_length in a0. + congruence. +Qed. + +Lemma All2i_All2_All2i_All2i {A B C n} {P : nat -> A -> B -> Type} {Q : B -> C -> Type} {R : nat -> A -> C -> Type} + {S : nat -> A -> C -> Type} {l l' l''} : + All2i P n l l' -> + All2 Q l' l'' -> + All2i R n l l'' -> + (forall n x y z, P n x y -> Q y z -> R n x z -> S n x z) -> + All2i S n l l''. +Proof. + intros a b c H. + induction a in l'', b, c |- *; depelim b; depelim c; try constructor; auto. + eapply H; eauto. Qed. \ No newline at end of file diff --git a/template-coq/theories/utils/MCList.v b/template-coq/theories/utils/MCList.v index 79094596f..e5a666a6c 100644 --- a/template-coq/theories/utils/MCList.v +++ b/template-coq/theories/utils/MCList.v @@ -7,8 +7,18 @@ Arguments firstn : simpl nomatch. Arguments skipn : simpl nomatch. Notation "#| l |" := (List.length l) (at level 0, l at level 99, format "#| l |"). + +Hint Rewrite map_length app_length List.rev_length : len. + Arguments nil {_}, _. +Instance proper_map_ho {A B} : Proper ((pointwise_relation A Logic.eq) ==> Logic.eq ==> Logic.eq) + (@map A B). +Proof. + intros f g Hfg x y ->. apply map_ext. + apply Hfg. +Qed. + Lemma app_tip_assoc {A} (l : list A) x l' : (l ++ [x]) ++ l' = l ++ (x :: l'). Proof. now rewrite <- app_assoc. Qed. @@ -44,6 +54,11 @@ Next Obligation. simpl in H. auto with arith. Defined. +Fixpoint map2 {A B C} (f : A -> B -> C) (l : list A) (l' : list B) : list C := + match l, l' with + | hd :: tl, hd' :: tl' => f hd hd' :: map2 f tl tl' + | _, _ => [] + end. Lemma nth_error_safe_nth {A} n (l : list A) (isdecl : n < Datatypes.length l) : nth_error l n = Some (safe_nth l (exist _ n isdecl)). @@ -129,6 +144,7 @@ Proof. } intro l. apply h. Defined. +Hint Rewrite @rev_length : len. Fact rev_map_length : forall {A B} {f : A -> B} {l : list A}, @@ -147,6 +163,7 @@ Proof. } intro l. apply h. Defined. +Hint Rewrite @rev_map_length : len. Fact rev_map_app : forall {A B} {f : A -> B} {l1 l2}, @@ -159,7 +176,6 @@ Proof. rewrite app_assoc. reflexivity. Defined. - Lemma map_map_compose : forall (A B C : Type) (f : A -> B) (g : B -> C) (l : list A), map g (map f l) = map (fun x => g (f x)) l. @@ -469,10 +485,12 @@ Proof. unfold mapi at 1. rewrite mapi_rec_rev. now rewrite Nat.add_0_r. Qed. Lemma mapi_rec_length {A B} (f : nat -> A -> B) (l : list A) n : length (mapi_rec f l n) = length l. Proof. induction l in n |- *; simpl; try congruence. Qed. +Hint Rewrite @mapi_rec_length : len. Lemma mapi_length {A B} (f : nat -> A -> B) (l : list A) : length (mapi f l) = length l. Proof. apply mapi_rec_length. Qed. +Hint Rewrite @mapi_length : len. Lemma skipn_length {A} n (l : list A) : n <= length l -> length (skipn n l) = length l - n. Proof. @@ -587,6 +605,13 @@ Proof. now rewrite Nat.add_succ_r. Qed. +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. +Qed. +Hint Rewrite @skipn_map_length : len. + Lemma firstn_ge {A} (l : list A) n : #|l| <= n -> firstn n l = l. Proof. induction l in n |- *; simpl; intros; auto. now rewrite firstn_nil. @@ -956,6 +981,7 @@ Lemma unfold_length {A} (f : nat -> A) m : #|unfold m f| = m. Proof. induction m; simpl; rewrite ?app_length /=; auto. lia. Qed. +Hint Rewrite @unfold_length : len. Lemma nth_error_unfold {A} (f : nat -> A) m n : n < m <-> nth_error (unfold m f) n = Some (f n). Proof. @@ -1073,3 +1099,59 @@ Proof. induction l in n |- *; simpl; auto with arith; destruct n; simpl; auto with arith. discriminate. Qed. + +Fixpoint map2i_rec {A B C} (f : nat -> A -> B -> C) i (l : list A) (l' : list B) : list C := + match l, l' with + | hd :: tl, hd' :: tl' => f i hd hd' :: map2i_rec f (S i) tl tl' + | _, _ => [] + 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' : + mapi f (map2 g l l') = map2i (fun i x y => f i (g x y)) l l'. +Proof. + unfold mapi, map2i. generalize 0. + induction l in l' |- *; intros; destruct l'; simpl; auto. f_equal. + 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' : + 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. + induction l in l' |- *; intros n; destruct l'; simpl; auto. f_equal. + apply IHl. +Qed. + +Lemma map2i_ext {A B C} (f g : nat -> A -> B -> C) l l' : + (forall i x y, f i x y = g i x y) -> map2i f l l' = map2i g l l'. +Proof. + intros Hfg. + unfold map2i. + generalize 0. + induction l in l' |- *; destruct l'; simpl; auto. + intros. f_equal; eauto. +Qed. + +Lemma app_inj_length_r {A} (l l' r r' : list A) : + app l r = app l' r' -> #|r| = #|r'| -> l = l' /\ r = r'. +Proof. + induction r in l, l', r' |- *. destruct r'; intros; simpl in *; intuition auto; try discriminate. + now rewrite !app_nil_r in H. + intros. destruct r'; try discriminate. + simpl in H. + change (l ++ a :: r) with (l ++ [a] ++ r) in H. + change (l' ++ a0 :: r') with (l' ++ [a0] ++ r') in H. + rewrite !app_assoc in H. destruct (IHr _ _ _ H). now injection H0. + subst. now apply app_inj_tail in H1 as [-> ->]. +Qed. + +Lemma app_inj_length_l {A} (l l' r r' : list A) : + app l r = app l' r' -> #|l| = #|l'| -> l = l' /\ r = r'. +Proof. + induction l in r, r', l' |- *. destruct l'; intros; simpl in *; intuition auto; try discriminate. + intros. destruct l'; try discriminate. simpl in *. injection H as [= -> ?]. + specialize (IHl _ _ _ H). + destruct IHl; intuition congruence. +Qed. + diff --git a/template-coq/theories/utils/MCOption.v b/template-coq/theories/utils/MCOption.v index c67f69f2b..c3495e57f 100644 --- a/template-coq/theories/utils/MCOption.v +++ b/template-coq/theories/utils/MCOption.v @@ -1,5 +1,5 @@ -From Coq Require Import List ssreflect Arith. -From MetaCoq Require Import MCPrelude MCList MCProd. +From Coq Require Import List ssreflect Arith Morphisms. +From MetaCoq Require Import MCPrelude MCList MCProd MCReflect. Definition option_get {A} (default : A) (x : option A) : A := match x with @@ -67,6 +67,14 @@ Proof. intros []; cbn; congruence. Qed. +Instance option_map_proper {A B} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@option_map A B). +Proof. + intros f g Hfg x y <-. now apply option_map_ext. +Qed. + +Lemma option_map_id {A} : option_map (@id A) =1 id. +Proof. by intros []. Qed. + Lemma nth_map_option_out {A B} (f : nat -> A -> option B) l l' i t : map_option_out (mapi f l) = Some l' -> nth_error l' i = Some t -> (∑ x, (nth_error l i = Some x) /\ (f i x = Some t)). @@ -92,6 +100,22 @@ Proof. move=> [=] <-. by rewrite (IHl l0 eq_refl). Qed. +Lemma map_option_out_impl {A B} (l : list A) (f g : A -> option B) x : + (forall x y, f x = Some y -> g x = Some y) -> + map_option_out (map f l) = Some x -> + map_option_out (map g l) = Some x. +Proof. + intros Hfg. + induction l in x |- *; simpl; auto. + destruct (f a) eqn:fa. + - rewrite (Hfg _ _ fa). + move: IHl; destruct map_option_out. + * move=> H'. specialize (H' _ eq_refl). + rewrite H'. congruence. + * discriminate. + - discriminate. +Qed. + 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). @@ -100,6 +124,15 @@ Proof. move=> [] <-. exists a; auto. Qed. +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. + intros Hp x. + destruct x => /= //. constructor. exact tt. +Qed. + + (** Analogous to Forall, but for the [option] type *) (* Helpful for induction principles and predicates on [term] *) Inductive ForOption {A} (P : A -> Prop) : option A -> Prop := @@ -115,3 +148,20 @@ Definition foroptb2 {A : Type} (p : A -> A -> bool) (o o': option A) : bool := | None, None => true | _, _ => false end. + +Instance foroptb_proper A : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@foroptb A). +Proof. + intros f g Hfg x y ->; rewrite /foroptb. + destruct y; simpl; rewrite // ?Hfg. +Qed. + +Instance foroptb_proper_pointwise A : Proper (`=1` ==> `=1`) (@foroptb A). +Proof. + intros f g Hfg y; rewrite /foroptb. + destruct y; simpl; rewrite // ?Hfg. +Qed. + +Lemma foroptb_impl {A} (f g : A -> bool) x : (forall x, f x -> g x) -> foroptb f x -> foroptb g x. +Proof. + move=> Hf; destruct x; simpl => //; apply Hf. +Qed. diff --git a/template-coq/theories/utils/MCPred.v b/template-coq/theories/utils/MCPred.v new file mode 100644 index 000000000..fe0270672 --- /dev/null +++ b/template-coq/theories/utils/MCPred.v @@ -0,0 +1,45 @@ +From Coq Require Import List Bool Arith ssreflect ssrbool Morphisms Lia. +From MetaCoq.Template Require Import MCPrelude MCReflect MCList MCRelations MCProd MCOption. +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. + +Definition conjP (p q : nat -> bool) (n : nat) : bool := + p n && q n. + +Definition implP (p q : nat -> bool) (n : nat) : bool := + p n ==> q n. *) + +Instance orP_Proper {A} : Proper (`=1` ==> `=1` ==> `=1`) (@predU A). +Proof. + intros f g Hfg f' g' Hfg' i; rewrite /predU /=. + now rewrite Hfg Hfg'. +Qed. + +Instance andP_Proper A : Proper (`=1` ==> `=1` ==> `=1`) (@predI A). +Proof. + intros f g Hfg f' g' Hfg' i; rewrite /predI /=. + now rewrite Hfg Hfg'. +Qed. + +Instance implP_Proper {A} : Proper (`=1` ==> `=1` ==> `=1`) (@predA A). +Proof. + intros f g Hfg f' g' Hfg' i; rewrite /predA /=. + now rewrite Hfg Hfg'. +Qed. + +Lemma orPL (p q : nat -> bool) : predA p (predU p q) =1 xpredT. +Proof. + intros i. rewrite /predA /predU /=. + rewrite (ssrbool.implybE (p i)). + destruct (p i) => //. +Qed. + +Lemma orPR (p q : nat -> bool) i : q i -> (predU p q) i. +Proof. + rewrite /predU /= => ->; rewrite orb_true_r //. +Qed. \ No newline at end of file diff --git a/template-coq/theories/utils/MCPrelude.v b/template-coq/theories/utils/MCPrelude.v index 5b8768dea..06a4ebc30 100644 --- a/template-coq/theories/utils/MCPrelude.v +++ b/template-coq/theories/utils/MCPrelude.v @@ -1,4 +1,4 @@ -Require Import String ZArith Lia. +Require Import String ZArith Lia Morphisms. From Equations Require Import Equations. Set Equations Transparent. @@ -30,8 +30,50 @@ Notation "( x ; y ; z ; t ; u ; v )" := (x ; ( y ; (z ; (t ; (u ; v))))). Notation "x .π1" := (@projT1 _ _ x) (at level 3, format "x '.π1'"). Notation "x .π2" := (@projT2 _ _ x) (at level 3, format "x '.π2'"). +(** Shorthand for pointwise equality relation in Proper signatures *) +Notation "`=1`" := (pointwise_relation _ Logic.eq) (at level 80). +Infix "=1" := (pointwise_relation _ Logic.eq) (at level 70). +Notation "`=2`" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 80). +Infix "=2" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 70). + +(** Higher-order lemma to simplify Proper proofs. *) +Instance proper_ext_eq {A B} : Proper (`=1` ==> `=1` ==> iff) (@pointwise_relation A _ (@Logic.eq B)). +Proof. + intros f f' Hff' g g' Hgg'. split; intros. + - intros x. now rewrite <- Hff', <- Hgg'. + - intros x. now rewrite Hff', Hgg'. +Qed. + +Instance id_proper_proxy {A} : ProperProxy (`=1`) (@id A). +Proof. + intros x; reflexivity. +Qed. + +Instance pointwise_subrelation {A B} : subrelation (`=1`) (@Logic.eq A ==> @Logic.eq B)%signature. +Proof. + intros f g Hfg x y ->. now rewrite Hfg. +Qed. + +Instance pointwise_subrelation2 {A B C} : subrelation (`=2`) (@Logic.eq A ==> @Logic.eq B ==> @Logic.eq C)%signature. +Proof. + intros f g Hfg x y -> ? ? ->. now rewrite Hfg. +Qed. + +(** Common abbreviations *) +Ltac tas := try assumption. +Ltac tea := try eassumption. +Ltac trea := try reflexivity; try eassumption. +Ltac tc := try typeclasses eauto. + Create HintDb terms. +(** 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. + +Hint Rewrite Nat.add_0_r : len. + Ltac arith_congr := repeat (try lia; progress f_equal). Ltac lia_f_equal := repeat (lia || f_equal). @@ -65,3 +107,10 @@ Hint Extern 10 (@eq nat _ _) => lia : terms. 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 + for easier lemma application. *) +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 5631a042c..c62bb2958 100644 --- a/template-coq/theories/utils/MCProd.v +++ b/template-coq/theories/utils/MCProd.v @@ -13,7 +13,6 @@ Open Scope pair_scope. Notation "x × y" := (prod x y ) (at level 80, right associativity). - Notation "p .p1" := (proj1 p) (at level 2, left associativity, format "p .p1"). Notation "p .p2" := (proj2 p) (at level 2, left associativity, format "p .p2"). @@ -23,7 +22,9 @@ Definition on_snd {A B C} (f : B -> C) (p : A * B) := Definition test_snd {A B} (f : B -> bool) (p : A * B) := f (snd p). - +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. diff --git a/template-coq/theories/utils/MCReflect.v b/template-coq/theories/utils/MCReflect.v new file mode 100644 index 000000000..26c08f0ab --- /dev/null +++ b/template-coq/theories/utils/MCReflect.v @@ -0,0 +1,56 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Bool. +From MetaCoq.Template Require Import MCPrelude. +Require Import ssreflect. +From Equations Require Import Equations. + +(** * Notion of reflection for Type-based properties *) + +Inductive reflectT (A : Type) : bool -> Type := +| ReflectT : A -> reflectT A true +| ReflectF : (A -> False) -> reflectT A false. + +Lemma reflectT_reflect (A : Prop) b : reflectT A b -> reflect A b. +Proof. + destruct 1; now constructor. +Qed. + +Lemma reflect_reflectT (A : Prop) b : reflect A b -> reflectT A b. +Proof. + destruct 1; now constructor. +Qed. + +Lemma equiv_reflectT P (b : bool) : (P -> b) -> (b -> P) -> reflectT P b. +Proof. + intros. destruct b; constructor; auto. + intros p; specialize (H p). discriminate. +Qed. + +Lemma elimT {T} {b} : reflectT T b -> b -> T. +Proof. intros [] => //. Qed. +Coercion elimT : reflectT >-> Funclass. + +Lemma introT {T} {b} : reflectT T b -> T -> b. +Proof. intros [] => //. Qed. + +Hint View for move/ introT|2. + +Lemma reflectT_subrelation {A} {R} {r : A -> A -> bool} : (forall x y, reflectT (R x y) (r x y)) -> CRelationClasses.subrelation R r. +Proof. + intros. intros x y h. destruct (X x y); auto. +Qed. + +Lemma reflectT_subrelation' {A} {R} {r : A -> A -> bool} : (forall x y, reflectT (R x y) (r x y)) -> CRelationClasses.subrelation r R. +Proof. + intros. intros x y h. destruct (X x y); auto. discriminate. +Qed. + +Lemma reflectT_pred {A} {p : A -> bool} : forall x, reflectT (p x) (p x). +Proof. + intros x. now apply equiv_reflectT. +Qed. + +Lemma reflectT_pred2 {A B} {p : A -> B -> bool} : forall x y, reflectT (p x y) (p x y). +Proof. + intros x y. now apply equiv_reflectT. +Qed. diff --git a/template-coq/theories/utils/MCRelations.v b/template-coq/theories/utils/MCRelations.v index f24839fc0..2ddd1b39d 100644 --- a/template-coq/theories/utils/MCRelations.v +++ b/template-coq/theories/utils/MCRelations.v @@ -5,6 +5,10 @@ Require Import CRelationClasses. Infix "<~>" := iffT (at level 90). +(** This allow to use implicit projections for move/ on "<~>" lemmas *) +Hint View for move/ fst|2. +Hint View for move/ snd|2. + Notation "'precompose'" := (fun R f x y => R (f x) (f y)) (only parsing). Definition on_rel {A B} (R : A -> A -> Prop) (f : B -> A) : B -> B -> Prop := diff --git a/template-coq/theories/utils/MCUtils.v b/template-coq/theories/utils/MCUtils.v index e6ebf182f..0e4b48473 100644 --- a/template-coq/theories/utils/MCUtils.v +++ b/template-coq/theories/utils/MCUtils.v @@ -1,6 +1,7 @@ From Coq Require Import Nat ZArith Bool. Require Export MCPrelude + MCReflect All_Forall MCArith MCCompare @@ -184,10 +185,6 @@ Proof. destruct q. apply Eqdep_dec.UIP_refl_bool. Qed. -Ltac tas := try assumption. -Ltac tea := try eassumption. -Ltac trea := try reflexivity; try eassumption. - Axiom todo : String.string -> forall {A}, A. Ltac todo s := exact (todo s). diff --git a/template-coq/update_plugin.sh b/template-coq/update_plugin.sh index b9a5ecaf4..259db8507 100755 --- a/template-coq/update_plugin.sh +++ b/template-coq/update_plugin.sh @@ -2,9 +2,9 @@ TOCOPY="ast_denoter.ml ast_quoter.ml denoter.ml plugin_core.ml plugin_core.mli reification.ml quoter.ml run_extractable.ml run_extractable.mli tm_util.ml" -# Test is gen-src is older than src -if [[ "gen-src" -ot "src" || ! -f "gen-src/denoter.ml" || ! -f "gen-src/metacoq_template_plugin.cmxs" || - "gen-src/extractable.ml" -nt "gen-src/metacoq_template_plugin.cmxs" || "$1" = "force" ]] +# Test if gen-src is older than src +if [[ ! -f "gen-src/denoter.ml" || + "theories/Extraction.vo" -nt "gen-src/denoter.ml" || "$1" = "force" ]] then echo "Updating gen-src from src" mkdir -p build diff --git a/test-suite/bugkncst.v b/test-suite/bugkncst.v index cce78b869..f7cf013ba 100644 --- a/test-suite/bugkncst.v +++ b/test-suite/bugkncst.v @@ -17,13 +17,17 @@ Require Import Coq.Strings.String. Require Import Coq.Strings.Ascii. Require Import Coq.Bool.Bool. Require Import MetaCoq.Template.Loader. -Require Import MetaCoq.Template.Ast. +Require Import MetaCoq.Template.All. Unset Template Cast Propositions. +From MetaCoq.Template Require Import Pretty. (* Use template-coq to make a [program] from function defined above *) Time MetaCoq Quote Recursively Definition p_Plus1 := Plus1. +(* Eval cbv in (print_program false 1 p_Plus1). +Eval lazy in (print_term (empty_ext (fst p_Plus1)) nil true (snd p_Plus1)). *) + (** The program p_Plus1 is too big to read, so we define some *** diagnostic software **) Section occ_term_Sec. @@ -41,8 +45,9 @@ 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 kername_eq_dec str nm then true else false | tCase _ ty mch brs => - pocc_term n ty || pocc_term n mch || - fold_left orb (map (fun x => pocc_term n (snd x)) brs) false + 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 _ => fold_left orb (map (fun x => pocc_term n (dtype x) || pocc_term n (dbody x)) ds) false diff --git a/test-suite/erasure_live_test.v b/test-suite/erasure_live_test.v index 3a9d162bf..e45ac317d 100644 --- a/test-suite/erasure_live_test.v +++ b/test-suite/erasure_live_test.v @@ -8,7 +8,7 @@ Local Open Scope string_scope. From MetaCoq.Template Require Import utils. -Definition test (p : Ast.program) : string := +Definition test (p : Ast.Env.program) : string := erase_and_print_template_program p. MetaCoq Quote Recursively Definition zero := 0. diff --git a/test-suite/issue28.v b/test-suite/issue28.v index da1ac8676..95cb74961 100644 --- a/test-suite/issue28.v +++ b/test-suite/issue28.v @@ -1,4 +1,4 @@ -Require Import MetaCoq.Template.All. +Require Import MetaCoq.Template.All MetaCoq.Template.Pretty. Require Export String List. Open Scope string. Import ListNotations. @@ -24,11 +24,15 @@ Definition T := 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 ((mkInd q_test 0, 1), Relevant) - (tLambda (nNamed "x") (tApp (tInd (mkInd q_test 0) []) [tInd (mkInd q_unit 0) []]) (tInd (mkInd q_unit 0) [])) + (tCase {|ci_ind := mkInd q_test 0; ci_npar := 1; ci_relevance := Relevant |} + {| pparams := [tInd (mkInd q_unit 0) []]; puinst := []; + pcontext := [nNamed "X"]; + preturn := (tInd (mkInd q_unit 0) []) |} (tRel 0) - [(1, tLambda (nNamed "x0") (tApp (tInd (mkInd q_test 0) []) [tInd (mkInd q_unit 0) []]) (tApp (tRel 2) [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). Fail Let bla := (existT_typed_term (test unit -> unit) (fix f (x : test f) : unit := match x with diff --git a/test-suite/plugin-demo/theories/MyPlugin.v b/test-suite/plugin-demo/theories/MyPlugin.v index 56d52e4e5..6d455f49c 100644 --- a/test-suite/plugin-demo/theories/MyPlugin.v +++ b/test-suite/plugin-demo/theories/MyPlugin.v @@ -7,8 +7,8 @@ Import TemplateMonad.Extractable. From MetaCoq Require Import Template.BasicAst Template.AstUtils Ast. -Let TemplateMonad := TM. -Fixpoint mconcat (ls : list (TemplateMonad unit)) : TemplateMonad unit := +Notation TemplateMonad := TM. +Fixpoint mconcat (ls : list (TemplateMonad unit)) : TM unit := match ls with | nil => tmReturn tt | m :: ms => tmBind m (fun _ => mconcat ms) @@ -133,7 +133,7 @@ Definition getFields (mi : mutual_inductive_body) match oib.(ind_ctors) with | ctor :: nil => Some {| type := oib.(ind_name) - ; ctor := let '(x,_,_) := ctor in x + ; ctor := ctor.(cstr_name) ; fields := oib.(ind_projs) |} | _ => None diff --git a/test-suite/safechecker_test.v b/test-suite/safechecker_test.v index f3f8cfe49..fb3111d90 100644 --- a/test-suite/safechecker_test.v +++ b/test-suite/safechecker_test.v @@ -41,6 +41,20 @@ Definition bignat := 10000. MetaCoq SafeCheck bignat. MetaCoq CoqCheck bignat. +(*Require Import String. +From MetaCoq.Template Require Import Loader Core TemplateMonad monad_utils Pretty. +Import MonadNotation. +Open Scope monad_scope. +Require Import String. +Open Scope string_scope. +Definition topkn s : BasicAst.kername := + (Datatypes.pair (BasicAst.MPfile ("safechecker_test" :: nil)%list) (s))%string. + +MetaCoq Quote Recursively Definition prodq := prod_rect. + +MetaCoq Run + (tmEval cbv (print_program false 2 prodq) >>= tmPrint). +*) Set Universe Polymorphism. (* Basic notations *) @@ -55,7 +69,6 @@ Arguments pair {_ _} _ _. Notation "x * y" := (prod x y) : type_scope. Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z): type_scope. - Section projections. Context {A : Type} {B : Type}. @@ -137,7 +150,7 @@ Definition transport_eq {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P Notation "p # x" := (transport_eq _ p x) (right associativity, at level 65, only parsing). Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z. - destruct p; exact q. + destruct p; exact q. Show Proof. Defined. Notation "p @ q" := (concat p q) (at level 20). @@ -540,6 +553,10 @@ Definition isequiv_adjointify {A B : Type} (f : A -> B) (g : B -> A) (is_adjoint' f g issect isretr). +(* MetaCoq Run (tmEval (unfold concatkn) + (@safechecker_test.concat) >>= tmQuote >>= tmPrint). *) + (* fun t => tmEval cbv (print_program false 1 t) >>= tmPrint). *) + MetaCoq SafeCheck @issect'. MetaCoq SafeCheck @ap_pp. diff --git a/translations/param_binary.v b/translations/param_binary.v index 05e5ae322..a7d8c92dc 100644 --- a/translations/param_binary.v +++ b/translations/param_binary.v @@ -18,8 +18,8 @@ Fixpoint tsl_rec0 (n : nat) (o : nat) (t : term) {struct t} : term := | tLambda na A t => tLambda na (tsl_rec0 n o A) (tsl_rec0 (n+1) o t) | tLetIn na t A u => tLetIn na (tsl_rec0 n o t) (tsl_rec0 n o A) (tsl_rec0 (n+1) o u) | tApp t lu => tApp (tsl_rec0 n o t) (map (tsl_rec0 n o) lu) - | tCase ik t u br => tCase ik (tsl_rec0 n o t) (tsl_rec0 n o u) - (map (fun x => (fst x, tsl_rec0 n o (snd x))) br) + | tCase ik t u br => tCase ik (map_predicate_k id (fun k => tsl_rec0 n k) o t) (tsl_rec0 n o u) + (map_branches_k (fun x => tsl_rec0 n x) o br) | tProj p t => tProj p (tsl_rec0 n o t) (* | tFix : mfixpoint term -> nat -> term *) (* | tCoFix : mfixpoint term -> nat -> term *) @@ -114,17 +114,20 @@ Fixpoint tsl_rec1_app (app : list term) (E : tsl_table) (t : term) : term := end | tCase ik t u brs as case => - let brs' := List.map (on_snd (lift0 1)) brs in - let case1 := tCase ik (lift0 3 t) (tRel 2) brs' in - let case2 := tCase ik (lift0 3 t) (tRel 1) brs' in - match lookup_tsl_table E (IndRef (fst (fst ik))) with - | Some (tInd i _univ) => - tCase ((i, (snd (fst ik)) * 3), snd ik)%nat - (tsl_rec1_app [tsl_rec0 0 2 case1; tsl_rec0 0 1 case2] E t) - (tsl_rec1 E u) - (map (on_snd (tsl_rec1 E)) brs) - | _ => debug "tCase" (match fst (fst ik) with mkInd s _ => string_of_kername s end) - end + case + (* todo "case", but probably already wrong before + let brs' := (map_branches_k (fun x => lift x 0) 1 brs) in + let case1 := tCase ik (map_predicate_k id (fun x => lift x 0) 3 t) (tRel 2) brs' in + let case2 := tCase ik (map_predicate_k id (fun x => lift x 0) 3 t) (tRel 1) brs' in + match lookup_tsl_table E (IndRef ik.(ci_ind)) with + | Some (tInd i _univ) => + let ci' := {| ci_ind := i; ci_npar := 3 * ci.(ci_npar); ci_relevance := ci.(ci_relevance) |} in + tCase ci' + (tsl_rec1_app [tsl_rec0 0 2 case1; tsl_rec0 0 1 case2] E t) + (tsl_rec1 E u) + (map (on_snd (tsl_rec1 E)) brs) + | _ => debug "tCase" (match ik.(ci_ind) with mkInd s _ => string_of_kername s end) + end*) | tLetIn na t A u => let t0 := tsl_rec0 0 2 t in @@ -168,6 +171,8 @@ Definition tsl_mind_body (E : tsl_table) (mp : modpath) (kn : kername) - refine (mapi _ mind.(ind_bodies)). intros i ind. refine {| ind_name := tsl_ident ind.(ind_name); + ind_indices := ind.(ind_indices); + ind_sort := ind.(ind_sort); ind_type := _; ind_kelim := ind.(ind_kelim); ind_ctors := _; @@ -179,14 +184,19 @@ Definition tsl_mind_body (E : tsl_table) (mp : modpath) (kn : kername) ar). + (* constructors *) refine (mapi _ ind.(ind_ctors)). - intros k ((name, typ), nargs). - refine (tsl_ident name, _, 3 * nargs)%nat. + intros k [name args indices type arity]. + econstructor. + refine (tsl_ident name). + refine args. + refine indices. 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 typ)). + 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. Instance param : Translation := diff --git a/translations/param_cheap_packed.v b/translations/param_cheap_packed.v index e7e746b07..fb2fbabcf 100644 --- a/translations/param_cheap_packed.v +++ b/translations/param_cheap_packed.v @@ -26,8 +26,9 @@ Fixpoint tsl_rec1 (n : nat) (t : term) {struct t} : term := | tLambda x A t => tLambda x (tsl_rec1 n A) (tsl_rec1 (n+1) t) | tLetIn x a t u => tLetIn x (tsl_rec1 n a) (tsl_rec1 n t) (tsl_rec1 (n+1) u) | tApp t lu => tApp (tsl_rec1 n t) (List.map (tsl_rec1 n) lu) - | tCase ik t u br => tCase ik (tsl_rec1 n t) (tsl_rec1 n u) - (List.map (fun x => (fst x, tsl_rec1 n (snd x))) br) + | tCase ik t u brs => tCase ik + (map_predicate_k id tsl_rec1 n t) (tsl_rec1 n u) + (map_branches_k tsl_rec1 n brs) | tProj p t => tProj p (tsl_rec1 n t) (* | tFix : mfixpoint term -> nat -> term *) (* | tCoFix : mfixpoint term -> nat -> term *) @@ -121,8 +122,9 @@ Fixpoint replace t k u {struct u} := | tCast c kind ty => tCast (replace t k c) kind (replace t k ty) | tLetIn na b ty b' => tLetIn na (replace t k b) (replace t k ty) (replace (lift0 1 t) (S k) b') | tCase ind p c brs => - let brs' := List.map (on_snd (replace t k)) brs in - tCase ind (replace t k p) (replace t k c) brs' + let p' := map_predicate_k id (replace t) k p in + let brs' := map_branches_k (replace t) k brs in + tCase ind p' (replace t k c) brs' | tProj p c => tProj p (replace t k c) | tFix mfix idx => let k' := List.length mfix + k in @@ -171,6 +173,8 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) intros i ind. refine (A <- _ ;; ctors <- _ ;; ret {| ind_name := tsl_ident ind.(ind_name); + ind_sort := ind.(ind_sort); + ind_indices := ind.(ind_indices); (* Not true, should change *) ind_type := A; ind_kelim := ind.(ind_kelim); ind_ctors := ctors; @@ -182,13 +186,18 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) ret (try_reduce (fst (fst ΣE)) [] fuel (mkApp t2 i1))). + (* constructors *) refine (monad_map_i _ ind.(ind_ctors)). - intros k ((name, typ), nargs). - refine (t2 <- tsl2' typ ;; + intros k c. + refine (t2 <- tsl2' c.(cstr_type) ;; let t2 := fold_left_i (fun t i u => replace u i t) L t2 in 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 (tsl_ident name, t', nargs) + | Some t' => ret + {| cstr_name := tsl_ident c.(cstr_name); + cstr_type := t'; + cstr_args := c.(cstr_args); (* Not used by denotation yet *) + cstr_indices := c.(cstr_indices); + cstr_arity := c.(cstr_arity) |} | None => raise TranslationNotHandeled end). diff --git a/translations/param_original.v b/translations/param_original.v index b4d6f7b61..bcdeb704c 100644 --- a/translations/param_original.v +++ b/translations/param_original.v @@ -17,8 +17,8 @@ Fixpoint tsl_rec0 (n : nat) (t : term) {struct t} : term := | tLambda na A t => tLambda na (tsl_rec0 n A) (tsl_rec0 (n+1) t) | tLetIn na t A u => tLetIn na (tsl_rec0 n t) (tsl_rec0 n A) (tsl_rec0 (n+1) u) | tApp t lu => tApp (tsl_rec0 n t) (map (tsl_rec0 n) lu) - | tCase ik t u br => tCase ik (tsl_rec0 n t) (tsl_rec0 n u) - (map (fun x => (fst x, tsl_rec0 n (snd x))) br) + | tCase ik t u br => tCase ik (map_predicate_k id tsl_rec0 n t) (tsl_rec0 n u) + (map_branches_k tsl_rec0 n br) | tProj p t => tProj p (tsl_rec0 n t) (* | tFix : mfixpoint term -> nat -> term *) (* | tCoFix : mfixpoint term -> nat -> term *) @@ -89,15 +89,17 @@ Fixpoint tsl_rec1_app (app : option term) (E : tsl_table) (t : term) : term := | None => debug "tConstruct" (match i with mkInd s _ => string_of_kername s end) end | tCase ik t u brs as case => - let brs' := List.map (on_snd (lift0 1)) brs in - let case1 := tCase ik (lift0 1 t) (tRel 0) brs' in - match lookup_tsl_table E (IndRef (fst (fst ik))) with + let t' := map_predicate_k id (fun x => lift x 0) 1 t in + let brs' := map_branches_k (fun x => lift x 0) 1 brs in + let case1 := tCase ik t' (tRel 0) brs' in + match lookup_tsl_table E (IndRef ik.(ci_ind)) with | Some (tInd i _univ) => - tCase ((i, (snd (fst ik)) * 2), snd ik)%nat - (tsl_rec1_app (Some (tsl_rec0 0 case1)) E t) + let ci' := {| ci_ind := ik.(ci_ind); ci_npar := ik.(ci_npar) * 2; ci_relevance := ik.(ci_relevance) |} in + tCase ci' + (map_predicate_k id (fun k => tsl_rec1_app (Some (tsl_rec0 0 case1)) E) 0 t) (tsl_rec1 E u) - (map (on_snd (tsl_rec1 E)) brs) - | _ => debug "tCase" (match fst (fst ik) with mkInd s _ => string_of_kername s end) + (map_branches_k (fun k => tsl_rec1 E) 0 brs) + | _ => debug "tCase" (match ik.(ci_ind) with mkInd s _ => string_of_kername s end) end | tProj _ _ => todo "tsl" | tFix _ _ | tCoFix _ _ => todo "tsl" @@ -130,6 +132,8 @@ Definition tsl_mind_body (E : tsl_table) (mp : modpath) (kn : kername) - refine (mapi _ mind.(ind_bodies)). intros i ind. refine {| ind_name := tsl_ident ind.(ind_name); + ind_indices := ind.(ind_indices); + ind_sort := ind.(ind_sort); ind_type := _; ind_kelim := ind.(ind_kelim); ind_ctors := _; @@ -141,10 +145,12 @@ Definition tsl_mind_body (E : tsl_table) (mp : modpath) (kn : kername) ar). + (* constructors *) refine (mapi _ ind.(ind_ctors)). - intros k ((name, typ), nargs). - refine (tsl_ident name, _, 2 * nargs)%nat. + intros k c. + refine {| cstr_name := tsl_ident c.(cstr_name); cstr_arity := 2 * c.(cstr_arity) |}%nat. + exact c.(cstr_args). (* wrong probably *) + exact c.(cstr_indices). refine (subst_app _ [tConstruct (mkInd kn i) k []]). - refine (fold_left_i (fun t0 i u => t0 {S i := u}) _ (tsl_rec1 E typ)). + refine (fold_left_i (fun t0 i u => t0 {S i := u}) _ (tsl_rec1 E c.(cstr_type))). (* [I_n-1; ... I_0] *) refine (rev (mapi (fun i _ => tInd (mkInd kn i) []) mind.(ind_bodies))). @@ -185,6 +191,8 @@ MetaCoq Run (TC <- Translate emptyTC "nat" ;; MetaCoq Run (TC <- Translate nat_TC "bool" ;; tmDefinition "bool_TC" TC ). Import Init.Nat. +(* todo "case" *) +(* MetaCoq Run (Translate bool_TC "pred"). @@ -448,7 +456,7 @@ Module Axioms. Defined. End Axioms. - +*) diff --git a/translations/times_bool_fun.v b/translations/times_bool_fun.v index 92ad91548..b8fb35d5e 100644 --- a/translations/times_bool_fun.v +++ b/translations/times_bool_fun.v @@ -162,6 +162,8 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) (kn : kername) let ctors' := List.split (mapi _ ind.(ind_ctors)) in (_ :: fst ctors', {| ind_name := tsl_ident ind.(ind_name); + ind_sort := ind.(ind_sort); + ind_indices := ind.(ind_indices); ind_type := ind_type'; ind_kelim := ind.(ind_kelim); ind_ctors := snd ctors'; @@ -174,11 +176,11 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) (kn : kername) refine (List.fold_left _ L' (snd L)). exact (fun t decl => tProd decl.(decl_name) decl.(decl_type) t). + (* constructors *) - intros k ((name, typ), nargs). + intros k [name argctx indices typ nargs]. simple refine (let ctor_type' := _ in ((ConstructRef (mkInd kn i) k, pouet (tConstruct (mkInd kn' i) k []) _), - (tsl_ident name, ctor_type', nargs))). + (Build_constructor_body (tsl_ident name) argctx indices ctor_type' nargs))). * refine (fold_left_i (fun t i _ => replace (proj1 (tRel i)) (tRel i) t) mind.(ind_bodies) _). refine (let L := decompose_prod typ in _). diff --git a/translations/translation_utils.v b/translations/translation_utils.v index b9acffcf9..14a403737 100644 --- a/translations/translation_utils.v +++ b/translations/translation_utils.v @@ -276,9 +276,9 @@ Definition ImplementExisting {tsl : Translation} (ΣE : tsl_context) (id : ident match List.nth_error ctors k with | None => fail_nf ("The body of " ^ id ^ " has not enough constructors. This is a bug.") - | Some (_, ty, _) => (* keep id? *) + | Some cstr => (* keep id? *) tmDebug "plop3" ;; - let A := subst0 (inds kn [] (* FIXME uctx *) (ind_bodies d)) ty in + let A := subst0 (inds kn [] (* FIXME uctx *) (ind_bodies d)) cstr.(cstr_type) in tmDebug "plop4" ;; tA' <- tmEval lazy (tsl_ty ΣE A) ;; tmDebug "plop5" ;;