diff --git a/Makefile b/Makefile index 79b3720..ef5b76f 100644 --- a/Makefile +++ b/Makefile @@ -16,12 +16,12 @@ uninstall: $(COQMAKEFILE) $(MAKE) -f $(COQMAKEFILE) uninstall theories/Autosubst2/syntax.v theories/Autosubst2/core.v theories/Autosubst2/fintype.v : syntax.sig - autosubst -f -v ge813 -s ucoq -o theories/Autosubst2/syntax.v syntax.sig + autosubst -f -v ge813 -s coq -o theories/Autosubst2/syntax.v syntax.sig .PHONY: clean FORCE clean: test ! -f $(COQMAKEFILE) || ( $(MAKE) -f $(COQMAKEFILE) clean && rm $(COQMAKEFILE) ) - rm -f theories/Autosubst2/syntax.v theories/Autosubst2/core.v theories/Autosubst2/unscoped.v + rm -f theories/Autosubst2/syntax.v theories/Autosubst2/core.v theories/Autosubst2/fintype.v FORCE: diff --git a/syntax.sig b/syntax.sig index 24931eb..6b7e4df 100644 --- a/syntax.sig +++ b/syntax.sig @@ -16,7 +16,4 @@ PPair : PTm -> PTm -> PTm PProj : PTag -> PTm -> PTm PBind : BTag -> PTm -> (bind PTm in PTm) -> PTm PUniv : nat -> PTm -PNat : PTm -PZero : PTm -PSuc : PTm -> PTm -PInd : (bind PTm in PTm) -> PTm -> PTm -> (bind PTm,PTm in PTm) -> PTm \ No newline at end of file +PBot : PTm \ No newline at end of file diff --git a/theories/Autosubst2/fintype.v b/theories/Autosubst2/fintype.v new file mode 100644 index 0000000..99508b6 --- /dev/null +++ b/theories/Autosubst2/fintype.v @@ -0,0 +1,419 @@ +(** * Autosubst Header for Scoped Syntax + Our development utilises well-scoped de Bruijn syntax. This means that the de Bruijn indices are taken from finite types. As a consequence, any kind of substitution or environment used in conjunction with well-scoped syntax takes the form of a mapping from some finite type _I^n_. In particular, _renamings_ are mappings _I^n -> I^m_. Here we develop the theory of how these parts interact. + +Version: December 11, 2019. +*) +Require Import core. +Require Import Setoid Morphisms Relation_Definitions. + +Set Implicit Arguments. +Unset Strict Implicit. + +Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y := + match p with eq_refl => eq_refl end. + +Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y := + match q with eq_refl => match p with eq_refl => eq_refl end end. + +(** ** Primitives of the Sigma Calculus + We implement the finite type with _n_ elements, _I^n_, as the _n_-fold iteration of the Option Type. _I^0_ is implemented as the empty type. +*) + +Fixpoint fin (n : nat) : Type := + match n with + | 0 => False + | S m => option (fin m) + end. + +(** Renamings and Injective Renamings + _Renamings_ are mappings between finite types. +*) +Definition ren (m n : nat) : Type := fin m -> fin n. + +Definition id {X} := @Datatypes.id X. + +Definition idren {k: nat} : ren k k := @Datatypes.id (fin k). + +(** We give a special name, to the newest element in a non-empty finite type, as it usually corresponds to a freshly bound variable. *) +Definition var_zero {n : nat} : fin (S n) := None. + +Definition null {T} (i : fin 0) : T := match i with end. + +Definition shift {n : nat} : ren n (S n) := + Some. + +(** Extension of Finite Mappings + Assume we are given a mapping _f_ from _I^n_ to some type _X_, then we can _extend_ this mapping with a new value from _x : X_ to a mapping from _I^n+1_ to _X_. We denote this operation by _x . f_ and define it as follows: +*) +Definition scons {X : Type} {n : nat} (x : X) (f : fin n -> X) (m : fin (S n)) : X := + match m with + | None => x + | Some i => f i + end. + +#[ export ] +Hint Opaque scons : rewrite. + +(** ** Type Class Instances for Notation *) + +(** *** Type classes for renamings. *) + +Class Ren1 (X1 : Type) (Y Z : Type) := + ren1 : X1 -> Y -> Z. + +Class Ren2 (X1 X2 : Type) (Y Z : Type) := + ren2 : X1 -> X2 -> Y -> Z. + +Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) := + ren3 : X1 -> X2 -> X3 -> Y -> Z. + +Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) := + ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z. + +Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) := + ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z. + +Module RenNotations. + Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s ⟨ xi1 ⟩") : subst_scope. + + Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ⟩") : subst_scope. + + Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope. + + Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4 xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope. + + Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5 xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope. + + Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope. + + Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope. +End RenNotations. + +(** *** Type Classes for Substiution *) + +Class Subst1 (X1 : Type) (Y Z: Type) := + subst1 : X1 -> Y -> Z. + +Class Subst2 (X1 X2 : Type) (Y Z: Type) := + subst2 : X1 -> X2 -> Y -> Z. + +Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) := + subst3 : X1 -> X2 -> X3 -> Y -> Z. + +Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) := + subst4 : X1 -> X2 -> X3 -> X4 -> Y -> Z. + +Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) := + subst5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z. + +Module SubstNotations. + Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope. + + Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/' tau ]") : subst_scope. +End SubstNotations. + +(** ** Type Class for Variables *) +Class Var X Y := + ids : X -> Y. + + +(** ** Proofs for substitution primitives *) + +(** Forward Function Composition + Substitutions represented as functions are ubiquitious in this development and we often have to compose them, without talking about their pointwise behaviour. + That is, we are interested in the forward compostion of functions, _f o g_, for which we introduce a convenient notation, "f >> g". The direction of the arrow serves as a reminder of the _forward_ nature of this composition, that is first apply _f_, then _g_. *) + +Arguments funcomp {X Y Z} (g)%fscope (f)%fscope. + +Module CombineNotations. + Notation "f >> g" := (funcomp g f) (at level 50) : fscope. + + Notation "s .: sigma" := (scons s sigma) (at level 55, sigma at next level, right associativity) : subst_scope. + + #[ global ] + Open Scope fscope. + #[ global ] + Open Scope subst_scope. +End CombineNotations. + +Import CombineNotations. + + +(** Generic lifting operation for renamings *) +Definition up_ren {m n} (xi : ren m n) : ren (S m) (S n) := + var_zero .: xi >> shift. + +(** Generic proof that lifting of renamings composes. *) +Lemma up_ren_ren k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) : + forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x. +Proof. + intros [x|]. + - cbn. unfold funcomp. now rewrite <- E. + - reflexivity. +Qed. + +Arguments up_ren_ren {k l m} xi zeta rho E. + +Lemma fin_eta {X} (f g : fin 0 -> X) : + pointwise_relation _ eq f g. +Proof. intros []. Qed. + +(** Eta laws *) +Lemma scons_eta' {T} {n : nat} (f : fin (S n) -> T) : + pointwise_relation _ eq (f var_zero .: (funcomp f shift)) f. +Proof. intros x. destruct x; reflexivity. Qed. + +Lemma scons_eta_id' {n : nat} : + pointwise_relation (fin (S n)) eq (var_zero .: shift) id. +Proof. intros x. destruct x; reflexivity. Qed. + +Lemma scons_comp' {T:Type} {U} {m} (s: T) (sigma: fin m -> T) (tau: T -> U) : + pointwise_relation _ eq (funcomp tau (s .: sigma)) ((tau s) .: (funcomp tau sigma)). +Proof. intros x. destruct x; reflexivity. Qed. + +(* Lemma scons_tail'_pointwise {X} {n} (s : X) (f : fin n -> X) : *) +(* pointwise_relation _ eq (funcomp (scons s f) shift) f. *) +(* Proof. *) +(* reflexivity. *) +(* Qed. *) + +(* Lemma scons_tail' {X} {n} (s : X) (f : fin n -> X) x : *) +(* (scons s f (shift x)) = f x. *) +(* Proof. *) +(* reflexivity. *) +(* Qed. *) + +(* Morphism for Setoid Rewriting. The only morphism that can be defined statically. *) +#[export] Instance scons_morphism {X: Type} {n:nat} : + Proper (eq ==> pointwise_relation _ eq ==> pointwise_relation _ eq) (@scons X n). +Proof. + intros t t' -> sigma tau H. + intros [x|]. + cbn. apply H. + reflexivity. +Qed. + +#[export] Instance scons_morphism2 {X: Type} {n: nat} : + Proper (eq ==> pointwise_relation _ eq ==> eq ==> eq) (@scons X n). +Proof. + intros ? t -> sigma tau H ? x ->. + destruct x as [x|]. + cbn. apply H. + reflexivity. +Qed. + +(** ** Variadic Substitution Primitives *) + +Fixpoint shift_p (p : nat) {n} : ren n (p + n) := + fun n => match p with + | 0 => n + | S p => Some (shift_p p n) + end. + +Fixpoint scons_p {X: Type} {m : nat} : forall {n} (f : fin m -> X) (g : fin n -> X), fin (m + n) -> X. +Proof. + destruct m. + - intros n f g. exact g. + - intros n f g. cbn. apply scons. + + exact (f var_zero). + + apply scons_p. + * intros z. exact (f (Some z)). + * exact g. +Defined. + +#[export] Hint Opaque scons_p : rewrite. + +#[export] Instance scons_p_morphism {X: Type} {m n:nat} : + Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> pointwise_relation _ eq) (@scons_p X m n). +Proof. + intros sigma sigma' Hsigma tau tau' Htau. + intros x. + induction m. + - cbn. apply Htau. + - cbn. change (fin (S m + n)) with (fin (S (m + n))) in x. + destruct x as [x|]. + + cbn. apply IHm. + intros ?. apply Hsigma. + + cbn. apply Hsigma. +Qed. + +#[export] Instance scons_p_morphism2 {X: Type} {m n:nat} : + Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> eq ==> eq) (@scons_p X m n). +Proof. + intros sigma sigma' Hsigma tau tau' Htau ? x ->. + induction m. + - cbn. apply Htau. + - cbn. change (fin (S m + n)) with (fin (S (m + n))) in x. + destruct x as [x|]. + + cbn. apply IHm. + intros ?. apply Hsigma. + + cbn. apply Hsigma. +Qed. + +Definition zero_p {m : nat} {n} : fin m -> fin (m + n). +Proof. + induction m. + - intros []. + - intros [x|]. + + exact (shift_p 1 (IHm x)). + + exact var_zero. +Defined. + +Lemma scons_p_head' {X} {m n} (f : fin m -> X) (g : fin n -> X) z: + (scons_p f g) (zero_p z) = f z. +Proof. + induction m. + - inversion z. + - destruct z. + + simpl. simpl. now rewrite IHm. + + reflexivity. +Qed. + +Lemma scons_p_head_pointwise {X} {m n} (f : fin m -> X) (g : fin n -> X) : + pointwise_relation _ eq (funcomp (scons_p f g) zero_p) f. +Proof. + intros z. + unfold funcomp. + induction m. + - inversion z. + - destruct z. + + simpl. now rewrite IHm. + + reflexivity. +Qed. + +Lemma scons_p_tail' X m n (f : fin m -> X) (g : fin n -> X) z : + scons_p f g (shift_p m z) = g z. +Proof. induction m; cbn; eauto. Qed. + +Lemma scons_p_tail_pointwise X m n (f : fin m -> X) (g : fin n -> X) : + pointwise_relation _ eq (funcomp (scons_p f g) (shift_p m)) g. +Proof. intros z. induction m; cbn; eauto. Qed. + +Lemma destruct_fin {m n} (x : fin (m + n)): + (exists x', x = zero_p x') \/ exists x', x = shift_p m x'. +Proof. + induction m; simpl in *. + - right. eauto. + - destruct x as [x|]. + + destruct (IHm x) as [[x' ->] |[x' ->]]. + * left. now exists (Some x'). + * right. eauto. + + left. exists None. eauto. +Qed. + +Lemma scons_p_comp' X Y m n (f : fin m -> X) (g : fin n -> X) (h : X -> Y) : + pointwise_relation _ eq (funcomp h (scons_p f g)) (scons_p (f >> h) (g >> h)). +Proof. + intros x. + destruct (destruct_fin x) as [[x' ->]|[x' ->]]. + (* TODO better way to solve this? *) + - revert x'. + apply pointwise_forall. + change (fun x => (scons_p f g >> h) (zero_p x)) with (zero_p >> scons_p f g >> h). + now setoid_rewrite scons_p_head_pointwise. + - revert x'. + apply pointwise_forall. + change (fun x => (scons_p f g >> h) (shift_p m x)) with (shift_p m >> scons_p f g >> h). + change (fun x => scons_p (f >> h) (g >> h) (shift_p m x)) with (shift_p m >> scons_p (f >> h) (g >> h)). + now rewrite !scons_p_tail_pointwise. +Qed. + + +Lemma scons_p_congr {X} {m n} (f f' : fin m -> X) (g g': fin n -> X) z: + (forall x, f x = f' x) -> (forall x, g x = g' x) -> scons_p f g z = scons_p f' g' z. +Proof. intros H1 H2. induction m; eauto. cbn. destruct z; eauto. Qed. + +(** Generic n-ary lifting operation. *) +Definition upRen_p p { m : nat } { n : nat } (xi : (fin) (m) -> (fin) (n)) : fin (p + m) -> fin (p + n) := + scons_p (zero_p ) (xi >> shift_p _). + +Arguments upRen_p p {m n} xi. + +(** Generic proof for composition of n-ary lifting. *) +Lemma up_ren_ren_p p k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) : + forall x, (upRen_p p xi >> upRen_p p zeta) x = upRen_p p rho x. +Proof. + intros x. destruct (destruct_fin x) as [[? ->]|[? ->]]. + - unfold upRen_p. unfold funcomp. now repeat rewrite scons_p_head'. + - unfold upRen_p. unfold funcomp. repeat rewrite scons_p_tail'. + now rewrite <- E. +Qed. + + +Arguments zero_p m {n}. +Arguments scons_p {X} m {n} f g. + +Lemma scons_p_eta {X} {m n} {f : fin m -> X} + {g : fin n -> X} (h: fin (m + n) -> X) {z: fin (m + n)}: + (forall x, g x = h (shift_p m x)) -> (forall x, f x = h (zero_p m x)) -> scons_p m f g z = h z. +Proof. + intros H1 H2. destruct (destruct_fin z) as [[? ->] |[? ->]]. + - rewrite scons_p_head'. eauto. + - rewrite scons_p_tail'. eauto. +Qed. + +Arguments scons_p_eta {X} {m n} {f g} h {z}. +Arguments scons_p_congr {X} {m n} {f f'} {g g'} {z}. + +(** ** Notations for Scoped Syntax *) + +Module ScopedNotations. + Include RenNotations. + Include SubstNotations. + Include CombineNotations. + +(* Notation "s , sigma" := (scons s sigma) (at level 60, format "s , sigma", right associativity) : subst_scope. *) + + Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope. + + Notation "↑" := (shift) : subst_scope. + + #[global] + Open Scope fscope. + #[global] + Open Scope subst_scope. +End ScopedNotations. + + +(** ** Tactics for Scoped Syntax *) + +Tactic Notation "auto_case" tactic(t) := (match goal with + | [|- forall (i : fin 0), _] => intros []; t + | [|- forall (i : fin (S (S (S (S _))))), _] => intros [[[[|]|]|]|]; t + | [|- forall (i : fin (S (S (S _)))), _] => intros [[[|]|]|]; t + | [|- forall (i : fin (S (S _))), _] => intros [[?|]|]; t + | [|- forall (i : fin (S _)), _] => intros [?|]; t + end). + +#[export] Hint Rewrite @scons_p_head' @scons_p_tail' : FunctorInstances. + +(** Generic fsimpl tactic: simplifies the above primitives in a goal. *) +Ltac fsimpl := + repeat match goal with + | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *) + | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *) + | [|- context [id ?s]] => change (id s) with s + | [|- context[(?f >> ?g) >> ?h]] => change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *) + (* | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head *) + | [|- context[(?s .: ?sigma) var_zero]] => change ((s.:sigma) var_zero) with s + | [|- context[(?s .: ?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m) + (* first [progress setoid_rewrite scons_tail' | progress setoid_rewrite scons_tail'_pointwise ] *) + | [|- context[idren >> ?f]] => change (idren >> f) with f + | [|- context[?f >> idren]] => change (f >> idren) with f + | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g (* f should evaluate to shift *) + | [|- context[?x2 .: (funcomp ?f shift)]] => change (scons x2 (funcomp f shift)) with (scons (f var_zero) (funcomp f shift)); setoid_rewrite (@scons_eta' _ _ f); eta_reduce + | [|- context[?f var_zero .: ?g]] => change (scons (f var_zero) g) with (scons (f var_zero) (funcomp f shift)); setoid_rewrite scons_eta'; eta_reduce + | [|- _ = ?h (?f ?s)] => change (h (f s)) with ((f >> h) s) + | [|- ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s) + | [|- context[funcomp _ (scons _ _)]] => setoid_rewrite scons_comp'; eta_reduce + | [|- context[funcomp _ (scons_p _ _ _)]] => setoid_rewrite scons_p_comp'; eta_reduce + | [|- context[scons (@var_zero _) shift]] => setoid_rewrite scons_eta_id'; eta_reduce + (* | _ => progress autorewrite with FunctorInstances *) + | [|- context[funcomp (scons_p _ _ _) (zero_p _)]] => + first [progress setoid_rewrite scons_p_head_pointwise | progress setoid_rewrite scons_p_head' ] + | [|- context[scons_p _ _ _ (zero_p _ _)]] => setoid_rewrite scons_p_head' + | [|- context[funcomp (scons_p _ _ _) (shift_p _)]] => + first [progress setoid_rewrite scons_p_tail_pointwise | progress setoid_rewrite scons_p_tail' ] + | [|- context[scons_p _ _ _ (shift_p _ _)]] => setoid_rewrite scons_p_tail' + | _ => first [progress minimize | progress cbn [shift scons scons_p] ] + end. diff --git a/theories/Autosubst2/syntax.v b/theories/Autosubst2/syntax.v index ee8b076..ff9ec18 100644 --- a/theories/Autosubst2/syntax.v +++ b/theories/Autosubst2/syntax.v @@ -1,4 +1,4 @@ -Require Import core unscoped. +Require Import core fintype. Require Import Setoid Morphisms Relation_Definitions. @@ -33,372 +33,369 @@ Proof. exact (eq_refl). Qed. -Inductive PTm : Type := - | VarPTm : nat -> PTm - | PAbs : PTm -> PTm - | PApp : PTm -> PTm -> PTm - | PPair : PTm -> PTm -> PTm - | PProj : PTag -> PTm -> PTm - | PBind : BTag -> PTm -> PTm -> PTm - | PUniv : nat -> PTm - | PNat : PTm - | PZero : PTm - | PSuc : PTm -> PTm - | PInd : PTm -> PTm -> PTm -> PTm -> PTm. +Inductive PTm (n_PTm : nat) : Type := + | VarPTm : fin n_PTm -> PTm n_PTm + | PAbs : PTm (S n_PTm) -> PTm n_PTm + | PApp : PTm n_PTm -> PTm n_PTm -> PTm n_PTm + | PPair : PTm n_PTm -> PTm n_PTm -> PTm n_PTm + | PProj : PTag -> PTm n_PTm -> PTm n_PTm + | PBind : BTag -> PTm n_PTm -> PTm (S n_PTm) -> PTm n_PTm + | PUniv : nat -> PTm n_PTm + | PBot : PTm n_PTm. -Lemma congr_PAbs {s0 : PTm} {t0 : PTm} (H0 : s0 = t0) : PAbs s0 = PAbs t0. +Lemma congr_PAbs {m_PTm : nat} {s0 : PTm (S m_PTm)} {t0 : PTm (S m_PTm)} + (H0 : s0 = t0) : PAbs m_PTm s0 = PAbs m_PTm t0. Proof. -exact (eq_trans eq_refl (ap (fun x => PAbs x) H0)). +exact (eq_trans eq_refl (ap (fun x => PAbs m_PTm x) H0)). Qed. -Lemma congr_PApp {s0 : PTm} {s1 : PTm} {t0 : PTm} {t1 : PTm} (H0 : s0 = t0) - (H1 : s1 = t1) : PApp s0 s1 = PApp t0 t1. +Lemma congr_PApp {m_PTm : nat} {s0 : PTm m_PTm} {s1 : PTm m_PTm} + {t0 : PTm m_PTm} {t1 : PTm m_PTm} (H0 : s0 = t0) (H1 : s1 = t1) : + PApp m_PTm s0 s1 = PApp m_PTm t0 t1. Proof. -exact (eq_trans (eq_trans eq_refl (ap (fun x => PApp x s1) H0)) - (ap (fun x => PApp t0 x) H1)). +exact (eq_trans (eq_trans eq_refl (ap (fun x => PApp m_PTm x s1) H0)) + (ap (fun x => PApp m_PTm t0 x) H1)). Qed. -Lemma congr_PPair {s0 : PTm} {s1 : PTm} {t0 : PTm} {t1 : PTm} (H0 : s0 = t0) - (H1 : s1 = t1) : PPair s0 s1 = PPair t0 t1. +Lemma congr_PPair {m_PTm : nat} {s0 : PTm m_PTm} {s1 : PTm m_PTm} + {t0 : PTm m_PTm} {t1 : PTm m_PTm} (H0 : s0 = t0) (H1 : s1 = t1) : + PPair m_PTm s0 s1 = PPair m_PTm t0 t1. Proof. -exact (eq_trans (eq_trans eq_refl (ap (fun x => PPair x s1) H0)) - (ap (fun x => PPair t0 x) H1)). +exact (eq_trans (eq_trans eq_refl (ap (fun x => PPair m_PTm x s1) H0)) + (ap (fun x => PPair m_PTm t0 x) H1)). Qed. -Lemma congr_PProj {s0 : PTag} {s1 : PTm} {t0 : PTag} {t1 : PTm} - (H0 : s0 = t0) (H1 : s1 = t1) : PProj s0 s1 = PProj t0 t1. +Lemma congr_PProj {m_PTm : nat} {s0 : PTag} {s1 : PTm m_PTm} {t0 : PTag} + {t1 : PTm m_PTm} (H0 : s0 = t0) (H1 : s1 = t1) : + PProj m_PTm s0 s1 = PProj m_PTm t0 t1. Proof. -exact (eq_trans (eq_trans eq_refl (ap (fun x => PProj x s1) H0)) - (ap (fun x => PProj t0 x) H1)). +exact (eq_trans (eq_trans eq_refl (ap (fun x => PProj m_PTm x s1) H0)) + (ap (fun x => PProj m_PTm t0 x) H1)). Qed. -Lemma congr_PBind {s0 : BTag} {s1 : PTm} {s2 : PTm} {t0 : BTag} {t1 : PTm} - {t2 : PTm} (H0 : s0 = t0) (H1 : s1 = t1) (H2 : s2 = t2) : - PBind s0 s1 s2 = PBind t0 t1 t2. +Lemma congr_PBind {m_PTm : nat} {s0 : BTag} {s1 : PTm m_PTm} + {s2 : PTm (S m_PTm)} {t0 : BTag} {t1 : PTm m_PTm} {t2 : PTm (S m_PTm)} + (H0 : s0 = t0) (H1 : s1 = t1) (H2 : s2 = t2) : + PBind m_PTm s0 s1 s2 = PBind m_PTm t0 t1 t2. Proof. exact (eq_trans - (eq_trans (eq_trans eq_refl (ap (fun x => PBind x s1 s2) H0)) - (ap (fun x => PBind t0 x s2) H1)) - (ap (fun x => PBind t0 t1 x) H2)). + (eq_trans (eq_trans eq_refl (ap (fun x => PBind m_PTm x s1 s2) H0)) + (ap (fun x => PBind m_PTm t0 x s2) H1)) + (ap (fun x => PBind m_PTm t0 t1 x) H2)). Qed. -Lemma congr_PUniv {s0 : nat} {t0 : nat} (H0 : s0 = t0) : PUniv s0 = PUniv t0. +Lemma congr_PUniv {m_PTm : nat} {s0 : nat} {t0 : nat} (H0 : s0 = t0) : + PUniv m_PTm s0 = PUniv m_PTm t0. Proof. -exact (eq_trans eq_refl (ap (fun x => PUniv x) H0)). +exact (eq_trans eq_refl (ap (fun x => PUniv m_PTm x) H0)). Qed. -Lemma congr_PNat : PNat = PNat. +Lemma congr_PBot {m_PTm : nat} : PBot m_PTm = PBot m_PTm. Proof. exact (eq_refl). Qed. -Lemma congr_PZero : PZero = PZero. -Proof. -exact (eq_refl). -Qed. - -Lemma congr_PSuc {s0 : PTm} {t0 : PTm} (H0 : s0 = t0) : PSuc s0 = PSuc t0. -Proof. -exact (eq_trans eq_refl (ap (fun x => PSuc x) H0)). -Qed. - -Lemma congr_PInd {s0 : PTm} {s1 : PTm} {s2 : PTm} {s3 : PTm} {t0 : PTm} - {t1 : PTm} {t2 : PTm} {t3 : PTm} (H0 : s0 = t0) (H1 : s1 = t1) - (H2 : s2 = t2) (H3 : s3 = t3) : PInd s0 s1 s2 s3 = PInd t0 t1 t2 t3. -Proof. -exact (eq_trans - (eq_trans - (eq_trans (eq_trans eq_refl (ap (fun x => PInd x s1 s2 s3) H0)) - (ap (fun x => PInd t0 x s2 s3) H1)) - (ap (fun x => PInd t0 t1 x s3) H2)) - (ap (fun x => PInd t0 t1 t2 x) H3)). -Qed. - -Lemma upRen_PTm_PTm (xi : nat -> nat) : nat -> nat. +Lemma upRen_PTm_PTm {m : nat} {n : nat} (xi : fin m -> fin n) : + fin (S m) -> fin (S n). Proof. exact (up_ren xi). Defined. -Fixpoint ren_PTm (xi_PTm : nat -> nat) (s : PTm) {struct s} : PTm := - match s with - | VarPTm s0 => VarPTm (xi_PTm s0) - | PAbs s0 => PAbs (ren_PTm (upRen_PTm_PTm xi_PTm) s0) - | PApp s0 s1 => PApp (ren_PTm xi_PTm s0) (ren_PTm xi_PTm s1) - | PPair s0 s1 => PPair (ren_PTm xi_PTm s0) (ren_PTm xi_PTm s1) - | PProj s0 s1 => PProj s0 (ren_PTm xi_PTm s1) - | PBind s0 s1 s2 => - PBind s0 (ren_PTm xi_PTm s1) (ren_PTm (upRen_PTm_PTm xi_PTm) s2) - | PUniv s0 => PUniv s0 - | PNat => PNat - | PZero => PZero - | PSuc s0 => PSuc (ren_PTm xi_PTm s0) - | PInd s0 s1 s2 s3 => - PInd (ren_PTm (upRen_PTm_PTm xi_PTm) s0) (ren_PTm xi_PTm s1) - (ren_PTm xi_PTm s2) - (ren_PTm (upRen_PTm_PTm (upRen_PTm_PTm xi_PTm)) s3) - end. - -Lemma up_PTm_PTm (sigma : nat -> PTm) : nat -> PTm. +Lemma upRen_list_PTm_PTm (p : nat) {m : nat} {n : nat} (xi : fin m -> fin n) + : fin (plus p m) -> fin (plus p n). Proof. -exact (scons (VarPTm var_zero) (funcomp (ren_PTm shift) sigma)). +exact (upRen_p p xi). Defined. -Fixpoint subst_PTm (sigma_PTm : nat -> PTm) (s : PTm) {struct s} : PTm := +Fixpoint ren_PTm {m_PTm : nat} {n_PTm : nat} +(xi_PTm : fin m_PTm -> fin n_PTm) (s : PTm m_PTm) {struct s} : PTm n_PTm := match s with - | VarPTm s0 => sigma_PTm s0 - | PAbs s0 => PAbs (subst_PTm (up_PTm_PTm sigma_PTm) s0) - | PApp s0 s1 => PApp (subst_PTm sigma_PTm s0) (subst_PTm sigma_PTm s1) - | PPair s0 s1 => PPair (subst_PTm sigma_PTm s0) (subst_PTm sigma_PTm s1) - | PProj s0 s1 => PProj s0 (subst_PTm sigma_PTm s1) - | PBind s0 s1 s2 => - PBind s0 (subst_PTm sigma_PTm s1) (subst_PTm (up_PTm_PTm sigma_PTm) s2) - | PUniv s0 => PUniv s0 - | PNat => PNat - | PZero => PZero - | PSuc s0 => PSuc (subst_PTm sigma_PTm s0) - | PInd s0 s1 s2 s3 => - PInd (subst_PTm (up_PTm_PTm sigma_PTm) s0) (subst_PTm sigma_PTm s1) - (subst_PTm sigma_PTm s2) - (subst_PTm (up_PTm_PTm (up_PTm_PTm sigma_PTm)) s3) + | VarPTm _ s0 => VarPTm n_PTm (xi_PTm s0) + | PAbs _ s0 => PAbs n_PTm (ren_PTm (upRen_PTm_PTm xi_PTm) s0) + | PApp _ s0 s1 => PApp n_PTm (ren_PTm xi_PTm s0) (ren_PTm xi_PTm s1) + | PPair _ s0 s1 => PPair n_PTm (ren_PTm xi_PTm s0) (ren_PTm xi_PTm s1) + | PProj _ s0 s1 => PProj n_PTm s0 (ren_PTm xi_PTm s1) + | PBind _ s0 s1 s2 => + PBind n_PTm s0 (ren_PTm xi_PTm s1) (ren_PTm (upRen_PTm_PTm xi_PTm) s2) + | PUniv _ s0 => PUniv n_PTm s0 + | PBot _ => PBot n_PTm end. -Lemma upId_PTm_PTm (sigma : nat -> PTm) (Eq : forall x, sigma x = VarPTm x) : - forall x, up_PTm_PTm sigma x = VarPTm x. +Lemma up_PTm_PTm {m : nat} {n_PTm : nat} (sigma : fin m -> PTm n_PTm) : + fin (S m) -> PTm (S n_PTm). +Proof. +exact (scons (VarPTm (S n_PTm) var_zero) (funcomp (ren_PTm shift) sigma)). +Defined. + +Lemma up_list_PTm_PTm (p : nat) {m : nat} {n_PTm : nat} + (sigma : fin m -> PTm n_PTm) : fin (plus p m) -> PTm (plus p n_PTm). +Proof. +exact (scons_p p (funcomp (VarPTm (plus p n_PTm)) (zero_p p)) + (funcomp (ren_PTm (shift_p p)) sigma)). +Defined. + +Fixpoint subst_PTm {m_PTm : nat} {n_PTm : nat} +(sigma_PTm : fin m_PTm -> PTm n_PTm) (s : PTm m_PTm) {struct s} : PTm n_PTm +:= + match s with + | VarPTm _ s0 => sigma_PTm s0 + | PAbs _ s0 => PAbs n_PTm (subst_PTm (up_PTm_PTm sigma_PTm) s0) + | PApp _ s0 s1 => + PApp n_PTm (subst_PTm sigma_PTm s0) (subst_PTm sigma_PTm s1) + | PPair _ s0 s1 => + PPair n_PTm (subst_PTm sigma_PTm s0) (subst_PTm sigma_PTm s1) + | PProj _ s0 s1 => PProj n_PTm s0 (subst_PTm sigma_PTm s1) + | PBind _ s0 s1 s2 => + PBind n_PTm s0 (subst_PTm sigma_PTm s1) + (subst_PTm (up_PTm_PTm sigma_PTm) s2) + | PUniv _ s0 => PUniv n_PTm s0 + | PBot _ => PBot n_PTm + end. + +Lemma upId_PTm_PTm {m_PTm : nat} (sigma : fin m_PTm -> PTm m_PTm) + (Eq : forall x, sigma x = VarPTm m_PTm x) : + forall x, up_PTm_PTm sigma x = VarPTm (S m_PTm) x. Proof. exact (fun n => match n with - | S n' => ap (ren_PTm shift) (Eq n') - | O => eq_refl + | Some fin_n => ap (ren_PTm shift) (Eq fin_n) + | None => eq_refl end). Qed. -Fixpoint idSubst_PTm (sigma_PTm : nat -> PTm) -(Eq_PTm : forall x, sigma_PTm x = VarPTm x) (s : PTm) {struct s} : -subst_PTm sigma_PTm s = s := - match s with - | VarPTm s0 => Eq_PTm s0 - | PAbs s0 => - congr_PAbs - (idSubst_PTm (up_PTm_PTm sigma_PTm) (upId_PTm_PTm _ Eq_PTm) s0) - | PApp s0 s1 => - congr_PApp (idSubst_PTm sigma_PTm Eq_PTm s0) - (idSubst_PTm sigma_PTm Eq_PTm s1) - | PPair s0 s1 => - congr_PPair (idSubst_PTm sigma_PTm Eq_PTm s0) - (idSubst_PTm sigma_PTm Eq_PTm s1) - | PProj s0 s1 => congr_PProj (eq_refl s0) (idSubst_PTm sigma_PTm Eq_PTm s1) - | PBind s0 s1 s2 => - congr_PBind (eq_refl s0) (idSubst_PTm sigma_PTm Eq_PTm s1) - (idSubst_PTm (up_PTm_PTm sigma_PTm) (upId_PTm_PTm _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => congr_PSuc (idSubst_PTm sigma_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (idSubst_PTm (up_PTm_PTm sigma_PTm) (upId_PTm_PTm _ Eq_PTm) s0) - (idSubst_PTm sigma_PTm Eq_PTm s1) (idSubst_PTm sigma_PTm Eq_PTm s2) - (idSubst_PTm (up_PTm_PTm (up_PTm_PTm sigma_PTm)) - (upId_PTm_PTm _ (upId_PTm_PTm _ Eq_PTm)) s3) - end. - -Lemma upExtRen_PTm_PTm (xi : nat -> nat) (zeta : nat -> nat) - (Eq : forall x, xi x = zeta x) : - forall x, upRen_PTm_PTm xi x = upRen_PTm_PTm zeta x. +Lemma upId_list_PTm_PTm {p : nat} {m_PTm : nat} + (sigma : fin m_PTm -> PTm m_PTm) (Eq : forall x, sigma x = VarPTm m_PTm x) + : forall x, up_list_PTm_PTm p sigma x = VarPTm (plus p m_PTm) x. Proof. -exact (fun n => match n with - | S n' => ap shift (Eq n') - | O => eq_refl - end). +exact (fun n => + scons_p_eta (VarPTm (plus p m_PTm)) + (fun n => ap (ren_PTm (shift_p p)) (Eq n)) (fun n => eq_refl)). Qed. -Fixpoint extRen_PTm (xi_PTm : nat -> nat) (zeta_PTm : nat -> nat) -(Eq_PTm : forall x, xi_PTm x = zeta_PTm x) (s : PTm) {struct s} : +Fixpoint idSubst_PTm {m_PTm : nat} (sigma_PTm : fin m_PTm -> PTm m_PTm) +(Eq_PTm : forall x, sigma_PTm x = VarPTm m_PTm x) (s : PTm m_PTm) {struct s} + : subst_PTm sigma_PTm s = s := + match s with + | VarPTm _ s0 => Eq_PTm s0 + | PAbs _ s0 => + congr_PAbs + (idSubst_PTm (up_PTm_PTm sigma_PTm) (upId_PTm_PTm _ Eq_PTm) s0) + | PApp _ s0 s1 => + congr_PApp (idSubst_PTm sigma_PTm Eq_PTm s0) + (idSubst_PTm sigma_PTm Eq_PTm s1) + | PPair _ s0 s1 => + congr_PPair (idSubst_PTm sigma_PTm Eq_PTm s0) + (idSubst_PTm sigma_PTm Eq_PTm s1) + | PProj _ s0 s1 => + congr_PProj (eq_refl s0) (idSubst_PTm sigma_PTm Eq_PTm s1) + | PBind _ s0 s1 s2 => + congr_PBind (eq_refl s0) (idSubst_PTm sigma_PTm Eq_PTm s1) + (idSubst_PTm (up_PTm_PTm sigma_PTm) (upId_PTm_PTm _ Eq_PTm) s2) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot + end. + +Lemma upExtRen_PTm_PTm {m : nat} {n : nat} (xi : fin m -> fin n) + (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) : + forall x, upRen_PTm_PTm xi x = upRen_PTm_PTm zeta x. +Proof. +exact (fun n => + match n with + | Some fin_n => ap shift (Eq fin_n) + | None => eq_refl + end). +Qed. + +Lemma upExtRen_list_PTm_PTm {p : nat} {m : nat} {n : nat} + (xi : fin m -> fin n) (zeta : fin m -> fin n) + (Eq : forall x, xi x = zeta x) : + forall x, upRen_list_PTm_PTm p xi x = upRen_list_PTm_PTm p zeta x. +Proof. +exact (fun n => + scons_p_congr (fun n => eq_refl) (fun n => ap (shift_p p) (Eq n))). +Qed. + +Fixpoint extRen_PTm {m_PTm : nat} {n_PTm : nat} +(xi_PTm : fin m_PTm -> fin n_PTm) (zeta_PTm : fin m_PTm -> fin n_PTm) +(Eq_PTm : forall x, xi_PTm x = zeta_PTm x) (s : PTm m_PTm) {struct s} : ren_PTm xi_PTm s = ren_PTm zeta_PTm s := match s with - | VarPTm s0 => ap (VarPTm) (Eq_PTm s0) - | PAbs s0 => + | VarPTm _ s0 => ap (VarPTm n_PTm) (Eq_PTm s0) + | PAbs _ s0 => congr_PAbs (extRen_PTm (upRen_PTm_PTm xi_PTm) (upRen_PTm_PTm zeta_PTm) (upExtRen_PTm_PTm _ _ Eq_PTm) s0) - | PApp s0 s1 => + | PApp _ s0 s1 => congr_PApp (extRen_PTm xi_PTm zeta_PTm Eq_PTm s0) (extRen_PTm xi_PTm zeta_PTm Eq_PTm s1) - | PPair s0 s1 => + | PPair _ s0 s1 => congr_PPair (extRen_PTm xi_PTm zeta_PTm Eq_PTm s0) (extRen_PTm xi_PTm zeta_PTm Eq_PTm s1) - | PProj s0 s1 => + | PProj _ s0 s1 => congr_PProj (eq_refl s0) (extRen_PTm xi_PTm zeta_PTm Eq_PTm s1) - | PBind s0 s1 s2 => + | PBind _ s0 s1 s2 => congr_PBind (eq_refl s0) (extRen_PTm xi_PTm zeta_PTm Eq_PTm s1) (extRen_PTm (upRen_PTm_PTm xi_PTm) (upRen_PTm_PTm zeta_PTm) (upExtRen_PTm_PTm _ _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => congr_PSuc (extRen_PTm xi_PTm zeta_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (extRen_PTm (upRen_PTm_PTm xi_PTm) (upRen_PTm_PTm zeta_PTm) - (upExtRen_PTm_PTm _ _ Eq_PTm) s0) - (extRen_PTm xi_PTm zeta_PTm Eq_PTm s1) - (extRen_PTm xi_PTm zeta_PTm Eq_PTm s2) - (extRen_PTm (upRen_PTm_PTm (upRen_PTm_PTm xi_PTm)) - (upRen_PTm_PTm (upRen_PTm_PTm zeta_PTm)) - (upExtRen_PTm_PTm _ _ (upExtRen_PTm_PTm _ _ Eq_PTm)) s3) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot end. -Lemma upExt_PTm_PTm (sigma : nat -> PTm) (tau : nat -> PTm) - (Eq : forall x, sigma x = tau x) : +Lemma upExt_PTm_PTm {m : nat} {n_PTm : nat} (sigma : fin m -> PTm n_PTm) + (tau : fin m -> PTm n_PTm) (Eq : forall x, sigma x = tau x) : forall x, up_PTm_PTm sigma x = up_PTm_PTm tau x. Proof. exact (fun n => match n with - | S n' => ap (ren_PTm shift) (Eq n') - | O => eq_refl + | Some fin_n => ap (ren_PTm shift) (Eq fin_n) + | None => eq_refl end). Qed. -Fixpoint ext_PTm (sigma_PTm : nat -> PTm) (tau_PTm : nat -> PTm) -(Eq_PTm : forall x, sigma_PTm x = tau_PTm x) (s : PTm) {struct s} : +Lemma upExt_list_PTm_PTm {p : nat} {m : nat} {n_PTm : nat} + (sigma : fin m -> PTm n_PTm) (tau : fin m -> PTm n_PTm) + (Eq : forall x, sigma x = tau x) : + forall x, up_list_PTm_PTm p sigma x = up_list_PTm_PTm p tau x. +Proof. +exact (fun n => + scons_p_congr (fun n => eq_refl) + (fun n => ap (ren_PTm (shift_p p)) (Eq n))). +Qed. + +Fixpoint ext_PTm {m_PTm : nat} {n_PTm : nat} +(sigma_PTm : fin m_PTm -> PTm n_PTm) (tau_PTm : fin m_PTm -> PTm n_PTm) +(Eq_PTm : forall x, sigma_PTm x = tau_PTm x) (s : PTm m_PTm) {struct s} : subst_PTm sigma_PTm s = subst_PTm tau_PTm s := match s with - | VarPTm s0 => Eq_PTm s0 - | PAbs s0 => + | VarPTm _ s0 => Eq_PTm s0 + | PAbs _ s0 => congr_PAbs (ext_PTm (up_PTm_PTm sigma_PTm) (up_PTm_PTm tau_PTm) (upExt_PTm_PTm _ _ Eq_PTm) s0) - | PApp s0 s1 => + | PApp _ s0 s1 => congr_PApp (ext_PTm sigma_PTm tau_PTm Eq_PTm s0) (ext_PTm sigma_PTm tau_PTm Eq_PTm s1) - | PPair s0 s1 => + | PPair _ s0 s1 => congr_PPair (ext_PTm sigma_PTm tau_PTm Eq_PTm s0) (ext_PTm sigma_PTm tau_PTm Eq_PTm s1) - | PProj s0 s1 => + | PProj _ s0 s1 => congr_PProj (eq_refl s0) (ext_PTm sigma_PTm tau_PTm Eq_PTm s1) - | PBind s0 s1 s2 => + | PBind _ s0 s1 s2 => congr_PBind (eq_refl s0) (ext_PTm sigma_PTm tau_PTm Eq_PTm s1) (ext_PTm (up_PTm_PTm sigma_PTm) (up_PTm_PTm tau_PTm) (upExt_PTm_PTm _ _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => congr_PSuc (ext_PTm sigma_PTm tau_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (ext_PTm (up_PTm_PTm sigma_PTm) (up_PTm_PTm tau_PTm) - (upExt_PTm_PTm _ _ Eq_PTm) s0) - (ext_PTm sigma_PTm tau_PTm Eq_PTm s1) - (ext_PTm sigma_PTm tau_PTm Eq_PTm s2) - (ext_PTm (up_PTm_PTm (up_PTm_PTm sigma_PTm)) - (up_PTm_PTm (up_PTm_PTm tau_PTm)) - (upExt_PTm_PTm _ _ (upExt_PTm_PTm _ _ Eq_PTm)) s3) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot end. -Lemma up_ren_ren_PTm_PTm (xi : nat -> nat) (zeta : nat -> nat) - (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) : +Lemma up_ren_ren_PTm_PTm {k : nat} {l : nat} {m : nat} (xi : fin k -> fin l) + (zeta : fin l -> fin m) (rho : fin k -> fin m) + (Eq : forall x, funcomp zeta xi x = rho x) : forall x, funcomp (upRen_PTm_PTm zeta) (upRen_PTm_PTm xi) x = upRen_PTm_PTm rho x. Proof. exact (up_ren_ren xi zeta rho Eq). Qed. -Fixpoint compRenRen_PTm (xi_PTm : nat -> nat) (zeta_PTm : nat -> nat) -(rho_PTm : nat -> nat) -(Eq_PTm : forall x, funcomp zeta_PTm xi_PTm x = rho_PTm x) (s : PTm) {struct - s} : ren_PTm zeta_PTm (ren_PTm xi_PTm s) = ren_PTm rho_PTm s := +Lemma up_ren_ren_list_PTm_PTm {p : nat} {k : nat} {l : nat} {m : nat} + (xi : fin k -> fin l) (zeta : fin l -> fin m) (rho : fin k -> fin m) + (Eq : forall x, funcomp zeta xi x = rho x) : + forall x, + funcomp (upRen_list_PTm_PTm p zeta) (upRen_list_PTm_PTm p xi) x = + upRen_list_PTm_PTm p rho x. +Proof. +exact (up_ren_ren_p Eq). +Qed. + +Fixpoint compRenRen_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} +(xi_PTm : fin m_PTm -> fin k_PTm) (zeta_PTm : fin k_PTm -> fin l_PTm) +(rho_PTm : fin m_PTm -> fin l_PTm) +(Eq_PTm : forall x, funcomp zeta_PTm xi_PTm x = rho_PTm x) (s : PTm m_PTm) +{struct s} : ren_PTm zeta_PTm (ren_PTm xi_PTm s) = ren_PTm rho_PTm s := match s with - | VarPTm s0 => ap (VarPTm) (Eq_PTm s0) - | PAbs s0 => + | VarPTm _ s0 => ap (VarPTm l_PTm) (Eq_PTm s0) + | PAbs _ s0 => congr_PAbs (compRenRen_PTm (upRen_PTm_PTm xi_PTm) (upRen_PTm_PTm zeta_PTm) (upRen_PTm_PTm rho_PTm) (up_ren_ren _ _ _ Eq_PTm) s0) - | PApp s0 s1 => + | PApp _ s0 s1 => congr_PApp (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s0) (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s1) - | PPair s0 s1 => + | PPair _ s0 s1 => congr_PPair (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s0) (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s1) - | PProj s0 s1 => + | PProj _ s0 s1 => congr_PProj (eq_refl s0) (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s1) - | PBind s0 s1 s2 => + | PBind _ s0 s1 s2 => congr_PBind (eq_refl s0) (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s1) (compRenRen_PTm (upRen_PTm_PTm xi_PTm) (upRen_PTm_PTm zeta_PTm) (upRen_PTm_PTm rho_PTm) (up_ren_ren _ _ _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => congr_PSuc (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (compRenRen_PTm (upRen_PTm_PTm xi_PTm) (upRen_PTm_PTm zeta_PTm) - (upRen_PTm_PTm rho_PTm) (up_ren_ren _ _ _ Eq_PTm) s0) - (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s1) - (compRenRen_PTm xi_PTm zeta_PTm rho_PTm Eq_PTm s2) - (compRenRen_PTm (upRen_PTm_PTm (upRen_PTm_PTm xi_PTm)) - (upRen_PTm_PTm (upRen_PTm_PTm zeta_PTm)) - (upRen_PTm_PTm (upRen_PTm_PTm rho_PTm)) - (up_ren_ren _ _ _ (up_ren_ren _ _ _ Eq_PTm)) s3) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot end. -Lemma up_ren_subst_PTm_PTm (xi : nat -> nat) (tau : nat -> PTm) - (theta : nat -> PTm) (Eq : forall x, funcomp tau xi x = theta x) : +Lemma up_ren_subst_PTm_PTm {k : nat} {l : nat} {m_PTm : nat} + (xi : fin k -> fin l) (tau : fin l -> PTm m_PTm) + (theta : fin k -> PTm m_PTm) (Eq : forall x, funcomp tau xi x = theta x) : forall x, funcomp (up_PTm_PTm tau) (upRen_PTm_PTm xi) x = up_PTm_PTm theta x. Proof. exact (fun n => match n with - | S n' => ap (ren_PTm shift) (Eq n') - | O => eq_refl + | Some fin_n => ap (ren_PTm shift) (Eq fin_n) + | None => eq_refl end). Qed. -Fixpoint compRenSubst_PTm (xi_PTm : nat -> nat) (tau_PTm : nat -> PTm) -(theta_PTm : nat -> PTm) -(Eq_PTm : forall x, funcomp tau_PTm xi_PTm x = theta_PTm x) (s : PTm) {struct - s} : subst_PTm tau_PTm (ren_PTm xi_PTm s) = subst_PTm theta_PTm s := +Lemma up_ren_subst_list_PTm_PTm {p : nat} {k : nat} {l : nat} {m_PTm : nat} + (xi : fin k -> fin l) (tau : fin l -> PTm m_PTm) + (theta : fin k -> PTm m_PTm) (Eq : forall x, funcomp tau xi x = theta x) : + forall x, + funcomp (up_list_PTm_PTm p tau) (upRen_list_PTm_PTm p xi) x = + up_list_PTm_PTm p theta x. +Proof. +exact (fun n => + eq_trans (scons_p_comp' _ _ _ n) + (scons_p_congr (fun z => scons_p_head' _ _ z) + (fun z => + eq_trans (scons_p_tail' _ _ (xi z)) + (ap (ren_PTm (shift_p p)) (Eq z))))). +Qed. + +Fixpoint compRenSubst_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} +(xi_PTm : fin m_PTm -> fin k_PTm) (tau_PTm : fin k_PTm -> PTm l_PTm) +(theta_PTm : fin m_PTm -> PTm l_PTm) +(Eq_PTm : forall x, funcomp tau_PTm xi_PTm x = theta_PTm x) (s : PTm m_PTm) +{struct s} : subst_PTm tau_PTm (ren_PTm xi_PTm s) = subst_PTm theta_PTm s := match s with - | VarPTm s0 => Eq_PTm s0 - | PAbs s0 => + | VarPTm _ s0 => Eq_PTm s0 + | PAbs _ s0 => congr_PAbs (compRenSubst_PTm (upRen_PTm_PTm xi_PTm) (up_PTm_PTm tau_PTm) (up_PTm_PTm theta_PTm) (up_ren_subst_PTm_PTm _ _ _ Eq_PTm) s0) - | PApp s0 s1 => + | PApp _ s0 s1 => congr_PApp (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s0) (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s1) - | PPair s0 s1 => + | PPair _ s0 s1 => congr_PPair (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s0) (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s1) - | PProj s0 s1 => + | PProj _ s0 s1 => congr_PProj (eq_refl s0) (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s1) - | PBind s0 s1 s2 => + | PBind _ s0 s1 s2 => congr_PBind (eq_refl s0) (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s1) (compRenSubst_PTm (upRen_PTm_PTm xi_PTm) (up_PTm_PTm tau_PTm) (up_PTm_PTm theta_PTm) (up_ren_subst_PTm_PTm _ _ _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => - congr_PSuc (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (compRenSubst_PTm (upRen_PTm_PTm xi_PTm) (up_PTm_PTm tau_PTm) - (up_PTm_PTm theta_PTm) (up_ren_subst_PTm_PTm _ _ _ Eq_PTm) s0) - (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s1) - (compRenSubst_PTm xi_PTm tau_PTm theta_PTm Eq_PTm s2) - (compRenSubst_PTm (upRen_PTm_PTm (upRen_PTm_PTm xi_PTm)) - (up_PTm_PTm (up_PTm_PTm tau_PTm)) - (up_PTm_PTm (up_PTm_PTm theta_PTm)) - (up_ren_subst_PTm_PTm _ _ _ (up_ren_subst_PTm_PTm _ _ _ Eq_PTm)) - s3) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot end. -Lemma up_subst_ren_PTm_PTm (sigma : nat -> PTm) (zeta_PTm : nat -> nat) - (theta : nat -> PTm) +Lemma up_subst_ren_PTm_PTm {k : nat} {l_PTm : nat} {m_PTm : nat} + (sigma : fin k -> PTm l_PTm) (zeta_PTm : fin l_PTm -> fin m_PTm) + (theta : fin k -> PTm m_PTm) (Eq : forall x, funcomp (ren_PTm zeta_PTm) sigma x = theta x) : forall x, funcomp (ren_PTm (upRen_PTm_PTm zeta_PTm)) (up_PTm_PTm sigma) x = @@ -406,64 +403,76 @@ Lemma up_subst_ren_PTm_PTm (sigma : nat -> PTm) (zeta_PTm : nat -> nat) Proof. exact (fun n => match n with - | S n' => + | Some fin_n => eq_trans (compRenRen_PTm shift (upRen_PTm_PTm zeta_PTm) - (funcomp shift zeta_PTm) (fun x => eq_refl) (sigma n')) + (funcomp shift zeta_PTm) (fun x => eq_refl) (sigma fin_n)) (eq_trans (eq_sym (compRenRen_PTm zeta_PTm shift (funcomp shift zeta_PTm) - (fun x => eq_refl) (sigma n'))) - (ap (ren_PTm shift) (Eq n'))) - | O => eq_refl + (fun x => eq_refl) (sigma fin_n))) + (ap (ren_PTm shift) (Eq fin_n))) + | None => eq_refl end). Qed. -Fixpoint compSubstRen_PTm (sigma_PTm : nat -> PTm) (zeta_PTm : nat -> nat) -(theta_PTm : nat -> PTm) +Lemma up_subst_ren_list_PTm_PTm {p : nat} {k : nat} {l_PTm : nat} + {m_PTm : nat} (sigma : fin k -> PTm l_PTm) + (zeta_PTm : fin l_PTm -> fin m_PTm) (theta : fin k -> PTm m_PTm) + (Eq : forall x, funcomp (ren_PTm zeta_PTm) sigma x = theta x) : + forall x, + funcomp (ren_PTm (upRen_list_PTm_PTm p zeta_PTm)) (up_list_PTm_PTm p sigma) + x = up_list_PTm_PTm p theta x. +Proof. +exact (fun n => + eq_trans (scons_p_comp' _ _ _ n) + (scons_p_congr + (fun x => ap (VarPTm (plus p m_PTm)) (scons_p_head' _ _ x)) + (fun n => + eq_trans + (compRenRen_PTm (shift_p p) (upRen_list_PTm_PTm p zeta_PTm) + (funcomp (shift_p p) zeta_PTm) + (fun x => scons_p_tail' _ _ x) (sigma n)) + (eq_trans + (eq_sym + (compRenRen_PTm zeta_PTm (shift_p p) + (funcomp (shift_p p) zeta_PTm) (fun x => eq_refl) + (sigma n))) (ap (ren_PTm (shift_p p)) (Eq n)))))). +Qed. + +Fixpoint compSubstRen_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} +(sigma_PTm : fin m_PTm -> PTm k_PTm) (zeta_PTm : fin k_PTm -> fin l_PTm) +(theta_PTm : fin m_PTm -> PTm l_PTm) (Eq_PTm : forall x, funcomp (ren_PTm zeta_PTm) sigma_PTm x = theta_PTm x) -(s : PTm) {struct s} : +(s : PTm m_PTm) {struct s} : ren_PTm zeta_PTm (subst_PTm sigma_PTm s) = subst_PTm theta_PTm s := match s with - | VarPTm s0 => Eq_PTm s0 - | PAbs s0 => + | VarPTm _ s0 => Eq_PTm s0 + | PAbs _ s0 => congr_PAbs (compSubstRen_PTm (up_PTm_PTm sigma_PTm) (upRen_PTm_PTm zeta_PTm) (up_PTm_PTm theta_PTm) (up_subst_ren_PTm_PTm _ _ _ Eq_PTm) s0) - | PApp s0 s1 => + | PApp _ s0 s1 => congr_PApp (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s0) (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s1) - | PPair s0 s1 => + | PPair _ s0 s1 => congr_PPair (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s0) (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s1) - | PProj s0 s1 => + | PProj _ s0 s1 => congr_PProj (eq_refl s0) (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s1) - | PBind s0 s1 s2 => + | PBind _ s0 s1 s2 => congr_PBind (eq_refl s0) (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s1) (compSubstRen_PTm (up_PTm_PTm sigma_PTm) (upRen_PTm_PTm zeta_PTm) (up_PTm_PTm theta_PTm) (up_subst_ren_PTm_PTm _ _ _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => - congr_PSuc (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (compSubstRen_PTm (up_PTm_PTm sigma_PTm) (upRen_PTm_PTm zeta_PTm) - (up_PTm_PTm theta_PTm) (up_subst_ren_PTm_PTm _ _ _ Eq_PTm) s0) - (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s1) - (compSubstRen_PTm sigma_PTm zeta_PTm theta_PTm Eq_PTm s2) - (compSubstRen_PTm (up_PTm_PTm (up_PTm_PTm sigma_PTm)) - (upRen_PTm_PTm (upRen_PTm_PTm zeta_PTm)) - (up_PTm_PTm (up_PTm_PTm theta_PTm)) - (up_subst_ren_PTm_PTm _ _ _ (up_subst_ren_PTm_PTm _ _ _ Eq_PTm)) - s3) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot end. -Lemma up_subst_subst_PTm_PTm (sigma : nat -> PTm) (tau_PTm : nat -> PTm) - (theta : nat -> PTm) +Lemma up_subst_subst_PTm_PTm {k : nat} {l_PTm : nat} {m_PTm : nat} + (sigma : fin k -> PTm l_PTm) (tau_PTm : fin l_PTm -> PTm m_PTm) + (theta : fin k -> PTm m_PTm) (Eq : forall x, funcomp (subst_PTm tau_PTm) sigma x = theta x) : forall x, funcomp (subst_PTm (up_PTm_PTm tau_PTm)) (up_PTm_PTm sigma) x = @@ -471,223 +480,258 @@ Lemma up_subst_subst_PTm_PTm (sigma : nat -> PTm) (tau_PTm : nat -> PTm) Proof. exact (fun n => match n with - | S n' => + | Some fin_n => eq_trans (compRenSubst_PTm shift (up_PTm_PTm tau_PTm) (funcomp (up_PTm_PTm tau_PTm) shift) (fun x => eq_refl) - (sigma n')) + (sigma fin_n)) (eq_trans (eq_sym (compSubstRen_PTm tau_PTm shift (funcomp (ren_PTm shift) tau_PTm) (fun x => eq_refl) - (sigma n'))) (ap (ren_PTm shift) (Eq n'))) - | O => eq_refl + (sigma fin_n))) (ap (ren_PTm shift) (Eq fin_n))) + | None => eq_refl end). Qed. -Fixpoint compSubstSubst_PTm (sigma_PTm : nat -> PTm) (tau_PTm : nat -> PTm) -(theta_PTm : nat -> PTm) +Lemma up_subst_subst_list_PTm_PTm {p : nat} {k : nat} {l_PTm : nat} + {m_PTm : nat} (sigma : fin k -> PTm l_PTm) + (tau_PTm : fin l_PTm -> PTm m_PTm) (theta : fin k -> PTm m_PTm) + (Eq : forall x, funcomp (subst_PTm tau_PTm) sigma x = theta x) : + forall x, + funcomp (subst_PTm (up_list_PTm_PTm p tau_PTm)) (up_list_PTm_PTm p sigma) x = + up_list_PTm_PTm p theta x. +Proof. +exact (fun n => + eq_trans + (scons_p_comp' (funcomp (VarPTm (plus p l_PTm)) (zero_p p)) _ _ n) + (scons_p_congr + (fun x => scons_p_head' _ (fun z => ren_PTm (shift_p p) _) x) + (fun n => + eq_trans + (compRenSubst_PTm (shift_p p) (up_list_PTm_PTm p tau_PTm) + (funcomp (up_list_PTm_PTm p tau_PTm) (shift_p p)) + (fun x => eq_refl) (sigma n)) + (eq_trans + (eq_sym + (compSubstRen_PTm tau_PTm (shift_p p) _ + (fun x => eq_sym (scons_p_tail' _ _ x)) (sigma n))) + (ap (ren_PTm (shift_p p)) (Eq n)))))). +Qed. + +Fixpoint compSubstSubst_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} +(sigma_PTm : fin m_PTm -> PTm k_PTm) (tau_PTm : fin k_PTm -> PTm l_PTm) +(theta_PTm : fin m_PTm -> PTm l_PTm) (Eq_PTm : forall x, funcomp (subst_PTm tau_PTm) sigma_PTm x = theta_PTm x) -(s : PTm) {struct s} : +(s : PTm m_PTm) {struct s} : subst_PTm tau_PTm (subst_PTm sigma_PTm s) = subst_PTm theta_PTm s := match s with - | VarPTm s0 => Eq_PTm s0 - | PAbs s0 => + | VarPTm _ s0 => Eq_PTm s0 + | PAbs _ s0 => congr_PAbs (compSubstSubst_PTm (up_PTm_PTm sigma_PTm) (up_PTm_PTm tau_PTm) (up_PTm_PTm theta_PTm) (up_subst_subst_PTm_PTm _ _ _ Eq_PTm) s0) - | PApp s0 s1 => + | PApp _ s0 s1 => congr_PApp (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s0) (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s1) - | PPair s0 s1 => + | PPair _ s0 s1 => congr_PPair (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s0) (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s1) - | PProj s0 s1 => + | PProj _ s0 s1 => congr_PProj (eq_refl s0) (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s1) - | PBind s0 s1 s2 => + | PBind _ s0 s1 s2 => congr_PBind (eq_refl s0) (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s1) (compSubstSubst_PTm (up_PTm_PTm sigma_PTm) (up_PTm_PTm tau_PTm) (up_PTm_PTm theta_PTm) (up_subst_subst_PTm_PTm _ _ _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => - congr_PSuc (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (compSubstSubst_PTm (up_PTm_PTm sigma_PTm) (up_PTm_PTm tau_PTm) - (up_PTm_PTm theta_PTm) (up_subst_subst_PTm_PTm _ _ _ Eq_PTm) s0) - (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s1) - (compSubstSubst_PTm sigma_PTm tau_PTm theta_PTm Eq_PTm s2) - (compSubstSubst_PTm (up_PTm_PTm (up_PTm_PTm sigma_PTm)) - (up_PTm_PTm (up_PTm_PTm tau_PTm)) - (up_PTm_PTm (up_PTm_PTm theta_PTm)) - (up_subst_subst_PTm_PTm _ _ _ - (up_subst_subst_PTm_PTm _ _ _ Eq_PTm)) s3) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot end. -Lemma renRen_PTm (xi_PTm : nat -> nat) (zeta_PTm : nat -> nat) (s : PTm) : +Lemma renRen_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (xi_PTm : fin m_PTm -> fin k_PTm) (zeta_PTm : fin k_PTm -> fin l_PTm) + (s : PTm m_PTm) : ren_PTm zeta_PTm (ren_PTm xi_PTm s) = ren_PTm (funcomp zeta_PTm xi_PTm) s. Proof. exact (compRenRen_PTm xi_PTm zeta_PTm _ (fun n => eq_refl) s). Qed. -Lemma renRen'_PTm_pointwise (xi_PTm : nat -> nat) (zeta_PTm : nat -> nat) : +Lemma renRen'_PTm_pointwise {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (xi_PTm : fin m_PTm -> fin k_PTm) (zeta_PTm : fin k_PTm -> fin l_PTm) : pointwise_relation _ eq (funcomp (ren_PTm zeta_PTm) (ren_PTm xi_PTm)) (ren_PTm (funcomp zeta_PTm xi_PTm)). Proof. exact (fun s => compRenRen_PTm xi_PTm zeta_PTm _ (fun n => eq_refl) s). Qed. -Lemma renSubst_PTm (xi_PTm : nat -> nat) (tau_PTm : nat -> PTm) (s : PTm) : +Lemma renSubst_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (xi_PTm : fin m_PTm -> fin k_PTm) (tau_PTm : fin k_PTm -> PTm l_PTm) + (s : PTm m_PTm) : subst_PTm tau_PTm (ren_PTm xi_PTm s) = subst_PTm (funcomp tau_PTm xi_PTm) s. Proof. exact (compRenSubst_PTm xi_PTm tau_PTm _ (fun n => eq_refl) s). Qed. -Lemma renSubst_PTm_pointwise (xi_PTm : nat -> nat) (tau_PTm : nat -> PTm) : +Lemma renSubst_PTm_pointwise {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (xi_PTm : fin m_PTm -> fin k_PTm) (tau_PTm : fin k_PTm -> PTm l_PTm) : pointwise_relation _ eq (funcomp (subst_PTm tau_PTm) (ren_PTm xi_PTm)) (subst_PTm (funcomp tau_PTm xi_PTm)). Proof. exact (fun s => compRenSubst_PTm xi_PTm tau_PTm _ (fun n => eq_refl) s). Qed. -Lemma substRen_PTm (sigma_PTm : nat -> PTm) (zeta_PTm : nat -> nat) (s : PTm) - : +Lemma substRen_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (sigma_PTm : fin m_PTm -> PTm k_PTm) (zeta_PTm : fin k_PTm -> fin l_PTm) + (s : PTm m_PTm) : ren_PTm zeta_PTm (subst_PTm sigma_PTm s) = subst_PTm (funcomp (ren_PTm zeta_PTm) sigma_PTm) s. Proof. exact (compSubstRen_PTm sigma_PTm zeta_PTm _ (fun n => eq_refl) s). Qed. -Lemma substRen_PTm_pointwise (sigma_PTm : nat -> PTm) (zeta_PTm : nat -> nat) - : +Lemma substRen_PTm_pointwise {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (sigma_PTm : fin m_PTm -> PTm k_PTm) (zeta_PTm : fin k_PTm -> fin l_PTm) : pointwise_relation _ eq (funcomp (ren_PTm zeta_PTm) (subst_PTm sigma_PTm)) (subst_PTm (funcomp (ren_PTm zeta_PTm) sigma_PTm)). Proof. exact (fun s => compSubstRen_PTm sigma_PTm zeta_PTm _ (fun n => eq_refl) s). Qed. -Lemma substSubst_PTm (sigma_PTm : nat -> PTm) (tau_PTm : nat -> PTm) - (s : PTm) : +Lemma substSubst_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (sigma_PTm : fin m_PTm -> PTm k_PTm) (tau_PTm : fin k_PTm -> PTm l_PTm) + (s : PTm m_PTm) : subst_PTm tau_PTm (subst_PTm sigma_PTm s) = subst_PTm (funcomp (subst_PTm tau_PTm) sigma_PTm) s. Proof. exact (compSubstSubst_PTm sigma_PTm tau_PTm _ (fun n => eq_refl) s). Qed. -Lemma substSubst_PTm_pointwise (sigma_PTm : nat -> PTm) - (tau_PTm : nat -> PTm) : +Lemma substSubst_PTm_pointwise {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} + (sigma_PTm : fin m_PTm -> PTm k_PTm) (tau_PTm : fin k_PTm -> PTm l_PTm) : pointwise_relation _ eq (funcomp (subst_PTm tau_PTm) (subst_PTm sigma_PTm)) (subst_PTm (funcomp (subst_PTm tau_PTm) sigma_PTm)). Proof. exact (fun s => compSubstSubst_PTm sigma_PTm tau_PTm _ (fun n => eq_refl) s). Qed. -Lemma rinstInst_up_PTm_PTm (xi : nat -> nat) (sigma : nat -> PTm) - (Eq : forall x, funcomp (VarPTm) xi x = sigma x) : - forall x, funcomp (VarPTm) (upRen_PTm_PTm xi) x = up_PTm_PTm sigma x. +Lemma rinstInst_up_PTm_PTm {m : nat} {n_PTm : nat} (xi : fin m -> fin n_PTm) + (sigma : fin m -> PTm n_PTm) + (Eq : forall x, funcomp (VarPTm n_PTm) xi x = sigma x) : + forall x, + funcomp (VarPTm (S n_PTm)) (upRen_PTm_PTm xi) x = up_PTm_PTm sigma x. Proof. exact (fun n => match n with - | S n' => ap (ren_PTm shift) (Eq n') - | O => eq_refl + | Some fin_n => ap (ren_PTm shift) (Eq fin_n) + | None => eq_refl end). Qed. -Fixpoint rinst_inst_PTm (xi_PTm : nat -> nat) (sigma_PTm : nat -> PTm) -(Eq_PTm : forall x, funcomp (VarPTm) xi_PTm x = sigma_PTm x) (s : PTm) -{struct s} : ren_PTm xi_PTm s = subst_PTm sigma_PTm s := +Lemma rinstInst_up_list_PTm_PTm {p : nat} {m : nat} {n_PTm : nat} + (xi : fin m -> fin n_PTm) (sigma : fin m -> PTm n_PTm) + (Eq : forall x, funcomp (VarPTm n_PTm) xi x = sigma x) : + forall x, + funcomp (VarPTm (plus p n_PTm)) (upRen_list_PTm_PTm p xi) x = + up_list_PTm_PTm p sigma x. +Proof. +exact (fun n => + eq_trans (scons_p_comp' _ _ (VarPTm (plus p n_PTm)) n) + (scons_p_congr (fun z => eq_refl) + (fun n => ap (ren_PTm (shift_p p)) (Eq n)))). +Qed. + +Fixpoint rinst_inst_PTm {m_PTm : nat} {n_PTm : nat} +(xi_PTm : fin m_PTm -> fin n_PTm) (sigma_PTm : fin m_PTm -> PTm n_PTm) +(Eq_PTm : forall x, funcomp (VarPTm n_PTm) xi_PTm x = sigma_PTm x) +(s : PTm m_PTm) {struct s} : ren_PTm xi_PTm s = subst_PTm sigma_PTm s := match s with - | VarPTm s0 => Eq_PTm s0 - | PAbs s0 => + | VarPTm _ s0 => Eq_PTm s0 + | PAbs _ s0 => congr_PAbs (rinst_inst_PTm (upRen_PTm_PTm xi_PTm) (up_PTm_PTm sigma_PTm) (rinstInst_up_PTm_PTm _ _ Eq_PTm) s0) - | PApp s0 s1 => + | PApp _ s0 s1 => congr_PApp (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s0) (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s1) - | PPair s0 s1 => + | PPair _ s0 s1 => congr_PPair (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s0) (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s1) - | PProj s0 s1 => + | PProj _ s0 s1 => congr_PProj (eq_refl s0) (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s1) - | PBind s0 s1 s2 => + | PBind _ s0 s1 s2 => congr_PBind (eq_refl s0) (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s1) (rinst_inst_PTm (upRen_PTm_PTm xi_PTm) (up_PTm_PTm sigma_PTm) (rinstInst_up_PTm_PTm _ _ Eq_PTm) s2) - | PUniv s0 => congr_PUniv (eq_refl s0) - | PNat => congr_PNat - | PZero => congr_PZero - | PSuc s0 => congr_PSuc (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s0) - | PInd s0 s1 s2 s3 => - congr_PInd - (rinst_inst_PTm (upRen_PTm_PTm xi_PTm) (up_PTm_PTm sigma_PTm) - (rinstInst_up_PTm_PTm _ _ Eq_PTm) s0) - (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s1) - (rinst_inst_PTm xi_PTm sigma_PTm Eq_PTm s2) - (rinst_inst_PTm (upRen_PTm_PTm (upRen_PTm_PTm xi_PTm)) - (up_PTm_PTm (up_PTm_PTm sigma_PTm)) - (rinstInst_up_PTm_PTm _ _ (rinstInst_up_PTm_PTm _ _ Eq_PTm)) s3) + | PUniv _ s0 => congr_PUniv (eq_refl s0) + | PBot _ => congr_PBot end. -Lemma rinstInst'_PTm (xi_PTm : nat -> nat) (s : PTm) : - ren_PTm xi_PTm s = subst_PTm (funcomp (VarPTm) xi_PTm) s. +Lemma rinstInst'_PTm {m_PTm : nat} {n_PTm : nat} + (xi_PTm : fin m_PTm -> fin n_PTm) (s : PTm m_PTm) : + ren_PTm xi_PTm s = subst_PTm (funcomp (VarPTm n_PTm) xi_PTm) s. Proof. exact (rinst_inst_PTm xi_PTm _ (fun n => eq_refl) s). Qed. -Lemma rinstInst'_PTm_pointwise (xi_PTm : nat -> nat) : +Lemma rinstInst'_PTm_pointwise {m_PTm : nat} {n_PTm : nat} + (xi_PTm : fin m_PTm -> fin n_PTm) : pointwise_relation _ eq (ren_PTm xi_PTm) - (subst_PTm (funcomp (VarPTm) xi_PTm)). + (subst_PTm (funcomp (VarPTm n_PTm) xi_PTm)). Proof. exact (fun s => rinst_inst_PTm xi_PTm _ (fun n => eq_refl) s). Qed. -Lemma instId'_PTm (s : PTm) : subst_PTm (VarPTm) s = s. +Lemma instId'_PTm {m_PTm : nat} (s : PTm m_PTm) : + subst_PTm (VarPTm m_PTm) s = s. Proof. -exact (idSubst_PTm (VarPTm) (fun n => eq_refl) s). +exact (idSubst_PTm (VarPTm m_PTm) (fun n => eq_refl) s). Qed. -Lemma instId'_PTm_pointwise : pointwise_relation _ eq (subst_PTm (VarPTm)) id. +Lemma instId'_PTm_pointwise {m_PTm : nat} : + pointwise_relation _ eq (subst_PTm (VarPTm m_PTm)) id. Proof. -exact (fun s => idSubst_PTm (VarPTm) (fun n => eq_refl) s). +exact (fun s => idSubst_PTm (VarPTm m_PTm) (fun n => eq_refl) s). Qed. -Lemma rinstId'_PTm (s : PTm) : ren_PTm id s = s. +Lemma rinstId'_PTm {m_PTm : nat} (s : PTm m_PTm) : ren_PTm id s = s. Proof. exact (eq_ind_r (fun t => t = s) (instId'_PTm s) (rinstInst'_PTm id s)). Qed. -Lemma rinstId'_PTm_pointwise : pointwise_relation _ eq (@ren_PTm id) id. +Lemma rinstId'_PTm_pointwise {m_PTm : nat} : + pointwise_relation _ eq (@ren_PTm m_PTm m_PTm id) id. Proof. exact (fun s => eq_ind_r (fun t => t = s) (instId'_PTm s) (rinstInst'_PTm id s)). Qed. -Lemma varL'_PTm (sigma_PTm : nat -> PTm) (x : nat) : - subst_PTm sigma_PTm (VarPTm x) = sigma_PTm x. +Lemma varL'_PTm {m_PTm : nat} {n_PTm : nat} + (sigma_PTm : fin m_PTm -> PTm n_PTm) (x : fin m_PTm) : + subst_PTm sigma_PTm (VarPTm m_PTm x) = sigma_PTm x. Proof. exact (eq_refl). Qed. -Lemma varL'_PTm_pointwise (sigma_PTm : nat -> PTm) : - pointwise_relation _ eq (funcomp (subst_PTm sigma_PTm) (VarPTm)) sigma_PTm. +Lemma varL'_PTm_pointwise {m_PTm : nat} {n_PTm : nat} + (sigma_PTm : fin m_PTm -> PTm n_PTm) : + pointwise_relation _ eq (funcomp (subst_PTm sigma_PTm) (VarPTm m_PTm)) + sigma_PTm. Proof. exact (fun x => eq_refl). Qed. -Lemma varLRen'_PTm (xi_PTm : nat -> nat) (x : nat) : - ren_PTm xi_PTm (VarPTm x) = VarPTm (xi_PTm x). +Lemma varLRen'_PTm {m_PTm : nat} {n_PTm : nat} + (xi_PTm : fin m_PTm -> fin n_PTm) (x : fin m_PTm) : + ren_PTm xi_PTm (VarPTm m_PTm x) = VarPTm n_PTm (xi_PTm x). Proof. exact (eq_refl). Qed. -Lemma varLRen'_PTm_pointwise (xi_PTm : nat -> nat) : - pointwise_relation _ eq (funcomp (ren_PTm xi_PTm) (VarPTm)) - (funcomp (VarPTm) xi_PTm). +Lemma varLRen'_PTm_pointwise {m_PTm : nat} {n_PTm : nat} + (xi_PTm : fin m_PTm -> fin n_PTm) : + pointwise_relation _ eq (funcomp (ren_PTm xi_PTm) (VarPTm m_PTm)) + (funcomp (VarPTm n_PTm) xi_PTm). Proof. exact (fun x => eq_refl). Qed. @@ -695,14 +739,18 @@ Qed. Class Up_PTm X Y := up_PTm : X -> Y. -#[global] Instance Subst_PTm : (Subst1 _ _ _) := @subst_PTm. - -#[global] Instance Up_PTm_PTm : (Up_PTm _ _) := @up_PTm_PTm. - -#[global] Instance Ren_PTm : (Ren1 _ _ _) := @ren_PTm. +#[global] +Instance Subst_PTm {m_PTm n_PTm : nat}: (Subst1 _ _ _) := + (@subst_PTm m_PTm n_PTm). #[global] -Instance VarInstance_PTm : (Var _ _) := @VarPTm. +Instance Up_PTm_PTm {m n_PTm : nat}: (Up_PTm _ _) := (@up_PTm_PTm m n_PTm). + +#[global] +Instance Ren_PTm {m_PTm n_PTm : nat}: (Ren1 _ _ _) := (@ren_PTm m_PTm n_PTm). + +#[global] +Instance VarInstance_PTm {n_PTm : nat}: (Var _ _) := (@VarPTm n_PTm). Notation "[ sigma_PTm ]" := (subst_PTm sigma_PTm) ( at level 1, left associativity, only printing) : fscope. @@ -729,9 +777,9 @@ Notation "x '__PTm'" := (VarPTm x) ( at level 5, format "x __PTm") : subst_scope. #[global] -Instance subst_PTm_morphism : +Instance subst_PTm_morphism {m_PTm : nat} {n_PTm : nat}: (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) - (@subst_PTm)). + (@subst_PTm m_PTm n_PTm)). Proof. exact (fun f_PTm g_PTm Eq_PTm s t Eq_st => eq_ind s (fun t' => subst_PTm f_PTm s = subst_PTm g_PTm t') @@ -739,16 +787,17 @@ exact (fun f_PTm g_PTm Eq_PTm s t Eq_st => Qed. #[global] -Instance subst_PTm_morphism2 : +Instance subst_PTm_morphism2 {m_PTm : nat} {n_PTm : nat}: (Proper (respectful (pointwise_relation _ eq) (pointwise_relation _ eq)) - (@subst_PTm)). + (@subst_PTm m_PTm n_PTm)). Proof. exact (fun f_PTm g_PTm Eq_PTm s => ext_PTm f_PTm g_PTm Eq_PTm s). Qed. #[global] -Instance ren_PTm_morphism : - (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) (@ren_PTm)). +Instance ren_PTm_morphism {m_PTm : nat} {n_PTm : nat}: + (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) + (@ren_PTm m_PTm n_PTm)). Proof. exact (fun f_PTm g_PTm Eq_PTm s t Eq_st => eq_ind s (fun t' => ren_PTm f_PTm s = ren_PTm g_PTm t') @@ -756,9 +805,9 @@ exact (fun f_PTm g_PTm Eq_PTm s t Eq_st => Qed. #[global] -Instance ren_PTm_morphism2 : +Instance ren_PTm_morphism2 {m_PTm : nat} {n_PTm : nat}: (Proper (respectful (pointwise_relation _ eq) (pointwise_relation _ eq)) - (@ren_PTm)). + (@ren_PTm m_PTm n_PTm)). Proof. exact (fun f_PTm g_PTm Eq_PTm s => extRen_PTm f_PTm g_PTm Eq_PTm s). Qed. @@ -790,7 +839,9 @@ Ltac asimpl' := repeat (first | progress setoid_rewrite rinstId'_PTm | progress setoid_rewrite instId'_PTm_pointwise | progress setoid_rewrite instId'_PTm - | progress unfold up_PTm_PTm, upRen_PTm_PTm, up_ren + | progress + unfold up_list_PTm_PTm, up_PTm_PTm, upRen_list_PTm_PTm, + upRen_PTm_PTm, up_ren | progress cbn[subst_PTm ren_PTm] | progress fsimpl ]). @@ -815,7 +866,24 @@ End Core. Module Extra. -Import Core. +Import +Core. + +Arguments VarPTm {n_PTm}. + +Arguments PBot {n_PTm}. + +Arguments PUniv {n_PTm}. + +Arguments PBind {n_PTm}. + +Arguments PProj {n_PTm}. + +Arguments PPair {n_PTm}. + +Arguments PApp {n_PTm}. + +Arguments PAbs {n_PTm}. #[global] Hint Opaque subst_PTm: rewrite. diff --git a/theories/Autosubst2/unscoped.v b/theories/Autosubst2/unscoped.v deleted file mode 100644 index 55f8172..0000000 --- a/theories/Autosubst2/unscoped.v +++ /dev/null @@ -1,213 +0,0 @@ -(** * Autosubst Header for Unnamed Syntax - -Version: December 11, 2019. - *) - -(* Adrian: - I changed this library a bit to work better with my generated code. - 1. I use nat directly instead of defining fin to be nat and using Some/None as S/O - 2. I removed the "s, sigma" notation for scons because it interacts with dependent function types "forall x, A"*) -Require Import core. -Require Import Setoid Morphisms Relation_Definitions. - -Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y := - match p with eq_refl => eq_refl end. - -Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y := - match q with eq_refl => match p with eq_refl => eq_refl end end. - -(** ** Primitives of the Sigma Calculus. *) - -Definition shift := S. - -Definition var_zero := 0. - -Definition id {X} := @Datatypes.id X. - -Definition scons {X: Type} (x : X) (xi : nat -> X) := - fun n => match n with - | 0 => x - | S n => xi n - end. - -#[ export ] -Hint Opaque scons : rewrite. - -(** ** Type Class Instances for Notation -Required to make notation work. *) - -(** *** Type classes for renamings. *) - -Class Ren1 (X1 : Type) (Y Z : Type) := - ren1 : X1 -> Y -> Z. - -Class Ren2 (X1 X2 : Type) (Y Z : Type) := - ren2 : X1 -> X2 -> Y -> Z. - -Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) := - ren3 : X1 -> X2 -> X3 -> Y -> Z. - -Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) := - ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z. - -Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) := - ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z. - -Module RenNotations. - Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s ⟨ xi1 ⟩") : subst_scope. - - Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ⟩") : subst_scope. - - Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope. - - Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4 xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope. - - Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5 xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope. - - Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope. - - Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope. -End RenNotations. - -(** *** Type Classes for Substiution *) - -Class Subst1 (X1 : Type) (Y Z: Type) := - subst1 : X1 -> Y -> Z. - -Class Subst2 (X1 X2 : Type) (Y Z: Type) := - subst2 : X1 -> X2 -> Y -> Z. - -Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) := - subst3 : X1 -> X2 -> X3 -> Y -> Z. - -Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) := - subst4 : X1 -> X2 -> X3 -> X4 -> Y -> Z. - -Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) := - subst5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z. - -Module SubstNotations. - Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope. - - Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/' tau ]") : subst_scope. -End SubstNotations. - -(** *** Type Class for Variables *) - -Class Var X Y := - ids : X -> Y. - -#[export] Instance idsRen : Var nat nat := id. - -(** ** Proofs for the substitution primitives. *) - -Arguments funcomp {X Y Z} (g)%fscope (f)%fscope. - -Module CombineNotations. - Notation "f >> g" := (funcomp g f) (at level 50) : fscope. - - Notation "s .: sigma" := (scons s sigma) (at level 55, sigma at next level, right associativity) : subst_scope. - - #[ global ] - Open Scope fscope. - #[ global ] - Open Scope subst_scope. -End CombineNotations. - -Import CombineNotations. - - -(** A generic lifting of a renaming. *) -Definition up_ren (xi : nat -> nat) := - 0 .: (xi >> S). - -(** A generic proof that lifting of renamings composes. *) -Lemma up_ren_ren (xi: nat -> nat) (zeta : nat -> nat) (rho: nat -> nat) (E: forall x, (xi >> zeta) x = rho x) : - forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x. -Proof. - intros [|x]. - - reflexivity. - - unfold up_ren. cbn. unfold funcomp. f_equal. apply E. -Qed. - -(** Eta laws. *) -Lemma scons_eta' {T} (f : nat -> T) : - pointwise_relation _ eq (f var_zero .: (funcomp f shift)) f. -Proof. intros x. destruct x; reflexivity. Qed. - -Lemma scons_eta_id' : - pointwise_relation _ eq (var_zero .: shift) id. -Proof. intros x. destruct x; reflexivity. Qed. - -Lemma scons_comp' (T: Type) {U} (s: T) (sigma: nat -> T) (tau: T -> U) : - pointwise_relation _ eq (funcomp tau (s .: sigma)) ((tau s) .: (funcomp tau sigma)). -Proof. intros x. destruct x; reflexivity. Qed. - -(* Morphism for Setoid Rewriting. The only morphism that can be defined statically. *) -#[export] Instance scons_morphism {X: Type} : - Proper (eq ==> pointwise_relation _ eq ==> pointwise_relation _ eq) (@scons X). -Proof. - intros ? t -> sigma tau H. - intros [|x]. - cbn. reflexivity. - apply H. -Qed. - -#[export] Instance scons_morphism2 {X: Type} : - Proper (eq ==> pointwise_relation _ eq ==> eq ==> eq) (@scons X). -Proof. - intros ? t -> sigma tau H ? x ->. - destruct x as [|x]. - cbn. reflexivity. - apply H. -Qed. - -(** ** Generic lifting of an allfv predicate *) -Definition up_allfv (p: nat -> Prop) : nat -> Prop := scons True p. - -(** ** Notations for unscoped syntax *) -Module UnscopedNotations. - Include RenNotations. - Include SubstNotations. - Include CombineNotations. - - (* Notation "s , sigma" := (scons s sigma) (at level 60, format "s , sigma", right associativity) : subst_scope. *) - - Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope. - - Notation "↑" := (shift) : subst_scope. - - #[global] - Open Scope fscope. - #[global] - Open Scope subst_scope. -End UnscopedNotations. - -(** ** Tactics for unscoped syntax *) - -(** Automatically does a case analysis on a natural number, useful for proofs with context renamings/context morphisms. *) -Tactic Notation "auto_case" tactic(t) := (match goal with - | [|- forall (i : nat), _] => intros []; t - end). - - -(** Generic fsimpl tactic: simplifies the above primitives in a goal. *) -Ltac fsimpl := - repeat match goal with - | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *) - | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *) - | [|- context [id ?s]] => change (id s) with s - | [|- context[(?f >> ?g) >> ?h]] => change ((f >> g) >> h) with (f >> (g >> h)) - | [|- context[(?v .: ?g) var_zero]] => change ((v .: g) var_zero) with v - | [|- context[(?v .: ?g) 0]] => change ((v .: g) 0) with v - | [|- context[(?v .: ?g) (S ?n)]] => change ((v .: g) (S n)) with (g n) - | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g (* f should evaluate to shift *) - | [|- context[var_zero]] => change var_zero with 0 - | [|- context[?x2 .: (funcomp ?f shift)]] => change (scons x2 (funcomp f shift)) with (scons (f var_zero) (funcomp f shift)); setoid_rewrite (@scons_eta' _ _ f) - | [|- context[?f var_zero .: ?g]] => change (scons (f var_zero) g) with (scons (f var_zero) (funcomp f shift)); rewrite scons_eta' - | [|- _ = ?h (?f ?s)] => change (h (f s)) with ((f >> h) s) - | [|- ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s) - (* DONE had to put an underscore as the last argument to scons. This might be an argument against unfolding funcomp *) - | [|- context[funcomp _ (scons _ _)]] => setoid_rewrite scons_comp'; eta_reduce - | [|- context[scons var_zero shift]] => setoid_rewrite scons_eta_id'; eta_reduce - end. \ No newline at end of file diff --git a/theories/admissible.v b/theories/admissible.v deleted file mode 100644 index 3e48d49..0000000 --- a/theories/admissible.v +++ /dev/null @@ -1,264 +0,0 @@ -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common typing structural. -From Hammer Require Import Tactics. -Require Import ssreflect. -Require Import Psatz. -Require Import Coq.Logic.FunctionalExtensionality. - -Derive Inversion wff_inv with (forall Γ, ⊢ Γ) Sort Prop. - -Lemma T_Abs Γ (a : PTm ) A B : - (cons A Γ) ⊢ a ∈ B -> - Γ ⊢ PAbs a ∈ PBind PPi A B. -Proof. - move => ha. - have [i hB] : exists i, (cons A Γ) ⊢ B ∈ PUniv i by sfirstorder use:regularity. - have hΓ : ⊢ (cons A Γ) by sfirstorder use:wff_mutual. - hauto lq:on rew:off inv:Wff use:T_Bind', typing.T_Abs. -Qed. - - -Lemma App_Inv Γ (b a : PTm) U : - Γ ⊢ PApp b a ∈ U -> - exists A B, Γ ⊢ b ∈ PBind PPi A B /\ Γ ⊢ a ∈ A /\ Γ ⊢ subst_PTm (scons a VarPTm) B ≲ U. -Proof. - move E : (PApp b a) => u hu. - move : b a E. elim : Γ u U / hu => //=. - - move => Γ b a A B hb _ ha _ b0 a0 [*]. subst. - exists A,B. - repeat split => //=. - have [i] : exists i, Γ ⊢ PBind PPi A B ∈ PUniv i by sfirstorder use:regularity. - hauto lq:on use:bind_inst, E_Refl. - - hauto lq:on rew:off ctrs:LEq. -Qed. - - -Lemma Abs_Inv Γ (a : PTm) U : - Γ ⊢ PAbs a ∈ U -> - exists A B, (cons A Γ) ⊢ a ∈ B /\ Γ ⊢ PBind PPi A B ≲ U. -Proof. - move E : (PAbs a) => u hu. - move : a E. elim : Γ u U / hu => //=. - - move => Γ a A B i hP _ ha _ a0 [*]. subst. - exists A, B. repeat split => //=. - hauto lq:on use:E_Refl, Su_Eq. - - hauto lq:on rew:off ctrs:LEq. -Qed. - - - -Lemma E_AppAbs : forall (a : PTm) (b : PTm) Γ (A : PTm), - Γ ⊢ PApp (PAbs a) b ∈ A -> Γ ⊢ PApp (PAbs a) b ≡ subst_PTm (scons b VarPTm) a ∈ A. -Proof. - move => a b Γ A ha. - move /App_Inv : ha. - move => [A0][B0][ha][hb]hS. - move /Abs_Inv : ha => [A1][B1][ha]hS0. - have hb' := hb. - move /E_Refl in hb. - have hS1 : Γ ⊢ A0 ≲ A1 by sfirstorder use:Su_Pi_Proj1. - have [i hPi] : exists i, Γ ⊢ PBind PPi A1 B1 ∈ PUniv i by sfirstorder use:regularity_sub0. - move : Su_Pi_Proj2 hS0 hb; repeat move/[apply]. - move : hS => /[swap]. move : Su_Transitive. repeat move/[apply]. - move => h. - apply : E_Conv; eauto. - apply : E_AppAbs; eauto. - eauto using T_Conv. -Qed. - -Lemma T_Eta Γ A a B : - A :: Γ ⊢ a ∈ B -> - A :: Γ ⊢ PApp (PAbs (ren_PTm (upRen_PTm_PTm shift) a)) (VarPTm var_zero) ∈ B. -Proof. - move => ha. - have hΓ' : ⊢ A :: Γ by sfirstorder use:wff_mutual. - have [i hA] : exists i, Γ ⊢ A ∈ PUniv i by hauto lq:on inv:Wff. - have hΓ : ⊢ Γ by hauto lq:on inv:Wff. - eapply T_App' with (B := ren_PTm (upRen_PTm_PTm shift) B). by asimpl; rewrite subst_scons_id. - apply T_Abs. eapply renaming; eauto; cycle 1. apply renaming_up. apply renaming_shift. - econstructor; eauto. sauto l:on use:renaming. - apply T_Var => //. - by constructor. -Qed. - -Lemma E_Bind Γ i p (A0 A1 : PTm) B0 B1 : - Γ ⊢ A0 ≡ A1 ∈ PUniv i -> - (cons A0 Γ) ⊢ B0 ≡ B1 ∈ PUniv i -> - Γ ⊢ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv i. -Proof. - move => h0 h1. - have : Γ ⊢ A0 ∈ PUniv i by hauto l:on use:regularity. - have : ⊢ Γ by sfirstorder use:wff_mutual. - move : E_Bind h0 h1; repeat move/[apply]. - firstorder. -Qed. - -Lemma E_App Γ (b0 b1 a0 a1 : PTm ) A B : - Γ ⊢ b0 ≡ b1 ∈ PBind PPi A B -> - Γ ⊢ a0 ≡ a1 ∈ A -> - Γ ⊢ PApp b0 a0 ≡ PApp b1 a1 ∈ subst_PTm (scons a0 VarPTm) B. -Proof. - move => h. - have [i] : exists i, Γ ⊢ PBind PPi A B ∈ PUniv i by hauto l:on use:regularity. - move : E_App h. by repeat move/[apply]. -Qed. - -Lemma E_Proj2 Γ (a b : PTm) A B : - Γ ⊢ a ≡ b ∈ PBind PSig A B -> - Γ ⊢ PProj PR a ≡ PProj PR b ∈ subst_PTm (scons (PProj PL a) VarPTm) B. -Proof. - move => h. - have [i] : exists i, Γ ⊢ PBind PSig A B ∈ PUniv i by hauto l:on use:regularity. - move : E_Proj2 h; by repeat move/[apply]. -Qed. - -Lemma E_FunExt Γ (a b : PTm) A B : - Γ ⊢ a ∈ PBind PPi A B -> - Γ ⊢ b ∈ PBind PPi A B -> - A :: Γ ⊢ PApp (ren_PTm shift a) (VarPTm var_zero) ≡ PApp (ren_PTm shift b) (VarPTm var_zero) ∈ B -> - Γ ⊢ a ≡ b ∈ PBind PPi A B. -Proof. - hauto l:on use:regularity, E_FunExt. -Qed. - -Lemma E_PairExt Γ (a b : PTm) A B : - Γ ⊢ a ∈ PBind PSig A B -> - Γ ⊢ b ∈ PBind PSig A B -> - Γ ⊢ PProj PL a ≡ PProj PL b ∈ A -> - Γ ⊢ PProj PR a ≡ PProj PR b ∈ subst_PTm (scons (PProj PL a) VarPTm) B -> - Γ ⊢ a ≡ b ∈ PBind PSig A B. hauto l:on use:regularity, E_PairExt. Qed. - -Lemma renaming_comp Γ Δ Ξ ξ0 ξ1 : - renaming_ok Γ Δ ξ0 -> renaming_ok Δ Ξ ξ1 -> - renaming_ok Γ Ξ (funcomp ξ0 ξ1). - rewrite /renaming_ok => h0 h1 i A. - move => {}/h1 {}/h0. - by asimpl. -Qed. - -Lemma E_AppEta Γ (b : PTm) A B : - Γ ⊢ b ∈ PBind PPi A B -> - Γ ⊢ PAbs (PApp (ren_PTm shift b) (VarPTm var_zero)) ≡ b ∈ PBind PPi A B. -Proof. - move => h. - have [i hPi] : exists i, Γ ⊢ PBind PPi A B ∈ PUniv i by sfirstorder use:regularity. - have [j [hA hB]] : exists i, Γ ⊢ A ∈ PUniv i /\ A :: Γ ⊢ B ∈ PUniv i by hauto lq:on use:Bind_Inv. - have {i} {}hPi : Γ ⊢ PBind PPi A B ∈ PUniv j by sfirstorder use:T_Bind, wff_mutual. - have hΓ : ⊢ A :: Γ by hauto lq:on use:Bind_Inv, Wff_Cons'. - have hΓ' : ⊢ ren_PTm shift A :: A :: Γ by sauto lq:on use:renaming, renaming_shift inv:Wff. - apply E_FunExt; eauto. - apply T_Abs. - eapply T_App' with (A := ren_PTm shift A) (B := ren_PTm (upRen_PTm_PTm shift) B). by asimpl; rewrite subst_scons_id. - change (PBind _ _ _) with (ren_PTm shift (PBind PPi A B)). - - eapply renaming; eauto. - apply renaming_shift. - constructor => //. - by constructor. - - apply : E_Transitive. simpl. - apply E_AppAbs' with (i := j)(A := ren_PTm shift A) (B := ren_PTm (upRen_PTm_PTm shift) B); eauto. - by asimpl; rewrite subst_scons_id. - hauto q:on use:renaming, renaming_shift. - constructor => //. - by constructor. - asimpl. - eapply T_App' with (A := ren_PTm shift (ren_PTm shift A)) (B := ren_PTm (upRen_PTm_PTm shift) (ren_PTm (upRen_PTm_PTm shift) B)); cycle 2. - constructor. econstructor; eauto. sauto lq:on use:renaming, renaming_shift. - by constructor. asimpl. substify. by asimpl. - have -> : PBind PPi (ren_PTm shift (ren_PTm shift A)) (ren_PTm (upRen_PTm_PTm shift) (ren_PTm (upRen_PTm_PTm shift) B))= (ren_PTm (funcomp shift shift) (PBind PPi A B)) by asimpl. - eapply renaming; eauto. by eauto using renaming_shift, renaming_comp. - asimpl. renamify. - eapply E_App' with (A := ren_PTm shift A) (B := ren_PTm (upRen_PTm_PTm shift) B). by asimpl; rewrite subst_scons_id. - hauto q:on use:renaming, renaming_shift. - sauto lq:on use:renaming, renaming_shift, E_Refl. - constructor. constructor=>//. constructor. -Qed. - -Lemma Proj1_Inv Γ (a : PTm ) U : - Γ ⊢ PProj PL a ∈ U -> - exists A B, Γ ⊢ a ∈ PBind PSig A B /\ Γ ⊢ A ≲ U. -Proof. - move E : (PProj PL a) => u hu. - move :a E. elim : Γ u U / hu => //=. - - move => Γ a A B ha _ a0 [*]. subst. - exists A, B. split => //=. - eapply regularity in ha. - move : ha => [i]. - move /Bind_Inv => [j][h _]. - by move /E_Refl /Su_Eq in h. - - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma Proj2_Inv Γ (a : PTm) U : - Γ ⊢ PProj PR a ∈ U -> - exists A B, Γ ⊢ a ∈ PBind PSig A B /\ Γ ⊢ subst_PTm (scons (PProj PL a) VarPTm) B ≲ U. -Proof. - move E : (PProj PR a) => u hu. - move :a E. elim : Γ u U / hu => //=. - - move => Γ a A B ha _ a0 [*]. subst. - exists A, B. split => //=. - have ha' := ha. - eapply regularity in ha. - move : ha => [i ha]. - move /T_Proj1 in ha'. - apply : bind_inst; eauto. - apply : E_Refl ha'. - - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma Pair_Inv Γ (a b : PTm ) U : - Γ ⊢ PPair a b ∈ U -> - exists A B, Γ ⊢ a ∈ A /\ - Γ ⊢ b ∈ subst_PTm (scons a VarPTm) B /\ - Γ ⊢ PBind PSig A B ≲ U. -Proof. - move E : (PPair a b) => u hu. - move : a b E. elim : Γ u U / hu => //=. - - move => Γ a b A B i hS _ ha _ hb _ a0 b0 [*]. subst. - exists A,B. repeat split => //=. - move /E_Refl /Su_Eq : hS. apply. - - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma E_ProjPair1 : forall (a b : PTm) Γ (A : PTm), - Γ ⊢ PProj PL (PPair a b) ∈ A -> Γ ⊢ PProj PL (PPair a b) ≡ a ∈ A. -Proof. - move => a b Γ A. - move /Proj1_Inv. move => [A0][B0][hab]hA0. - move /Pair_Inv : hab => [A1][B1][ha][hb]hS. - have [i ?] : exists i, Γ ⊢ PBind PSig A1 B1 ∈ PUniv i by sfirstorder use:regularity_sub0. - move /Su_Sig_Proj1 in hS. - have {hA0} {}hS : Γ ⊢ A1 ≲ A by eauto using Su_Transitive. - apply : E_Conv; eauto. - apply : E_ProjPair1; eauto. -Qed. - -Lemma E_ProjPair2 : forall (a b : PTm) Γ (A : PTm), - Γ ⊢ PProj PR (PPair a b) ∈ A -> Γ ⊢ PProj PR (PPair a b) ≡ b ∈ A. -Proof. - move => a b Γ A. move /Proj2_Inv. - move => [A0][B0][ha]h. - have hr := ha. - move /Pair_Inv : ha => [A1][B1][ha][hb]hU. - have [i hSig] : exists i, Γ ⊢ PBind PSig A1 B1 ∈ PUniv i by sfirstorder use:regularity. - have /E_Symmetric : Γ ⊢ (PProj PL (PPair a b)) ≡ a ∈ A1 by eauto using E_ProjPair1 with wt. - move /Su_Sig_Proj2 : hU. repeat move/[apply]. move => hB. - apply : E_Conv; eauto. - apply : E_Conv; eauto. - apply : E_ProjPair2; eauto. -Qed. - - -Lemma E_PairEta Γ a A B : - Γ ⊢ a ∈ PBind PSig A B -> - Γ ⊢ PPair (PProj PL a) (PProj PR a) ≡ a ∈ PBind PSig A B. -Proof. - move => h. - have [i hSig] : exists i, Γ ⊢ PBind PSig A B ∈ PUniv i by hauto use:regularity. - apply E_PairExt => //. - eapply T_Pair; eauto with wt. - apply : E_Transitive. apply E_ProjPair1. by eauto with wt. - by eauto with wt. - apply E_ProjPair2. - apply : T_Proj2; eauto with wt. -Qed. diff --git a/theories/algorithmic.v b/theories/algorithmic.v deleted file mode 100644 index 4e4e6fd..0000000 --- a/theories/algorithmic.v +++ /dev/null @@ -1,1893 +0,0 @@ -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax - common typing preservation admissible fp_red structural soundness. -From Hammer Require Import Tactics. -Require Import ssreflect ssrbool. -Require Import Psatz. -From stdpp Require Import relations (rtc(..), nsteps(..)). -Require Import Coq.Logic.FunctionalExtensionality. - -Module HRed. - Lemma ToRRed (a b : PTm) : HRed.R a b -> RRed.R a b. - Proof. induction 1; hauto lq:on ctrs:RRed.R. Qed. - - Lemma preservation Γ (a b A : PTm) : Γ ⊢ a ∈ A -> HRed.R a b -> Γ ⊢ b ∈ A. - Proof. - sfirstorder use:subject_reduction, ToRRed. - Qed. - - Lemma ToEq Γ (a b : PTm ) A : Γ ⊢ a ∈ A -> HRed.R a b -> Γ ⊢ a ≡ b ∈ A. - Proof. sfirstorder use:ToRRed, RRed_Eq. Qed. - -End HRed. - -Module HReds. - Lemma preservation Γ (a b A : PTm) : Γ ⊢ a ∈ A -> rtc HRed.R a b -> Γ ⊢ b ∈ A. - Proof. induction 2; sfirstorder use:HRed.preservation. Qed. - - Lemma ToEq Γ (a b : PTm) A : Γ ⊢ a ∈ A -> rtc HRed.R a b -> Γ ⊢ a ≡ b ∈ A. - Proof. - induction 2; sauto lq:on use:HRed.ToEq, E_Transitive, HRed.preservation. - Qed. -End HReds. - -Lemma T_Conv_E Γ (a : PTm) A B i : - Γ ⊢ a ∈ A -> - Γ ⊢ A ≡ B ∈ PUniv i \/ Γ ⊢ B ≡ A ∈ PUniv i -> - Γ ⊢ a ∈ B. -Proof. qauto use:T_Conv, Su_Eq, E_Symmetric. Qed. - -Lemma E_Conv_E Γ (a b : PTm) A B i : - Γ ⊢ a ≡ b ∈ A -> - Γ ⊢ A ≡ B ∈ PUniv i \/ Γ ⊢ B ≡ A ∈ PUniv i -> - Γ ⊢ a ≡ b ∈ B. -Proof. qauto use:E_Conv, Su_Eq, E_Symmetric. Qed. - -Lemma lored_embed Γ (a b : PTm) A : - Γ ⊢ a ∈ A -> LoRed.R a b -> Γ ⊢ a ≡ b ∈ A. -Proof. sfirstorder use:LoRed.ToRRed, RRed_Eq. Qed. - -Lemma loreds_embed Γ (a b : PTm ) A : - Γ ⊢ a ∈ A -> rtc LoRed.R a b -> Γ ⊢ a ≡ b ∈ A. -Proof. - move => + h. move : Γ A. - elim : a b /h. - - sfirstorder use:E_Refl. - - move => a b c ha hb ih Γ A hA. - have ? : Γ ⊢ a ≡ b ∈ A by sfirstorder use:lored_embed. - have ? : Γ ⊢ b ∈ A by hauto l:on use:regularity. - hauto lq:on ctrs:Eq. -Qed. - -Lemma Zero_Inv Γ U : - Γ ⊢ PZero ∈ U -> - Γ ⊢ PNat ≲ U. -Proof. - move E : PZero => u hu. - move : E. - elim : Γ u U /hu=>//=. - by eauto using Su_Eq, E_Refl, T_Nat'. - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma Sub_Bind_InvR Γ p (A : PTm ) B C : - Γ ⊢ PBind p A B ≲ C -> - exists i A0 B0, Γ ⊢ C ≡ PBind p A0 B0 ∈ PUniv i. -Proof. - move => /[dup] h. - move /synsub_to_usub. - move => [h0 [h1 h2]]. - move /LoReds.FromSN : h1. - move => [C' [hC0 hC1]]. - have [i hC] : exists i, Γ ⊢ C ∈ PUniv i by qauto l:on use:regularity. - have hE : Γ ⊢ C ≡ C' ∈ PUniv i by sfirstorder use:loreds_embed. - have : Γ ⊢ PBind p A B ≲ C' by eauto using Su_Transitive, Su_Eq. - move : hE hC1. clear. - case : C' => //=. - - move => k _ _ /synsub_to_usub. - clear. move => [_ [_ h]]. exfalso. - rewrite /Sub.R in h. - move : h => [c][d][+ []]. - move /REReds.bind_inv => ?. - move /REReds.var_inv => ?. - sauto lq:on. - - move => p0 h. exfalso. - have {h} : Γ ⊢ PAbs p0 ∈ PUniv i by hauto l:on use:regularity. - move /Abs_Inv => [A0][B0][_]/synsub_to_usub. - hauto l:on use:Sub.bind_univ_noconf. - - move => u v hC /andP [h0 h1] /synsub_to_usub ?. - exfalso. - suff : SNe (PApp u v) by hauto l:on use:Sub.bind_sne_noconf. - eapply ne_nf_embed => //=. sfirstorder b:on. - - move => p0 p1 hC h ?. exfalso. - have {hC} : Γ ⊢ PPair p0 p1 ∈ PUniv i by hauto l:on use:regularity. - hauto lq:on use:Sub.bind_univ_noconf, synsub_to_usub, Pair_Inv. - - move => p0 p1 _ + /synsub_to_usub. - hauto lq:on use:Sub.bind_sne_noconf, ne_nf_embed. - - move => b p0 p1 h0 h1 /[dup] h2 /synsub_to_usub *. - have ? : b = p by hauto l:on use:Sub.bind_inj. subst. - eauto. - - hauto lq:on use:synsub_to_usub, Sub.bind_univ_noconf. - - move => _ _ /synsub_to_usub [_ [_ h]]. exfalso. - apply Sub.nat_bind_noconf in h => //=. - - move => h. - have {}h : Γ ⊢ PZero ∈ PUniv i by hauto l:on use:regularity. - exfalso. move : h. clear. - move /Zero_Inv /synsub_to_usub. - hauto l:on use:Sub.univ_nat_noconf. - - move => a h. - have {}h : Γ ⊢ PSuc a ∈ PUniv i by hauto l:on use:regularity. - exfalso. move /Suc_Inv : h => [_ /synsub_to_usub]. - hauto lq:on use:Sub.univ_nat_noconf. - - move => P0 a0 b0 c0 h0 h1 /synsub_to_usub [_ [_ h2]]. - set u := PInd _ _ _ _ in h0. - have hne : SNe u by sfirstorder use:ne_nf_embed. - exfalso. move : h2 hne. hauto l:on use:Sub.bind_sne_noconf. -Qed. - -Lemma Sub_Univ_InvR Γ i C : - Γ ⊢ PUniv i ≲ C -> - exists j k, Γ ⊢ C ≡ PUniv j ∈ PUniv k. -Proof. - move => /[dup] h. - move /synsub_to_usub. - move => [h0 [h1 h2]]. - move /LoReds.FromSN : h1. - move => [C' [hC0 hC1]]. - have [j hC] : exists i, Γ ⊢ C ∈ PUniv i by qauto l:on use:regularity. - have hE : Γ ⊢ C ≡ C' ∈ PUniv j by sfirstorder use:loreds_embed. - have : Γ ⊢ PUniv i ≲ C' by eauto using Su_Transitive, Su_Eq. - move : hE hC1. clear. - case : C' => //=. - - move => f => _ _ /synsub_to_usub. - move => [_ [_]]. - move => [v0][v1][/REReds.univ_inv + [/REReds.var_inv ]]. - hauto lq:on inv:Sub1.R. - - move => p hC. - have {hC} : Γ ⊢ PAbs p ∈ PUniv j by hauto l:on use:regularity. - hauto lq:on rew:off use:Abs_Inv, synsub_to_usub, - Sub.bind_univ_noconf. - - hauto q:on use:synsub_to_usub, Sub.univ_sne_noconf, ne_nf_embed. - - move => a b hC. - have {hC} : Γ ⊢ PPair a b ∈ PUniv j by hauto l:on use:regularity. - hauto lq:on rew:off use:Pair_Inv, synsub_to_usub, - Sub.bind_univ_noconf. - - hauto q:on use:synsub_to_usub, Sub.univ_sne_noconf, ne_nf_embed. - - hauto lq:on use:synsub_to_usub, Sub.univ_bind_noconf. - - sfirstorder. - - hauto q:on use:synsub_to_usub, Sub.nat_univ_noconf. - - move => h. - have {}h : Γ ⊢ PZero ∈ PUniv j by hauto l:on use:regularity. - exfalso. move : h. clear. - move /Zero_Inv /synsub_to_usub. - hauto l:on use:Sub.univ_nat_noconf. - - move => a h. - have {}h : Γ ⊢ PSuc a ∈ PUniv j by hauto l:on use:regularity. - exfalso. move /Suc_Inv : h => [_ /synsub_to_usub]. - hauto lq:on use:Sub.univ_nat_noconf. - - move => P0 a0 b0 c0 h0 h1 /synsub_to_usub [_ [_ h2]]. - set u := PInd _ _ _ _ in h0. - have hne : SNe u by sfirstorder use:ne_nf_embed. - exfalso. move : h2 hne. hauto l:on use:Sub.univ_sne_noconf. -Qed. - -Lemma Sub_Bind_InvL Γ p (A : PTm) B C : - Γ ⊢ C ≲ PBind p A B -> - exists i A0 B0, Γ ⊢ PBind p A0 B0 ≡ C ∈ PUniv i. -Proof. - move => /[dup] h. - move /synsub_to_usub. - move => [h0 [h1 h2]]. - move /LoReds.FromSN : h0. - move => [C' [hC0 hC1]]. - have [i hC] : exists i, Γ ⊢ C ∈ PUniv i by qauto l:on use:regularity. - have hE : Γ ⊢ C ≡ C' ∈ PUniv i by sfirstorder use:loreds_embed. - have : Γ ⊢ C' ≲ PBind p A B by eauto using Su_Transitive, Su_Eq, E_Symmetric. - move : hE hC1. clear. - case : C' => //=. - - move => k _ _ /synsub_to_usub. - clear. move => [_ [_ h]]. exfalso. - rewrite /Sub.R in h. - move : h => [c][d][+ []]. - move /REReds.var_inv => ?. - move /REReds.bind_inv => ?. - hauto lq:on inv:Sub1.R. - - move => p0 h. exfalso. - have {h} : Γ ⊢ PAbs p0 ∈ PUniv i by hauto l:on use:regularity. - move /Abs_Inv => [A0][B0][_]/synsub_to_usub. - hauto l:on use:Sub.bind_univ_noconf. - - move => u v hC /andP [h0 h1] /synsub_to_usub ?. - exfalso. - suff : SNe (PApp u v) by hauto l:on use:Sub.sne_bind_noconf. - eapply ne_nf_embed => //=. sfirstorder b:on. - - move => p0 p1 hC h ?. exfalso. - have {hC} : Γ ⊢ PPair p0 p1 ∈ PUniv i by hauto l:on use:regularity. - hauto lq:on use:Sub.bind_univ_noconf, synsub_to_usub, Pair_Inv. - - move => p0 p1 _ + /synsub_to_usub. - hauto lq:on use:Sub.sne_bind_noconf, ne_nf_embed. - - move => b p0 p1 h0 h1 /[dup] h2 /synsub_to_usub *. - have ? : b = p by hauto l:on use:Sub.bind_inj. subst. - eauto using E_Symmetric. - - hauto lq:on use:synsub_to_usub, Sub.univ_bind_noconf. - - move => _ _ /synsub_to_usub [_ [_ h]]. exfalso. - apply Sub.bind_nat_noconf in h => //=. - - move => h. - have {}h : Γ ⊢ PZero ∈ PUniv i by hauto l:on use:regularity. - exfalso. move : h. clear. - move /Zero_Inv /synsub_to_usub. - hauto l:on use:Sub.univ_nat_noconf. - - move => a h. - have {}h : Γ ⊢ PSuc a ∈ PUniv i by hauto l:on use:regularity. - exfalso. move /Suc_Inv : h => [_ /synsub_to_usub]. - hauto lq:on use:Sub.univ_nat_noconf. - - move => P0 a0 b0 c0 h0 h1 /synsub_to_usub [_ [_ h2]]. - set u := PInd _ _ _ _ in h0. - have hne : SNe u by sfirstorder use:ne_nf_embed. - exfalso. move : h2 hne. subst u. - hauto l:on use:Sub.sne_bind_noconf. -Qed. - -Lemma T_Abs_Inv Γ (a0 a1 : PTm) U : - Γ ⊢ PAbs a0 ∈ U -> - Γ ⊢ PAbs a1 ∈ U -> - exists Δ V, Δ ⊢ a0 ∈ V /\ Δ ⊢ a1 ∈ V. -Proof. - move /Abs_Inv => [A0][B0][wt0]hU0. - move /Abs_Inv => [A1][B1][wt1]hU1. - move /Sub_Bind_InvR : (hU0) => [i][A2][B2]hE. - have hSu : Γ ⊢ PBind PPi A1 B1 ≲ PBind PPi A2 B2 by eauto using Su_Eq, Su_Transitive. - have hSu' : Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A2 B2 by eauto using Su_Eq, Su_Transitive. - exists ((cons A2 Γ)), B2. - have [k ?] : exists k, Γ ⊢ A2 ∈ PUniv k by hauto lq:on use:regularity, Bind_Inv. - split. - - have /Su_Pi_Proj2_Var ? := hSu'. - have /Su_Pi_Proj1 ? := hSu'. - move /regularity_sub0 : hSu' => [j] /Bind_Inv [k0 [? ?]]. - apply T_Conv with (A := B0); eauto. - apply : ctx_eq_subst_one; eauto. - - have /Su_Pi_Proj2_Var ? := hSu. - have /Su_Pi_Proj1 ? := hSu. - move /regularity_sub0 : hSu => [j] /Bind_Inv [k0 [? ?]]. - apply T_Conv with (A := B1); eauto. - apply : ctx_eq_subst_one; eauto. -Qed. - -Lemma Abs_Pi_Inv Γ (a : PTm) A B : - Γ ⊢ PAbs a ∈ PBind PPi A B -> - (cons A Γ) ⊢ a ∈ B. -Proof. - move => h. - have [i hi] : exists i, Γ ⊢ PBind PPi A B ∈ PUniv i by hauto use:regularity. - have [{}i {}hi] : exists i, Γ ⊢ A ∈ PUniv i by hauto use:Bind_Inv. - apply : subject_reduction; last apply RRed.AppAbs'. - apply : T_App'; cycle 1. - apply : weakening_wt'; cycle 2. apply hi. - apply h. reflexivity. reflexivity. rewrite -/ren_PTm. - apply T_Var with (i := var_zero). - by eauto using Wff_Cons'. - apply here. - rewrite -/ren_PTm. - by asimpl; rewrite subst_scons_id. - rewrite -/ren_PTm. - by asimpl; rewrite subst_scons_id. -Qed. - -Lemma T_Abs_Neu_Inv Γ (a u : PTm) U : - Γ ⊢ PAbs a ∈ U -> - Γ ⊢ u ∈ U -> - exists Δ V, Δ ⊢ a ∈ V /\ Δ ⊢ PApp (ren_PTm shift u) (VarPTm var_zero) ∈ V. -Proof. - move => /[dup] ha' + hu. - move /Abs_Inv => [A0][B0][ha]hSu. - move /Sub_Bind_InvR : (hSu) => [i][A2][B2]hE. - have {}hu : Γ ⊢ u ∈ PBind PPi A2 B2 by eauto using T_Conv_E. - have ha'' : Γ ⊢ PAbs a ∈ PBind PPi A2 B2 by eauto using T_Conv_E. - have {}hE : Γ ⊢ PBind PPi A2 B2 ∈ PUniv i - by hauto l:on use:regularity. - have {i} [j {}hE] : exists j, Γ ⊢ A2 ∈ PUniv j - by qauto l:on use:Bind_Inv. - have hΓ : ⊢ cons A2 Γ by eauto using Wff_Cons'. - set Δ := cons _ _ in hΓ. - have {}hu : Δ ⊢ PApp (ren_PTm shift u) (VarPTm var_zero) ∈ B2. - apply : T_App'; cycle 1. apply : weakening_wt' => //=; eauto. - reflexivity. - rewrite -/ren_PTm. - apply T_Var; eauto using here. - rewrite -/ren_PTm. by asimpl; rewrite subst_scons_id. - exists Δ, B2. split => //. - by move /Abs_Pi_Inv in ha''. -Qed. - -Lemma T_Univ_Raise Γ (a : PTm) i j : - Γ ⊢ a ∈ PUniv i -> - i <= j -> - Γ ⊢ a ∈ PUniv j. -Proof. hauto lq:on rew:off use:T_Conv, Su_Univ, wff_mutual. Qed. - -Lemma Bind_Univ_Inv Γ p (A : PTm) B i : - Γ ⊢ PBind p A B ∈ PUniv i -> - Γ ⊢ A ∈ PUniv i /\ (cons A Γ) ⊢ B ∈ PUniv i. -Proof. - move /Bind_Inv. - move => [i0][hA][hB]h. - move /synsub_to_usub : h => [_ [_ /Sub.univ_inj ? ]]. - sfirstorder use:T_Univ_Raise. -Qed. - -Lemma Pair_Sig_Inv Γ (a b : PTm) A B : - Γ ⊢ PPair a b ∈ PBind PSig A B -> - Γ ⊢ a ∈ A /\ Γ ⊢ b ∈ subst_PTm (scons a VarPTm) B. -Proof. - move => /[dup] h0 h1. - have [i hr] : exists i, Γ ⊢ PBind PSig A B ∈ PUniv i by sfirstorder use:regularity. - move /T_Proj1 in h0. - move /T_Proj2 in h1. - split. - hauto lq:on use:subject_reduction ctrs:RRed.R. - have hE : Γ ⊢ PProj PL (PPair a b) ≡ a ∈ A by - hauto lq:on use:RRed_Eq ctrs:RRed.R. - apply : T_Conv. - move /subject_reduction : h1. apply. - apply RRed.ProjPair. - apply : bind_inst; eauto. -Qed. - - -(* Coquand's algorithm with subtyping *) -Reserved Notation "a ∼ b" (at level 70). -Reserved Notation "a ↔ b" (at level 70). -Reserved Notation "a ⇔ b" (at level 70). -Inductive CoqEq : PTm -> PTm -> Prop := -| CE_ZeroZero : - PZero ↔ PZero - -| CE_SucSuc a b : - a ⇔ b -> - (* ------------- *) - PSuc a ↔ PSuc b - -| CE_AbsAbs a b : - a ⇔ b -> - (* --------------------- *) - PAbs a ↔ PAbs b - -| CE_AbsNeu a u : - ishne u -> - a ⇔ PApp (ren_PTm shift u) (VarPTm var_zero) -> - (* --------------------- *) - PAbs a ↔ u - -| CE_NeuAbs a u : - ishne u -> - PApp (ren_PTm shift u) (VarPTm var_zero) ⇔ a -> - (* --------------------- *) - u ↔ PAbs a - -| CE_PairPair a0 a1 b0 b1 : - a0 ⇔ a1 -> - b0 ⇔ b1 -> - (* ---------------------------- *) - PPair a0 b0 ↔ PPair a1 b1 - -| CE_PairNeu a0 a1 u : - ishne u -> - a0 ⇔ PProj PL u -> - a1 ⇔ PProj PR u -> - (* ----------------------- *) - PPair a0 a1 ↔ u - -| CE_NeuPair a0 a1 u : - ishne u -> - PProj PL u ⇔ a0 -> - PProj PR u ⇔ a1 -> - (* ----------------------- *) - u ↔ PPair a0 a1 - -| CE_UnivCong i : - (* -------------------------- *) - PUniv i ↔ PUniv i - -| CE_BindCong p A0 A1 B0 B1 : - A0 ⇔ A1 -> - B0 ⇔ B1 -> - (* ---------------------------- *) - PBind p A0 B0 ↔ PBind p A1 B1 - -| CE_NatCong : - (* ------------------ *) - PNat ↔ PNat - -| CE_NeuNeu a0 a1 : - a0 ∼ a1 -> - a0 ↔ a1 - -with CoqEq_Neu : PTm -> PTm -> Prop := -| CE_VarCong i : - (* -------------------------- *) - VarPTm i ∼ VarPTm i - -| CE_ProjCong p u0 u1 : - ishne u0 -> - ishne u1 -> - u0 ∼ u1 -> - (* --------------------- *) - PProj p u0 ∼ PProj p u1 - -| CE_AppCong u0 u1 a0 a1 : - ishne u0 -> - ishne u1 -> - u0 ∼ u1 -> - a0 ⇔ a1 -> - (* ------------------------- *) - PApp u0 a0 ∼ PApp u1 a1 - -| CE_IndCong P0 P1 u0 u1 b0 b1 c0 c1 : - ishne u0 -> - ishne u1 -> - P0 ⇔ P1 -> - u0 ∼ u1 -> - b0 ⇔ b1 -> - c0 ⇔ c1 -> - (* ----------------------------------- *) - PInd P0 u0 b0 c0 ∼ PInd P1 u1 b1 c1 - -with CoqEq_R : PTm -> PTm -> Prop := -| CE_HRed a a' b b' : - rtc HRed.R a a' -> - rtc HRed.R b b' -> - a' ↔ b' -> - (* ----------------------- *) - a ⇔ b -where "a ↔ b" := (CoqEq a b) and "a ⇔ b" := (CoqEq_R a b) and "a ∼ b" := (CoqEq_Neu a b). - -Lemma CE_HRedL (a a' b : PTm) : - HRed.R a a' -> - a' ⇔ b -> - a ⇔ b. -Proof. - hauto lq:on ctrs:rtc, CoqEq_R inv:CoqEq_R. -Qed. - -Lemma CE_HRedR (a b b' : PTm) : - HRed.R b b' -> - a ⇔ b' -> - a ⇔ b. -Proof. - hauto lq:on ctrs:rtc, CoqEq_R inv:CoqEq_R. -Qed. - -Lemma CE_Nf a b : - a ↔ b -> a ⇔ b. -Proof. hauto l:on ctrs:rtc. Qed. - -Scheme - coqeq_neu_ind := Induction for CoqEq_Neu Sort Prop - with coqeq_ind := Induction for CoqEq Sort Prop - with coqeq_r_ind := Induction for CoqEq_R Sort Prop. - -Combined Scheme coqeq_mutual from coqeq_neu_ind, coqeq_ind, coqeq_r_ind. - -Lemma coqeq_symmetric_mutual : - (forall (a b : PTm), a ∼ b -> b ∼ a) /\ - (forall (a b : PTm), a ↔ b -> b ↔ a) /\ - (forall (a b : PTm), a ⇔ b -> b ⇔ a). -Proof. apply coqeq_mutual; qauto l:on ctrs:CoqEq,CoqEq_R, CoqEq_Neu. Qed. - -Lemma coqeq_sound_mutual : - (forall (a b : PTm ), a ∼ b -> forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> exists C, - Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ≡ b ∈ C) /\ - (forall (a b : PTm ), a ↔ b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> Γ ⊢ a ≡ b ∈ A) /\ - (forall (a b : PTm ), a ⇔ b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> Γ ⊢ a ≡ b ∈ A). -Proof. - move => [:hAppL hPairL]. - apply coqeq_mutual. - - move => i Γ A B hi0 hi1. - move /Var_Inv : hi0 => [hΓ [C [h00 h01]]]. - move /Var_Inv : hi1 => [_ [C0 [h10 h11]]]. - have ? : C0 = C by eauto using lookup_deter. subst. - exists C. - repeat split => //=. - apply E_Refl. eauto using T_Var. - - move => [] u0 u1 hu0 hu1 hu ihu Γ A B hu0' hu1'. - + move /Proj1_Inv : hu0'. - move => [A0][B0][hu0']hu0''. - move /Proj1_Inv : hu1'. - move => [A1][B1][hu1']hu1''. - specialize ihu with (1 := hu0') (2 := hu1'). - move : ihu. - move => [C][ih0][ih1]ih. - have [i[A2[B2 h2]]] : exists i A2 B2, Γ ⊢ PBind PSig A2 B2 ≡ C ∈ PUniv i by sfirstorder use:Sub_Bind_InvL. - exists A2. - have [h3 h4] : Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A0 B0 /\ Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A1 B1 by qauto l:on use:Su_Eq, Su_Transitive. - repeat split; - eauto using Su_Sig_Proj1, Su_Transitive;[idtac]. - apply E_Proj1 with (B := B2); eauto using E_Conv_E. - + move /Proj2_Inv : hu0'. - move => [A0][B0][hu0']hu0''. - move /Proj2_Inv : hu1'. - move => [A1][B1][hu1']hu1''. - specialize ihu with (1 := hu0') (2 := hu1'). - move : ihu. - move => [C][ih0][ih1]ih. - have [A2 [B2 [i hi]]] : exists A2 B2 i, Γ ⊢ PBind PSig A2 B2 ≡ C ∈ PUniv i by hauto q:on use:Sub_Bind_InvL. - have [h3 h4] : Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A0 B0 /\ Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A1 B1 by qauto l:on use:Su_Eq, Su_Transitive. - have h5 : Γ ⊢ u0 ≡ u1 ∈ PBind PSig A2 B2 by eauto using E_Conv_E. - exists (subst_PTm (scons (PProj PL u0) VarPTm) B2). - have [? ?] : Γ ⊢ u0 ∈ PBind PSig A2 B2 /\ Γ ⊢ u1 ∈ PBind PSig A2 B2 by hauto l:on use:regularity. - repeat split => //=. - apply : Su_Transitive ;eauto. - apply : Su_Sig_Proj2; eauto. - apply E_Refl. eauto using T_Proj1. - apply : Su_Transitive ;eauto. - apply : Su_Sig_Proj2; eauto. - apply : E_Proj1; eauto. - apply : E_Proj2; eauto. - - move => u0 u1 a0 a1 neu0 neu1 hu ihu ha iha Γ A B wta0 wta1. - move /App_Inv : wta0 => [A0][B0][hu0][ha0]hU. - move /App_Inv : wta1 => [A1][B1][hu1][ha1]hU1. - move : ihu hu0 hu1. repeat move/[apply]. - move => [C][hC0][hC1]hu01. - have [i [A2 [B2 hPi]]] : exists i A2 B2, Γ ⊢ PBind PPi A2 B2 ≡ C ∈ PUniv i by sfirstorder use:Sub_Bind_InvL. - have ? : Γ ⊢ PBind PPi A2 B2 ≲ PBind PPi A0 B0 by eauto using Su_Eq, Su_Transitive. - have h : Γ ⊢ PBind PPi A2 B2 ≲ PBind PPi A1 B1 by eauto using Su_Eq, Su_Transitive. - have ha' : Γ ⊢ a0 ≡ a1 ∈ A2 by - sauto lq:on use:Su_Transitive, Su_Pi_Proj1. - have hwf : Γ ⊢ PBind PPi A2 B2 ∈ PUniv i by hauto l:on use:regularity. - have [j hj'] : exists j,Γ ⊢ A2 ∈ PUniv j by hauto l:on use:regularity. - have ? : ⊢ Γ by sfirstorder use:wff_mutual. - exists (subst_PTm (scons a0 VarPTm) B2). - repeat split. apply : Su_Transitive; eauto. - apply : Su_Pi_Proj2'; eauto using E_Refl. - apply : Su_Transitive; eauto. - have ? : Γ ⊢ A1 ≲ A2 by eauto using Su_Pi_Proj1. - apply Su_Transitive with (B := subst_PTm (scons a1 VarPTm) B2); - first by sfirstorder use:bind_inst. - apply : Su_Pi_Proj2'; eauto using E_Refl. - apply E_App with (A := A2); eauto using E_Conv_E. - - move {hAppL hPairL} => P0 P1 u0 u1 b0 b1 c0 c1 neu0 neu1 hP ihP hu ihu hb ihb hc ihc Γ A B. - move /Ind_Inv => [i0][hP0][hu0][hb0][hc0]hSu0. - move /Ind_Inv => [i1][hP1][hu1][hb1][hc1]hSu1. - move : ihu hu0 hu1; do!move/[apply]. move => ihu. - have {}ihu : Γ ⊢ u0 ≡ u1 ∈ PNat by hauto l:on use:E_Conv. - have wfΓ : ⊢ Γ by hauto use:wff_mutual. - have wfΓ' : ⊢ (cons PNat Γ) by hauto lq:on use:Wff_Cons', T_Nat'. - move => [:sigeq]. - have sigeq' : Γ ⊢ PBind PSig PNat P0 ≡ PBind PSig PNat P1 ∈ PUniv (max i0 i1). - apply E_Bind. by eauto using T_Nat, E_Refl. - abstract : sigeq. hauto lq:on use:T_Univ_Raise solve+:lia. - have sigleq : Γ ⊢ PBind PSig PNat P0 ≲ PBind PSig PNat P1. - apply Su_Sig with (i := 0)=>//. by apply T_Nat'. by eauto using Su_Eq, T_Nat', E_Refl. - apply Su_Eq with (i := max i0 i1). apply sigeq. - exists (subst_PTm (scons u0 VarPTm) P0). repeat split => //. - suff : Γ ⊢ subst_PTm (scons u0 VarPTm) P0 ≲ subst_PTm (scons u1 VarPTm) P1 by eauto using Su_Transitive. - by eauto using Su_Sig_Proj2. - apply E_IndCong with (i := max i0 i1); eauto. move :sigeq; clear; hauto q:on use:regularity. - apply ihb; eauto. apply : T_Conv; eauto. eapply morphing. apply : Su_Eq. apply E_Symmetric. apply sigeq. - done. apply morphing_ext. apply morphing_id. done. by apply T_Zero. - apply ihc; eauto. - eapply T_Conv; eauto. - eapply ctx_eq_subst_one; eauto. apply : Su_Eq; apply sigeq. - eapply weakening_su; eauto. - eapply morphing; eauto. apply : Su_Eq. apply E_Symmetric. apply sigeq. - apply morphing_ext. set x := {1}(funcomp _ shift). - have -> : x = funcomp (ren_PTm shift) VarPTm by asimpl. - apply : morphing_ren; eauto. apply : renaming_shift; eauto. by apply morphing_id. - apply T_Suc. apply T_Var; eauto using here. - - hauto lq:on use:Zero_Inv db:wt. - - hauto lq:on use:Suc_Inv db:wt. - - move => a b ha iha Γ A h0 h1. - move /Abs_Inv : h0 => [A0][B0][h0]h0'. - move /Abs_Inv : h1 => [A1][B1][h1]h1'. - have [i [A2 [B2 h]]] : exists i A2 B2, Γ ⊢ A ≡ PBind PPi A2 B2 ∈ PUniv i by hauto l:on use:Sub_Bind_InvR. - have hp0 : Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A2 B2 by eauto using Su_Transitive, Su_Eq. - have hp1 : Γ ⊢ PBind PPi A1 B1 ≲ PBind PPi A2 B2 by eauto using Su_Transitive, Su_Eq. - have [j ?] : exists j, Γ ⊢ A0 ∈ PUniv j by eapply wff_mutual in h0; inversion h0; subst; eauto. - have [k ?] : exists j, Γ ⊢ A1 ∈ PUniv j by eapply wff_mutual in h1; inversion h1; subst; eauto. - have [l ?] : exists j, Γ ⊢ A2 ∈ PUniv j by hauto lq:on rew:off use:regularity, Bind_Inv. - have [h2 h3] : Γ ⊢ A2 ≲ A0 /\ Γ ⊢ A2 ≲ A1 by hauto l:on use:Su_Pi_Proj1. - apply E_Conv with (A := PBind PPi A2 B2); cycle 1. - eauto using E_Symmetric, Su_Eq. - apply : E_Abs; eauto. - - apply iha. - move /Su_Pi_Proj2_Var in hp0. - apply : T_Conv; eauto. - eapply ctx_eq_subst_one with (A0 := A0); eauto. - move /Su_Pi_Proj2_Var in hp1. - apply : T_Conv; eauto. - eapply ctx_eq_subst_one with (A0 := A1); eauto. - - abstract : hAppL. - move => a u hneu ha iha Γ A wta wtu. - move /Abs_Inv : wta => [A0][B0][wta]hPi. - have [i [A2 [B2 h]]] : exists i A2 B2, Γ ⊢ A ≡ PBind PPi A2 B2 ∈ PUniv i by hauto l:on use:Sub_Bind_InvR. - have hPi'' : Γ ⊢ PBind PPi A2 B2 ≲ A by eauto using Su_Eq, Su_Transitive, E_Symmetric. - have [j0 ?] : exists j0, Γ ⊢ A0 ∈ PUniv j0 by move /regularity_sub0 in hPi; hauto lq:on use:Bind_Inv. - have [j2 ?] : exists j0, Γ ⊢ A2 ∈ PUniv j0 by move /regularity_sub0 in hPi''; hauto lq:on use:Bind_Inv. - have hPi' : Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A2 B2 by eauto using Su_Eq, Su_Transitive. - have hPidup := hPi'. - apply E_Conv with (A := PBind PPi A2 B2); eauto. - have /regularity_sub0 [i' hPi0] := hPi. - have : Γ ⊢ PAbs (PApp (ren_PTm shift u) (VarPTm var_zero)) ≡ u ∈ PBind PPi A2 B2. - apply : E_AppEta; eauto. - apply T_Conv with (A := A);eauto. - eauto using Su_Eq. - move => ?. - suff : Γ ⊢ PAbs a ≡ PAbs (PApp (ren_PTm shift u) (VarPTm var_zero)) ∈ PBind PPi A2 B2 - by eauto using E_Transitive. - apply : E_Abs; eauto. - apply iha. - move /Su_Pi_Proj2_Var in hPi'. - apply : T_Conv; eauto. - eapply ctx_eq_subst_one with (A0 := A0); eauto. - sfirstorder use:Su_Pi_Proj1. - eapply T_App' with (A := ren_PTm shift A2) (B := ren_PTm (upRen_PTm_PTm shift) B2). - by asimpl; rewrite subst_scons_id. - eapply weakening_wt' with (a := u) (A := PBind PPi A2 B2);eauto. - by eauto using T_Conv_E. apply T_Var. apply : Wff_Cons'; eauto. - apply here. - (* Mirrors the last case *) - - move => a u hu ha iha Γ A hu0 ha0. - apply E_Symmetric. - apply : hAppL; eauto. - sfirstorder use:coqeq_symmetric_mutual. - sfirstorder use:E_Symmetric. - - move => {hAppL hPairL} a0 a1 b0 b1 ha iha hb ihb Γ A. - move /Pair_Inv => [A0][B0][h00][h01]h02. - move /Pair_Inv => [A1][B1][h10][h11]h12. - have [i[A2[B2 h2]]] : exists i A2 B2, Γ ⊢ A ≡ PBind PSig A2 B2 ∈ PUniv i by hauto l:on use:Sub_Bind_InvR. - apply E_Conv with (A := PBind PSig A2 B2); last by eauto using E_Symmetric, Su_Eq. - have h0 : Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A2 B2 by eauto using Su_Transitive, Su_Eq, E_Symmetric. - have h1 : Γ ⊢ PBind PSig A1 B1 ≲ PBind PSig A2 B2 by eauto using Su_Transitive, Su_Eq, E_Symmetric. - have /Su_Sig_Proj1 h0' := h0. - have /Su_Sig_Proj1 h1' := h1. - move => [:eqa]. - apply : E_Pair; eauto. hauto l:on use:regularity. - abstract : eqa. apply iha; eauto using T_Conv. - apply ihb. - + apply T_Conv with (A := subst_PTm (scons a0 VarPTm) B0); eauto. - have : Γ ⊢ a0 ≡ a0 ∈A0 by eauto using E_Refl. - hauto l:on use:Su_Sig_Proj2. - + apply T_Conv with (A := subst_PTm (scons a1 VarPTm) B2); eauto; cycle 1. - move /E_Symmetric in eqa. - have ? : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i by hauto use:regularity. - apply:bind_inst; eauto. - apply : T_Conv; eauto. - have : Γ ⊢ a1 ≡ a1 ∈ A1 by eauto using E_Refl. - hauto l:on use:Su_Sig_Proj2. - - move => {hAppL}. - abstract : hPairL. - move => {hAppL}. - move => a0 a1 u neu h0 ih0 h1 ih1 Γ A ha hu. - move /Pair_Inv : ha => [A0][B0][ha0][ha1]ha. - have [i [A2 [B2 hA]]] : exists i A2 B2, Γ ⊢ A ≡ PBind PSig A2 B2 ∈ PUniv i by hauto l:on use:Sub_Bind_InvR. - have hA' : Γ ⊢ PBind PSig A2 B2 ≲ A by eauto using E_Symmetric, Su_Eq. - move /E_Conv : (hA'). apply. - have hSig : Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A2 B2 by eauto using E_Symmetric, Su_Eq, Su_Transitive. - have hA02 : Γ ⊢ A0 ≲ A2 by sfirstorder use:Su_Sig_Proj1. - have hu' : Γ ⊢ u ∈ PBind PSig A2 B2 by eauto using T_Conv_E. - move => [:ih0']. - apply : E_Transitive; last (apply : E_PairEta). - apply : E_Pair; eauto. hauto l:on use:regularity. - abstract : ih0'. - apply ih0. apply : T_Conv; eauto. - by eauto using T_Proj1. - apply ih1. apply : T_Conv; eauto. - move /E_Refl in ha0. - hauto l:on use:Su_Sig_Proj2. - move /T_Proj2 in hu'. - apply : T_Conv; eauto. - move /E_Symmetric in ih0'. - move /regularity_sub0 in hA'. - hauto l:on use:bind_inst. - eassumption. - (* Same as before *) - - move {hAppL}. - move => *. apply E_Symmetric. apply : hPairL; - sfirstorder use:coqeq_symmetric_mutual, E_Symmetric. - - sfirstorder use:E_Refl. - - move => {hAppL hPairL} p A0 A1 B0 B1 hA ihA hB ihB Γ A hA0 hA1. - move /Bind_Inv : hA0 => [i][hA0][hB0]hU. - move /Bind_Inv : hA1 => [j][hA1][hB1]hU1. - have [l [k hk]] : exists l k, Γ ⊢ A ≡ PUniv k ∈ PUniv l - by hauto lq:on use:Sub_Univ_InvR. - have hjk : Γ ⊢ PUniv j ≲ PUniv k by eauto using Su_Eq, Su_Transitive. - have hik : Γ ⊢ PUniv i ≲ PUniv k by eauto using Su_Eq, Su_Transitive. - apply E_Conv with (A := PUniv k); last by eauto using Su_Eq, E_Symmetric. - move => [:eqA]. - apply E_Bind. abstract : eqA. apply ihA. - apply T_Conv with (A := PUniv i); eauto. - apply T_Conv with (A := PUniv j); eauto. - apply ihB. - apply T_Conv with (A := PUniv i); eauto. - move : weakening_su hik hA0. by repeat move/[apply]. - apply T_Conv with (A := PUniv j); eauto. - apply : ctx_eq_subst_one; eauto. apply : Su_Eq; apply eqA. - move : weakening_su hjk hA0. by repeat move/[apply]. - - hauto lq:on ctrs:Eq,LEq,Wt. - - hauto lq:on ctrs:Eq,LEq,Wt. - - move => a a' b b' ha hb hab ihab Γ A ha0 hb0. - have [*] : Γ ⊢ a' ∈ A /\ Γ ⊢ b' ∈ A by eauto using HReds.preservation. - hauto lq:on use:HReds.ToEq, E_Symmetric, E_Transitive. -Qed. - -Definition term_metric k (a b : PTm) := - exists i j va vb, nsteps LoRed.R i a va /\ nsteps LoRed.R j b vb /\ nf va /\ nf vb /\ size_PTm va + size_PTm vb + i + j <= k. - -Lemma term_metric_sym k (a b : PTm) : - term_metric k a b -> term_metric k b a. -Proof. hauto lq:on unfold:term_metric solve+:lia. Qed. - -Lemma ne_hne (a : PTm) : ne a -> ishne a. -Proof. elim : a => //=; sfirstorder b:on. Qed. - -Lemma hf_hred_lored (a b : PTm) : - ~~ ishf a -> - LoRed.R a b -> - HRed.R a b \/ ishne a. -Proof. - move => + h. elim : a b/ h=>//=. - - hauto l:on use:HRed.AppAbs. - - hauto l:on use:HRed.ProjPair. - - hauto lq:on ctrs:HRed.R. - - hauto lq:on ctrs:HRed.R. - - hauto lq:on ctrs:HRed.R. - - sfirstorder use:ne_hne. - - hauto lq:on ctrs:HRed.R. - - sfirstorder use:ne_hne. - - hauto q:on ctrs:HRed.R. - - hauto lq:on use:ne_hne. - - hauto lq:on use:ne_hne. -Qed. - -Lemma term_metric_case k (a b : PTm) : - term_metric k a b -> - (ishf a \/ ishne a) \/ exists k' a', HRed.R a a' /\ term_metric k' a' b /\ k' < k. -Proof. - move=>[i][j][va][vb][h0] [h1][h2][h3]h4. - case : a h0 => //=; try firstorder. - - inversion h0 as [|A B C D E F]; subst. - hauto qb:on use:ne_hne. - inversion E; subst => /=. - + hauto lq:on use:HRed.AppAbs unfold:term_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:term_metric solve+:lia. - + sfirstorder qb:on use:ne_hne. - - inversion h0 as [|A B C D E F]; subst. - hauto qb:on use:ne_hne. - inversion E; subst => /=. - + hauto lq:on use:HRed.ProjPair unfold:term_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:term_metric solve+:lia. - - inversion h0 as [|A B C D E F]; subst. - hauto qb:on use:ne_hne. - inversion E; subst => /=. - + hauto lq:on use:HRed.IndZero unfold:term_metric solve+:lia. - + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:term_metric solve+:lia. - + sfirstorder use:ne_hne. - + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:term_metric solve+:lia. - + sfirstorder use:ne_hne. - + sfirstorder use:ne_hne. -Qed. - -Lemma A_Conf' a b : - ishf a \/ ishne a -> - ishf b \/ ishne b -> - tm_conf a b -> - algo_dom_r a b. -Proof. - move => ha hb. - move => ?. - apply A_NfNf. - apply A_Conf; sfirstorder use:hf_no_hred, hne_no_hred. -Qed. - -Lemma hne_nf_ne (a : PTm ) : - ishne a -> nf a -> ne a. -Proof. case : a => //=. Qed. - -Lemma lored_nsteps_renaming k (a b : PTm) (ξ : nat -> nat) : - nsteps LoRed.R k a b -> - nsteps LoRed.R k (ren_PTm ξ a) (ren_PTm ξ b). -Proof. - induction 1; hauto lq:on ctrs:nsteps use:LoRed.renaming. -Qed. - -Lemma hred_hne (a b : PTm) : - HRed.R a b -> - ishne a -> - False. -Proof. induction 1; sfirstorder. Qed. - -Lemma hf_not_hne (a : PTm) : - ishf a -> ishne a -> False. -Proof. case : a => //=. Qed. - -Lemma T_AbsPair_Imp Γ a (b0 b1 : PTm) A : - Γ ⊢ PAbs a ∈ A -> - Γ ⊢ PPair b0 b1 ∈ A -> - False. -Proof. - move /Abs_Inv => [A0][B0][_]haU. - move /Pair_Inv => [A1][B1][_][_]hbU. - move /Sub_Bind_InvR : haU => [i][A2][B2]h2. - have : Γ ⊢ PBind PSig A1 B1 ≲ PBind PPi A2 B2 by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. hauto l:on use:Sub.bind_inj. -Qed. - -Lemma T_AbsZero_Imp Γ a (A : PTm) : - Γ ⊢ PAbs a ∈ A -> - Γ ⊢ PZero ∈ A -> - False. -Proof. - move /Abs_Inv => [A0][B0][_]haU. - move /Zero_Inv => hbU. - move /Sub_Bind_InvR : haU => [i][A2][B2]h2. - have : Γ ⊢ PNat ≲ PBind PPi A2 B2 by eauto using Su_Transitive, Su_Eq. - clear. hauto lq:on use:synsub_to_usub, Sub.bind_nat_noconf. -Qed. - -Lemma T_AbsSuc_Imp Γ a b (A : PTm) : - Γ ⊢ PAbs a ∈ A -> - Γ ⊢ PSuc b ∈ A -> - False. -Proof. - move /Abs_Inv => [A0][B0][_]haU. - move /Suc_Inv => [_ hbU]. - move /Sub_Bind_InvR : haU => [i][A2][B2]h2. - have {hbU h2} : Γ ⊢ PNat ≲ PBind PPi A2 B2 by eauto using Su_Transitive, Su_Eq. - hauto lq:on use:Sub.bind_nat_noconf, synsub_to_usub. -Qed. - -Lemma Nat_Inv Γ A: - Γ ⊢ PNat ∈ A -> - exists i, Γ ⊢ PUniv i ≲ A. -Proof. - move E : PNat => u hu. - move : E. - elim : Γ u A / hu=>//=. - - hauto lq:on use:E_Refl, T_Univ, Su_Eq. - - hauto lq:on ctrs:LEq. -Qed. - -Lemma T_AbsNat_Imp Γ a (A : PTm ) : - Γ ⊢ PAbs a ∈ A -> - Γ ⊢ PNat ∈ A -> - False. -Proof. - move /Abs_Inv => [A0][B0][_]haU. - move /Nat_Inv => [i hA]. - move /Sub_Univ_InvR : hA => [j][k]hA. - have : Γ ⊢ PBind PPi A0 B0 ≲ PUniv j by eauto using Su_Transitive, Su_Eq. - hauto lq:on use:Sub.bind_univ_noconf, synsub_to_usub. -Qed. - -Lemma T_PairBind_Imp Γ (a0 a1 : PTm ) p A0 B0 U : - Γ ⊢ PPair a0 a1 ∈ U -> - Γ ⊢ PBind p A0 B0 ∈ U -> - False. -Proof. - move /Pair_Inv => [A1][B1][_][_]hbU. - move /Bind_Inv => [i][_ [_ haU]]. - move /Sub_Univ_InvR : haU => [j][k]hU. - have : Γ ⊢ PBind PSig A1 B1 ≲ PUniv j by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. hauto l:on use:Sub.bind_univ_noconf. -Qed. - -Lemma T_PairNat_Imp Γ (a0 a1 : PTm) U : - Γ ⊢ PPair a0 a1 ∈ U -> - Γ ⊢ PNat ∈ U -> - False. -Proof. - move/Pair_Inv => [A1][B1][_][_]hbU. - move /Nat_Inv => [i]/Sub_Univ_InvR[j][k]hU. - have : Γ ⊢ PBind PSig A1 B1 ≲ PUniv j by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. hauto l:on use:Sub.bind_univ_noconf. -Qed. - -Lemma T_PairZero_Imp Γ (a0 a1 : PTm ) U : - Γ ⊢ PPair a0 a1 ∈ U -> - Γ ⊢ PZero ∈ U -> - False. -Proof. - move/Pair_Inv=>[A1][B1][_][_]hbU. - move/Zero_Inv. move/Sub_Bind_InvR : hbU=>[i][A0][B0]*. - have : Γ ⊢ PNat ≲ PBind PSig A0 B0 by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. hauto l:on use:Sub.bind_nat_noconf. -Qed. - -Lemma T_PairSuc_Imp Γ (a0 a1 : PTm ) b U : - Γ ⊢ PPair a0 a1 ∈ U -> - Γ ⊢ PSuc b ∈ U -> - False. -Proof. - move/Pair_Inv=>[A1][B1][_][_]hbU. - move/Suc_Inv=>[_ hU]. move/Sub_Bind_InvR : hbU=>[i][A0][B0]*. - have : Γ ⊢ PNat ≲ PBind PSig A0 B0 by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. hauto l:on use:Sub.bind_nat_noconf. -Qed. - -Lemma Univ_Inv Γ i U : - Γ ⊢ PUniv i ∈ U -> - Γ ⊢ PUniv i ∈ PUniv (S i) /\ Γ ⊢ PUniv (S i) ≲ U. -Proof. - move E : (PUniv i) => u hu. - move : i E. elim : Γ u U / hu => n //=. - - hauto l:on use:E_Refl, Su_Eq, T_Univ. - - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma T_PairUniv_Imp Γ (a0 a1 : PTm) i U : - Γ ⊢ PPair a0 a1 ∈ U -> - Γ ⊢ PUniv i ∈ U -> - False. -Proof. - move /Pair_Inv => [A1][B1][_][_]hbU. - move /Univ_Inv => [h0 h1]. - move /Sub_Univ_InvR : h1 => [j [k hU]]. - have : Γ ⊢ PBind PSig A1 B1 ≲ PUniv j by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. - hauto lq:on use:Sub.bind_univ_noconf. -Qed. - -Lemma T_AbsUniv_Imp Γ a i (A : PTm) : - Γ ⊢ PAbs a ∈ A -> - Γ ⊢ PUniv i ∈ A -> - False. -Proof. - move /Abs_Inv => [A0][B0][_]haU. - move /Univ_Inv => [h0 h1]. - move /Sub_Univ_InvR : h1 => [j [k hU]]. - have : Γ ⊢ PBind PPi A0 B0 ≲ PUniv j by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. - hauto lq:on use:Sub.bind_univ_noconf. -Qed. - -Lemma T_AbsUniv_Imp' Γ (a : PTm) i : - Γ ⊢ PAbs a ∈ PUniv i -> False. -Proof. - hauto lq:on use:synsub_to_usub, Sub.bind_univ_noconf, Abs_Inv. -Qed. - -Lemma T_ZeroUniv_Imp' Γ i : - Γ ⊢ PZero ∈ PUniv i -> False. -Proof. - hauto lq:on use:synsub_to_usub, Sub.univ_nat_noconf, Zero_Inv. -Qed. - -Lemma T_SucUniv_Imp' Γ (a : PTm) i : - Γ ⊢ PSuc a ∈ PUniv i -> False. -Proof. - hauto lq:on use:synsub_to_usub, Sub.univ_nat_noconf, Suc_Inv. -Qed. - -Lemma T_PairUniv_Imp' Γ (a b : PTm) i : - Γ ⊢ PPair a b ∈ PUniv i -> False. -Proof. - hauto lq:on use:synsub_to_usub, Sub.bind_univ_noconf, Pair_Inv. -Qed. - -Lemma T_AbsBind_Imp Γ a p A0 B0 (U : PTm ) : - Γ ⊢ PAbs a ∈ U -> - Γ ⊢ PBind p A0 B0 ∈ U -> - False. -Proof. - move /Abs_Inv => [A1][B1][_ ha]. - move /Bind_Inv => [i [_ [_ h]]]. - move /Sub_Univ_InvR : h => [j [k hU]]. - have : Γ ⊢ PBind PPi A1 B1 ≲ PUniv j by eauto using Su_Transitive, Su_Eq. - clear. move /synsub_to_usub. - hauto lq:on use:Sub.bind_univ_noconf. -Qed. - -Lemma lored_nsteps_suc_inv k (a : PTm ) b : - nsteps LoRed.R k (PSuc a) b -> exists b', nsteps LoRed.R k a b' /\ b = PSuc b'. -Proof. - move E : (PSuc a) => u hu. - move : a E. - elim : u b /hu. - - hauto l:on. - - scrush ctrs:nsteps inv:LoRed.R. -Qed. - -Lemma lored_nsteps_abs_inv k (a : PTm) b : - nsteps LoRed.R k (PAbs a) b -> exists b', nsteps LoRed.R k a b' /\ b = PAbs b'. -Proof. - move E : (PAbs a) => u hu. - move : a E. - elim : u b /hu. - - hauto l:on. - - scrush ctrs:nsteps inv:LoRed.R. -Qed. - -Lemma lored_hne_preservation (a b : PTm) : - LoRed.R a b -> ishne a -> ishne b. -Proof. induction 1; sfirstorder. Qed. - -Lemma loreds_hne_preservation (a b : PTm ) : - rtc LoRed.R a b -> ishne a -> ishne b. -Proof. induction 1; hauto lq:on ctrs:rtc use:lored_hne_preservation. Qed. - -Lemma lored_nsteps_bind_inv k p (a0 : PTm ) b0 C : - nsteps LoRed.R k (PBind p a0 b0) C -> - exists i j a1 b1, - i <= k /\ j <= k /\ - C = PBind p a1 b1 /\ - nsteps LoRed.R i a0 a1 /\ - nsteps LoRed.R j b0 b1. -Proof. - move E : (PBind p a0 b0) => u hu. move : p a0 b0 E. - elim : k u C / hu. - - sauto lq:on. - - move => k a0 a1 a2 ha ha' ih p a3 b0 ?. subst. - inversion ha; subst => //=; - spec_refl. - move : ih => [i][j][a1][b1][?][?][?][h0]h1. subst. - exists (S i),j,a1,b1. sauto lq:on solve+:lia. - move : ih => [i][j][a1][b1][?][?][?][h0]h1. subst. - exists i,(S j),a1,b1. sauto lq:on solve+:lia. -Qed. - -Lemma lored_nsteps_ind_inv k P0 (a0 : PTm) b0 c0 U : - nsteps LoRed.R k (PInd P0 a0 b0 c0) U -> - ishne a0 -> - exists iP ia ib ic P1 a1 b1 c1, - iP <= k /\ ia <= k /\ ib <= k /\ ic <= k /\ - U = PInd P1 a1 b1 c1 /\ - nsteps LoRed.R iP P0 P1 /\ - nsteps LoRed.R ia a0 a1 /\ - nsteps LoRed.R ib b0 b1 /\ - nsteps LoRed.R ic c0 c1. -Proof. - move E : (PInd P0 a0 b0 c0) => u hu. - move : P0 a0 b0 c0 E. - elim : k u U / hu. - - sauto lq:on. - - move => k t0 t1 t2 ht01 ht12 ih P0 a0 b0 c0 ? nea0. subst. - inversion ht01; subst => //=; spec_refl. - * move /(_ ltac:(done)) : ih. - move => [iP][ia][ib][ic]. - exists (S iP), ia, ib, ic. sauto lq:on solve+:lia. - * move /(_ ltac:(sfirstorder use:lored_hne_preservation)) : ih. - move => [iP][ia][ib][ic]. - exists iP, (S ia), ib, ic. sauto lq:on solve+:lia. - * move /(_ ltac:(done)) : ih. - move => [iP][ia][ib][ic]. - exists iP, ia, (S ib), ic. sauto lq:on solve+:lia. - * move /(_ ltac:(done)) : ih. - move => [iP][ia][ib][ic]. - exists iP, ia, ib, (S ic). sauto lq:on solve+:lia. -Qed. - -Lemma lored_nsteps_app_inv k (a0 b0 C : PTm) : - nsteps LoRed.R k (PApp a0 b0) C -> - ishne a0 -> - exists i j a1 b1, - i <= k /\ j <= k /\ - C = PApp a1 b1 /\ - nsteps LoRed.R i a0 a1 /\ - nsteps LoRed.R j b0 b1. -Proof. - move E : (PApp a0 b0) => u hu. move : a0 b0 E. - elim : k u C / hu. - - sauto lq:on. - - move => k a0 a1 a2 ha01 ha12 ih a3 b0 ?. subst. - inversion ha01; subst => //=. - spec_refl. - move => h. - have : ishne a4 by sfirstorder use:lored_hne_preservation. - move : ih => /[apply]. move => [i][j][a1][b1][?][?][?][h0]h1. - subst. exists (S i),j,a1,b1. sauto lq:on solve+:lia. - spec_refl. move : ih => /[apply]. - move => [i][j][a1][b1][?][?][?][h0]h1. subst. - exists i, (S j), a1, b1. sauto lq:on solve+:lia. -Qed. - -Lemma lored_nsteps_proj_inv k p (a0 C : PTm) : - nsteps LoRed.R k (PProj p a0) C -> - ishne a0 -> - exists i a1, - i <= k /\ - C = PProj p a1 /\ - nsteps LoRed.R i a0 a1. -Proof. - move E : (PProj p a0) => u hu. move : a0 E. - elim : k u C / hu. - - sauto lq:on. - - move => k a0 a1 a2 ha01 ha12 ih a3 ?. subst. - inversion ha01; subst => //=. - spec_refl. - move => h. - have : ishne a4 by sfirstorder use:lored_hne_preservation. - move : ih => /[apply]. move => [i][a1][?][?]h0. subst. - exists (S i), a1. hauto lq:on ctrs:nsteps solve+:lia. -Qed. - -Lemma lored_nsteps_app_cong k (a0 a1 b : PTm) : - nsteps LoRed.R k a0 a1 -> - ishne a0 -> - nsteps LoRed.R k (PApp a0 b) (PApp a1 b). - move => h. move : b. - elim : k a0 a1 / h. - - sauto. - - move => m a0 a1 a2 h0 h1 ih. - move => b hneu. - apply : nsteps_l; eauto using LoRed.AppCong0. - apply LoRed.AppCong0;eauto. move : hneu. clear. case : a0 => //=. - apply ih. sfirstorder use:lored_hne_preservation. -Qed. - -Lemma lored_nsteps_proj_cong k p (a0 a1 : PTm) : - nsteps LoRed.R k a0 a1 -> - ishne a0 -> - nsteps LoRed.R k (PProj p a0) (PProj p a1). - move => h. move : p. - elim : k a0 a1 / h. - - sauto. - - move => m a0 a1 a2 h0 h1 ih p hneu. - apply : nsteps_l; eauto using LoRed.ProjCong. - apply LoRed.ProjCong;eauto. move : hneu. clear. case : a0 => //=. - apply ih. sfirstorder use:lored_hne_preservation. -Qed. - -Lemma lored_nsteps_pair_inv k (a0 b0 C : PTm ) : - nsteps LoRed.R k (PPair a0 b0) C -> - exists i j a1 b1, - i <= k /\ j <= k /\ - C = PPair a1 b1 /\ - nsteps LoRed.R i a0 a1 /\ - nsteps LoRed.R j b0 b1. - move E : (PPair a0 b0) => u hu. move : a0 b0 E. - elim : k u C / hu. - - sauto lq:on. - - move => k a0 a1 a2 ha01 ha12 ih a3 b0 ?. subst. - inversion ha01; subst => //=. - spec_refl. - move : ih => [i][j][a1][b1][?][?][?][h0]h1. - subst. exists (S i),j,a1,b1. sauto lq:on solve+:lia. - spec_refl. - move : ih => [i][j][a1][b1][?][?][?][h0]h1. subst. - exists i, (S j), a1, b1. sauto lq:on solve+:lia. -Qed. - -Lemma term_metric_abs : forall k a b, - term_metric k (PAbs a) (PAbs b) -> - exists k', k' < k /\ term_metric k' a b. -Proof. - move => k a b [i][j][va][vb][hva][hvb][nfa][nfb]h. - apply lored_nsteps_abs_inv in hva, hvb. - move : hva => [a'][hva]?. subst. - move : hvb => [b'][hvb]?. subst. - simpl in *. exists (k - 1). - hauto lq:on unfold:term_metric solve+:lia. -Qed. - -Lemma term_metric_pair : forall k a0 b0 a1 b1, - term_metric k (PPair a0 b0) (PPair a1 b1) -> - exists k', k' < k /\ term_metric k' a0 a1 /\ term_metric k' b0 b1. -Proof. - move => k a0 b0 a1 b1 [i][j][va][vb][hva][hvb][nfa][nfb]h. - apply lored_nsteps_pair_inv in hva, hvb. - decompose record hva => {hva}. - decompose record hvb => {hvb}. subst. - simpl in *. exists (k - 1). - hauto lqb:on solve+:lia. -Qed. - -Lemma term_metric_bind : forall k p0 a0 b0 p1 a1 b1, - term_metric k (PBind p0 a0 b0) (PBind p1 a1 b1) -> - exists k', k' < k /\ term_metric k' a0 a1 /\ term_metric k' b0 b1. -Proof. - move => k p0 a0 b0 p1 a1 b1 [i][j][va][vb][hva][hvb][nfa][nfb]h. - apply lored_nsteps_bind_inv in hva, hvb. - decompose record hva => {hva}. - decompose record hvb => {hvb}. subst. - simpl in *. exists (k - 1). - hauto lqb:on solve+:lia. -Qed. - -Lemma term_metric_suc : forall k a b, - term_metric k (PSuc a) (PSuc b) -> - exists k', k' < k /\ term_metric k' a b. -Proof. - move => k a b [i][j][va][vb][hva][hvb][nfa][nfb]h. - apply lored_nsteps_suc_inv in hva, hvb. - move : hva => [a'][hva]?. subst. - move : hvb => [b'][hvb]?. subst. - simpl in *. exists (k - 1). - hauto lq:on unfold:term_metric solve+:lia. -Qed. - -Lemma term_metric_abs_neu k (a0 : PTm) u : - term_metric k (PAbs a0) u -> - ishne u -> - exists j, j < k /\ term_metric j a0 (PApp (ren_PTm shift u) (VarPTm var_zero)). -Proof. - move => [i][j][va][vb][h0][h1][h2][h3]h4 neu. - have neva : ne vb by hauto lq:on use:hne_nf_ne, loreds_hne_preservation, @relations.rtc_nsteps. - move /lored_nsteps_abs_inv : h0 => [a1][h01]?. subst. - exists (k - 1). - simpl in *. split. lia. - exists i,j,a1,(PApp (ren_PTm shift vb) (VarPTm var_zero)). - repeat split => //=. - apply lored_nsteps_app_cong. - by apply lored_nsteps_renaming. - by rewrite ishne_ren. - rewrite Bool.andb_true_r. - sfirstorder use:ne_nf_ren. - rewrite size_PTm_ren. lia. -Qed. - -Lemma term_metric_pair_neu k (a0 b0 : PTm) u : - term_metric k (PPair a0 b0) u -> - ishne u -> - exists j, j < k /\ term_metric j (PProj PL u) a0 /\ term_metric j (PProj PR u) b0. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3]h4 neu. - have neva : ne vb by hauto lq:on use:hne_nf_ne, loreds_hne_preservation, @relations.rtc_nsteps. - move /lored_nsteps_pair_inv : h0 => [i0][j0][a1][b1][?][?][?][?]?. subst. - exists (k-1). sauto qb:on use:lored_nsteps_proj_cong unfold:term_metric solve+:lia. -Qed. - -Lemma term_metric_app k (a0 b0 a1 b1 : PTm) : - term_metric k (PApp a0 b0) (PApp a1 b1) -> - ishne a0 -> - ishne a1 -> - exists j, j < k /\ term_metric j a0 a1 /\ term_metric j b0 b1. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3]h4. - move => hne0 hne1. - move : lored_nsteps_app_inv h0 (hne0);repeat move/[apply]. - move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. - move : lored_nsteps_app_inv h1 (hne1);repeat move/[apply]. - move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. - simpl in *. exists (k - 1). hauto lqb:on use:lored_nsteps_app_cong, ne_nf unfold:term_metric solve+:lia. -Qed. - -Lemma term_metric_proj k p0 p1 (a0 a1 : PTm) : - term_metric k (PProj p0 a0) (PProj p1 a1) -> - ishne a0 -> - ishne a1 -> - exists j, j < k /\ term_metric j a0 a1. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3]h4 hne0 hne1. - move : lored_nsteps_proj_inv h0 (hne0);repeat move/[apply]. - move => [i0][a2][hi][?]ha02. subst. - move : lored_nsteps_proj_inv h1 (hne1);repeat move/[apply]. - move => [i1][a3][hj][?]ha13. subst. - exists (k- 1). hauto q:on use:ne_nf solve+:lia. -Qed. - -Lemma term_metric_ind k P0 (a0 : PTm ) b0 c0 P1 a1 b1 c1 : - term_metric k (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) -> - ishne a0 -> - ishne a1 -> - exists j, j < k /\ term_metric j P0 P1 /\ term_metric j a0 a1 /\ - term_metric j b0 b1 /\ term_metric j c0 c1. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3]h4 hne0 hne1. - move /lored_nsteps_ind_inv /(_ hne0) : h0. - move =>[iP][ia][ib][ic][P2][a2][b2][c2][?][?][?][?][?][?][?][?]?. subst. - move /lored_nsteps_ind_inv /(_ hne1) : h1. - move =>[iP0][ia0][ib0][ic0][P3][a3][b3][c3][?][?][?][?][?][?][?][?]?. subst. - exists (k -1). simpl in *. - hauto lq:on rew:off use:ne_nf b:on solve+:lia. -Qed. - -Lemma term_metric_algo_dom : forall k a b, term_metric k a b -> algo_dom_r a b. -Proof. - move => [:hneL]. - elim /Wf_nat.lt_wf_ind. - move => n ih a b h. - case /term_metric_case : (h); cycle 1. - move => [k'][a'][h0][h1]h2. - by apply : A_HRedL; eauto. - case /term_metric_sym /term_metric_case : (h); cycle 1. - move => [k'][b'][hb][/term_metric_sym h0]h1. - move => ha. have {}ha : HRed.nf a by sfirstorder use:hf_no_hred, hne_no_hred. - by apply : A_HRedR; eauto. - move => /[swap]. - case => hfa; case => hfb. - - move : hfa hfb h. - case : a; case : b => //=; eauto 5 using A_Conf' with adom. - + hauto lq:on use:term_metric_abs db:adom. - + hauto lq:on use:term_metric_pair db:adom. - + hauto lq:on use:term_metric_bind db:adom. - + hauto lq:on use:term_metric_suc db:adom. - - abstract : hneL n ih a b h hfa hfb. - case : a hfa h => //=. - + hauto lq:on use:term_metric_abs_neu db:adom. - + scrush use:term_metric_pair_neu db:adom. - + case : b hfb => //=; eauto 5 using A_Conf' with adom. - + case : b hfb => //=; eauto 5 using A_Conf' with adom. - + case : b hfb => //=; eauto 5 using A_Conf' with adom. - + case : b hfb => //=; eauto 5 using A_Conf' with adom. - + case : b hfb => //=; eauto 5 using A_Conf' with adom. - - hauto q:on use:algo_dom_sym, term_metric_sym. - - move {hneL}. - case : b hfa hfb h => //=; case a => //=; eauto 5 using A_Conf' with adom. - + move => a0 b0 a1 b1 nfa0 nfa1. - move /term_metric_app /(_ nfa0 nfa1) => [j][hj][ha]hb. - apply A_NfNf. - (* apply A_NfNf. apply A_NeuNeu. apply A_AppCong => //; eauto. *) - have nfa0' : HRed.nf a0 by sfirstorder use:hne_no_hred. - have nfb0' : HRed.nf a1 by sfirstorder use:hne_no_hred. - have ha0 : algo_dom a0 a1 by eauto using algo_dom_r_algo_dom. - constructor => //. eauto. - + move => p0 A0 p1 A1 neA0 neA1. - have {}nfa0 : HRed.nf A0 by sfirstorder use:hne_no_hred. - have {}nfb0 : HRed.nf A1 by sfirstorder use:hne_no_hred. - hauto lq:on use:term_metric_proj, algo_dom_r_algo_dom db:adom. - + move => P0 a0 b0 c0 P1 a1 b1 c1 nea0 nea1. - have {}nfa0 : HRed.nf a0 by sfirstorder use:hne_no_hred. - have {}nfb0 : HRed.nf a1 by sfirstorder use:hne_no_hred. - hauto lq:on use:term_metric_ind, algo_dom_r_algo_dom db:adom. -Qed. - -Lemma ce_neu_neu_helper a b : - ishne a -> ishne b -> - (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C) -> (forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b) /\ (forall Γ A B, ishne a -> ishne b -> Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C). -Proof. sauto lq:on. Qed. - -Lemma hne_ind_inj P0 P1 u0 u1 b0 b1 c0 c1 : - ishne u0 -> ishne u1 -> - DJoin.R (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) -> - DJoin.R P0 P1 /\ DJoin.R u0 u1 /\ DJoin.R b0 b1 /\ DJoin.R c0 c1. -Proof. hauto q:on use:REReds.hne_ind_inv. Qed. - -Lemma coqeq_complete' : - (forall a b, algo_dom a b -> DJoin.R a b -> (forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b) /\ (forall Γ A B, ishne a -> ishne b -> Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)) /\ - (forall a b, algo_dom_r a b -> DJoin.R a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b). - move => [:hConfNeuNf hhPairNeu hhAbsNeu]. - apply algo_dom_mutual. - - move => a b h ih hj. split => //. - move => Γ A. move : T_Abs_Inv; repeat move/[apply]. - move => [Δ][V][h0]h1. - have [? ?] : SN a /\ SN b by hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply CE_Nf. constructor. apply : ih; eauto using DJoin.abs_inj. - - abstract : hhAbsNeu. - move => a u hu ha iha hj => //. - split => //= Γ A. - move => + h. have ? : SN u by hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - move : T_Abs_Neu_Inv h; repeat move/[apply]. - move => [Δ][V][ha']hu'. - apply CE_Nf. constructor => //. apply : iha; eauto. - apply DJoin.abs_inj. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply : DJoin.transitive; eauto. - apply DJoin.symmetric. apply DJoin.FromEJoin. eexists. split. apply relations.rtc_once. - apply ERed.AppEta. apply rtc_refl. - - hauto q:on use:coqeq_symmetric_mutual, DJoin.symmetric, algo_dom_sym. - - move {hhAbsNeu hhPairNeu hConfNeuNf}. - move => a0 a1 b0 b1 doma iha domb ihb /DJoin.pair_inj hj. - split => //. - move => Γ A wt0 wt1. - have [] : SN (PPair a0 b0) /\ SN (PPair a1 b1) by hauto lq:on use:logrel.SemWt_SN, fundamental_theorem. - move : hj; repeat move/[apply]. - move => [hja hjb]. - move /Pair_Inv : wt0 => [A0][B0][ha0][hb0]hSu0. - move /Pair_Inv : wt1 => [A1][B1][ha1][hb1]hSu1. - move /Sub_Bind_InvR : (hSu0). - move => [i][A2][B2]hE. - have hSu12 : Γ ⊢ PBind PSig A1 B1 ≲ PBind PSig A2 B2 - by eauto using Su_Transitive, Su_Eq. - have hSu02 : Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A2 B2 - by eauto using Su_Transitive, Su_Eq. - have hA02 : Γ ⊢ A0 ≲ A2 by eauto using Su_Sig_Proj1. - have hA12 : Γ ⊢ A1 ≲ A2 by eauto using Su_Sig_Proj1. - have ha0A2 : Γ ⊢ a0 ∈ A2 by eauto using T_Conv. - have ha1A2 : Γ ⊢ a1 ∈ A2 by eauto using T_Conv. - move : iha (ha0A2) (ha1A2) hja; repeat move/[apply]. - move => h. - apply CE_Nf. - apply CE_PairPair => //. - have {}haE : Γ ⊢ a0 ≡ a1 ∈ A2 - by hauto l:on use:coqeq_sound_mutual. - have {}hb1 : Γ ⊢ b1 ∈ subst_PTm (scons a1 VarPTm) B2. - apply : T_Conv; eauto. - move /E_Refl in ha1. hauto l:on use:Su_Sig_Proj2. - eapply ihb; cycle -1; eauto. - apply : T_Conv; eauto. - apply Su_Transitive with (B := subst_PTm (scons a0 VarPTm) B2). - move /E_Refl in ha0. hauto l:on use:Su_Sig_Proj2. - move : hE haE. clear. - move => h. - eapply regularity in h. - move : h => [_ [hB _]]. - eauto using bind_inst. - - abstract : hhPairNeu. move {hConfNeuNf}. - move => a0 b0 u neu doma iha domb ihb hj. - split => // Γ A /[dup] wt /Pair_Inv - [A0][B0][ha0][hb0]hU. - move => wtu. - move /Sub_Bind_InvR : (hU) => [i][A2][B2]hE. - have {}wt : Γ ⊢ PPair a0 b0 ∈ PBind PSig A2 B2 by sauto lq:on. - have {}hu : Γ ⊢ u ∈ PBind PSig A2 B2 by eauto using T_Conv_E. - move /Pair_Sig_Inv : wt => [{}ha0 {}hb0]. - have /T_Proj1 huL := hu. - have /T_Proj2 {hu} huR := hu. - have heL : a0 ⇔ PProj PL u . apply : iha; eauto. - apply : DJoin.transitive; cycle 2. apply DJoin.ProjCong; eauto. - apply : N_Exp; eauto. apply N_ProjPairL. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply DJoin.FromRRed1. apply RRed.ProjPair. - eapply CE_HRed; eauto using rtc_refl. - apply CE_PairNeu; eauto. - eapply ihb; eauto. - apply : DJoin.transitive; cycle 2. apply DJoin.ProjCong; eauto. - apply : N_Exp; eauto. apply N_ProjPairR. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply DJoin.FromRRed1. apply RRed.ProjPair. - apply : T_Conv; eauto. - have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i - by hauto l:on use:regularity. - have /E_Symmetric : Γ ⊢ a0 ≡ PProj PL u ∈ A2 by - hauto l:on use:coqeq_sound_mutual. - hauto l:on use:bind_inst. - - move {hhAbsNeu}. - move => a0 a1 u hu ha iha hb ihb /DJoin.symmetric hj. split => // *. - eapply coqeq_symmetric_mutual. - eapply algo_dom_sym in ha, hb. - eapply hhPairNeu => //=; eauto; hauto lq:on use:DJoin.symmetric, coqeq_symmetric_mutual. - - move {hhPairNeu hhAbsNeu}. hauto l:on. - - move {hhPairNeu hhAbsNeu}. - move => a0 a1 ha iha /DJoin.suc_inj hj. split => //. - move => Γ A /Suc_Inv ? /Suc_Inv ?. apply CE_Nf. hauto lq:on ctrs:CoqEq. - - move => i j /DJoin.univ_inj ?. subst. - split => //. hauto l:on. - - move => {hhPairNeu hhAbsNeu} p0 p1 A0 A1 B0 B1. - move => hA ihA hB ihB /DJoin.bind_inj. move => [?][hjA]hjB. subst. - split => // Γ A. - move => hbd0 hbd1. - have {hbd0} : exists i, Γ ⊢ PBind p1 A0 B0 ∈ PUniv i by move /Bind_Inv in hbd0; qauto use:T_Bind. - move => [i] => hbd0. - have {hbd1} : exists i, Γ ⊢ PBind p1 A1 B1 ∈ PUniv i by move /Bind_Inv in hbd1; qauto use:T_Bind. - move => [j] => hbd1. - have /Bind_Univ_Inv {hbd0} [? ?] : Γ ⊢ PBind p1 A0 B0 ∈ PUniv (max i j) by hauto lq:on use:T_Univ_Raise solve+:lia. - have /Bind_Univ_Inv {hbd1} [? ?] : Γ ⊢ PBind p1 A1 B1 ∈ PUniv (max i j) by hauto lq:on use:T_Univ_Raise solve+:lia. - move => [:eqa]. - apply CE_Nf. constructor; first by abstract : eqa; eauto. - eapply ihB; eauto. apply : ctx_eq_subst_one; eauto. - apply : Su_Eq; eauto. sfirstorder use:coqeq_sound_mutual. - - hauto l:on. - - move => {hhAbsNeu hhPairNeu} i j /DJoin.var_inj ?. subst. apply ce_neu_neu_helper => // Γ A B. - move /Var_Inv => [h [A0 [h0 h1]]]. - move /Var_Inv => [h' [A1 [h0' h1']]]. - split. by constructor. - suff : A0 = A1 by hauto lq:on db:wt. - eauto using lookup_deter. - - move => u0 u1 a0 a1 neu0 neu1 domu ihu doma iha. move /DJoin.hne_app_inj /(_ neu0 neu1) => [hju hja]. - apply ce_neu_neu_helper => //= Γ A B. - move /App_Inv => [A0][B0][hb0][ha0]hS0. - move /App_Inv => [A1][B1][hb1][ha1]hS1. - move /(_ hju) : ihu. - move => [_ ihb]. - move : ihb (neu0) (neu1) hb0 hb1. repeat move/[apply]. - move => [hb01][C][hT0][hT1][hT2]hT3. - move /Sub_Bind_InvL : (hT0). - move => [i][A2][B2]hE. - have hSu20 : Γ ⊢ PBind PPi A2 B2 ≲ PBind PPi A0 B0 by - eauto using Su_Eq, Su_Transitive. - have hSu10 : Γ ⊢ PBind PPi A2 B2 ≲ PBind PPi A1 B1 by - eauto using Su_Eq, Su_Transitive. - have hSuA0 : Γ ⊢ A0 ≲ A2 by sfirstorder use:Su_Pi_Proj1. - have hSuA1 : Γ ⊢ A1 ≲ A2 by sfirstorder use:Su_Pi_Proj1. - have ha1' : Γ ⊢ a1 ∈ A2 by eauto using T_Conv. - have ha0' : Γ ⊢ a0 ∈ A2 by eauto using T_Conv. - move : iha hja. repeat move/[apply]. - move => iha. - move : iha (ha0') (ha1'); repeat move/[apply]. - move => iha. - split. sauto lq:on. - exists (subst_PTm (scons a0 VarPTm) B2). - split. - apply : Su_Transitive; eauto. - move /E_Refl in ha0. - hauto l:on use:Su_Pi_Proj2. - have h01 : Γ ⊢ a0 ≡ a1 ∈ A2 by sfirstorder use:coqeq_sound_mutual. - split. - apply Su_Transitive with (B := subst_PTm (scons a1 VarPTm) B2). - move /regularity_sub0 : hSu10 => [i0]. - hauto l:on use:bind_inst. - hauto lq:on rew:off use:Su_Pi_Proj2, Su_Transitive, E_Refl. - split. - by apply : T_App; eauto using T_Conv_E. - apply : T_Conv; eauto. - apply T_App with (A := A2) (B := B2); eauto. - apply : T_Conv_E; eauto. - move /E_Symmetric in h01. - move /regularity_sub0 : hSu20 => [i0]. - sfirstorder use:bind_inst. - - move => p0 p1 a0 a1 hne0 hne1 doma iha /DJoin.hne_proj_inj /(_ hne0 hne1) [? hja]. subst. - move : iha hja; repeat move/[apply]. - move => [_ iha]. apply ce_neu_neu_helper => // Γ A B. - move : iha (hne0) (hne1);repeat move/[apply]. - move => ih. - case : p1. - ** move => ha0 ha1. - move /Proj1_Inv : ha0. move => [A0][B0][ha0]hSu0. - move /Proj1_Inv : ha1. move => [A1][B1][ha1]hSu1. - move : ih ha0 ha1 (hne0) (hne1); repeat move/[apply]. - move => [ha [C [hS0 [hS1 [wta0 wta1]]]]]. - split. sauto lq:on. - move /Sub_Bind_InvL : (hS0) => [i][A2][B2]hS2. - have hSu20 : Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A0 B0 - by eauto using Su_Transitive, Su_Eq. - have hSu21 : Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A1 B1 - by eauto using Su_Transitive, Su_Eq. - exists A2. split; eauto using Su_Sig_Proj1, Su_Transitive. - repeat split => //=. - hauto l:on use:Su_Sig_Proj1, Su_Transitive. - apply T_Proj1 with (B := B2); eauto using T_Conv_E. - apply T_Proj1 with (B := B2); eauto using T_Conv_E. - ** move => ha0 ha1. - move /Proj2_Inv : ha0. move => [A0][B0][ha0]hSu0. - move /Proj2_Inv : ha1. move => [A1][B1][ha1]hSu1. - move : ih (ha0) (ha1) (hne0) (hne1); repeat move/[apply]. - move => [ha [C [hS0 [hS1 [wta0 wta1]]]]]. - split. sauto lq:on. - move /Sub_Bind_InvL : (hS0) => [i][A2][B2]hS2. - have hSu20 : Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A0 B0 - by eauto using Su_Transitive, Su_Eq. - have hSu21 : Γ ⊢ PBind PSig A2 B2 ≲ PBind PSig A1 B1 - by eauto using Su_Transitive, Su_Eq. - have hA20 : Γ ⊢ A2 ≲ A0 by eauto using Su_Sig_Proj1. - have hA21 : Γ ⊢ A2 ≲ A1 by eauto using Su_Sig_Proj1. - have {}wta0 : Γ ⊢ a0 ∈ PBind PSig A2 B2 by eauto using T_Conv_E. - have {}wta1 : Γ ⊢ a1 ∈ PBind PSig A2 B2 by eauto using T_Conv_E. - have haE : Γ ⊢ PProj PL a0 ≡ PProj PL a1 ∈ A2 - by sauto lq:on use:coqeq_sound_mutual. - exists (subst_PTm (scons (PProj PL a0) VarPTm) B2). - repeat split. - *** apply : Su_Transitive; eauto. - have : Γ ⊢ PProj PL a0 ≡ PProj PL a0 ∈ A2 - by qauto use:regularity, E_Refl. - sfirstorder use:Su_Sig_Proj2. - *** apply : Su_Transitive; eauto. - sfirstorder use:Su_Sig_Proj2. - *** eauto using T_Proj2. - *** apply : T_Conv. - apply : T_Proj2; eauto. - move /E_Symmetric in haE. - move /regularity_sub0 in hSu21. - sfirstorder use:bind_inst. - - move {hhPairNeu hhAbsNeu}. - move => P0 P1 u0 u1 b0 b1 c0 c1 neu0 neu1 domP ihP domu ihu domb ihb domc ihc /hne_ind_inj. - move => /(_ neu0 neu1) [hjP][hju][hjb]hjc. - apply ce_neu_neu_helper => // Γ A B. - move /Ind_Inv => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. - move /Ind_Inv => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. - have {}iha : u0 ∼ u1 by qauto l:on. - have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. - move : T_Univ_Raise wtP0; repeat move/[apply]. move => wtP0. - move : T_Univ_Raise wtP1; repeat move/[apply]. move => wtP1. - have {}ihP : P0 ⇔ P1 by qauto l:on. - set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. - have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. - have hPE : Δ ⊢ P0 ≡ P1 ∈ PUniv (max iP0 iP1) - by hauto l:on use:coqeq_sound_mutual. - have haE : Γ ⊢ u0 ≡ u1 ∈ PNat - by hauto l:on use:coqeq_sound_mutual. - have wtΓ : ⊢ Γ by hauto l:on use:wff_mutual. - have hE : Γ ⊢ subst_PTm (scons PZero VarPTm) P0 ≡ subst_PTm (scons PZero VarPTm) P1 ∈ subst_PTm (scons PZero VarPTm) (PUniv (Nat.max iP0 iP1)). - eapply morphing; eauto. apply morphing_ext. by apply morphing_id. by apply T_Zero. - have {}wtb1 : Γ ⊢ b1 ∈ subst_PTm (scons PZero VarPTm) P0 - by eauto using T_Conv_E. - have {}ihb : b0 ⇔ b1 by hauto l:on. - have hPSig : Γ ⊢ PBind PSig PNat P0 ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. - set T := ren_PTm shift _ in wtc0. - have : (cons P0 Δ) ⊢ c1 ∈ T. - apply : T_Conv; eauto. apply : ctx_eq_subst_one; eauto with wt. - apply : Su_Eq; eauto. - subst T. apply : weakening_su; eauto. - eapply morphing. apply : Su_Eq. apply E_Symmetric. by eauto. - hauto l:on use:wff_mutual. - apply morphing_ext. set x := funcomp _ _. - have -> : x = funcomp (ren_PTm shift) VarPTm by asimpl. - apply : morphing_ren; eauto using renaming_shift. by apply morphing_id. - apply T_Suc. apply T_Var => //=. apply here. subst T => {}wtc1. - have {}ihc : c0 ⇔ c1 by qauto l:on. - move => [:ih]. - split. abstract : ih. move : neu0 neu1 ihP iha ihb ihc. clear. sauto lq:on. - have hEInd : Γ ⊢ PInd P0 u0 b0 c0 ≡ PInd P1 u1 b1 c1 ∈ subst_PTm (scons u0 VarPTm) P0 by hfcrush use:coqeq_sound_mutual. - exists (subst_PTm (scons u0 VarPTm) P0). - repeat split => //=; eauto with wt. - apply : Su_Transitive. - apply : Su_Sig_Proj2; eauto. apply : Su_Sig; eauto using T_Nat' with wt. - apply : Su_Eq. apply E_Refl. by apply T_Nat'. - apply : Su_Eq. apply hPE. by eauto. - move : hEInd. clear. hauto l:on use:regularity. - - move => a b ha hb. - move {hhPairNeu hhAbsNeu}. - case : hb; case : ha. - + move {hConfNeuNf}. - move => h0 h1 h2 h3. split; last by sfirstorder use:hf_not_hne. - move : h0 h1 h2 h3. - case : b; case : a => //= *; try by (exfalso; eauto 2 using T_AbsPair_Imp, T_AbsUniv_Imp, T_AbsBind_Imp, T_AbsNat_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_PairUniv_Imp, T_PairBind_Imp, T_PairNat_Imp, T_PairZero_Imp, T_PairSuc_Imp). - sfirstorder use:DJoin.bind_univ_noconf. - hauto q:on use:REReds.nat_inv, REReds.bind_inv. - hauto q:on use:REReds.zero_inv, REReds.bind_inv. - hauto q:on use:REReds.suc_inv, REReds.bind_inv. - hauto q:on use:REReds.bind_inv, REReds.univ_inv. - hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv. - hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. - hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. - hauto lq:on rew:off use:REReds.bind_inv, REReds.nat_inv. - hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv. - hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. - hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. - hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. - hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. - hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. - hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. - hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. - hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. - hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. - hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. - + abstract : hConfNeuNf a b. - move => h0 h1 h2 h3. split; last by sfirstorder use:hf_not_hne. - move : h0 h1 h2 h3. - case : b; case : a => //=; hauto q:on use:REReds.var_inv, REReds.bind_inv, REReds.hne_app_inv, REReds.hne_proj_inv, REReds.hne_ind_inv, REReds.bind_inv, REReds.nat_inv, REReds.univ_inv, REReds.zero_inv, REReds.suc_inv. - + rewrite tm_conf_sym. - move => h0 h1 h2 /DJoin.symmetric hb. - move : hConfNeuNf h0 h1 h2 hb; repeat move/[apply]. - qauto l:on use:coqeq_symmetric_mutual. - + move => neua neub hconf hj. - move {hConfNeuNf}. - exfalso. - move : neua neub hconf hj. - case : b; case : a => //=*; exfalso; hauto q:on use:REReds.var_inv, REReds.bind_inv, REReds.hne_app_inv, REReds.hne_proj_inv, REReds.hne_ind_inv. - - sfirstorder. - - move {hConfNeuNf hhPairNeu hhAbsNeu}. - move => a a' b hr ha iha hj Γ A wta wtb. - apply : CE_HRedL; eauto. - apply : iha; eauto; last by sfirstorder use:HRed.preservation. - apply : DJoin.transitive; eauto. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply DJoin.FromRRed1. by apply HRed.ToRRed. - - move {hConfNeuNf hhPairNeu hhAbsNeu}. - move => a b b' nfa hr h ih j Γ A wta wtb. - apply : CE_HRedR; eauto. - apply : ih; eauto; last by eauto using HRed.preservation. - apply : DJoin.transitive; eauto. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply DJoin.FromRRed0. by apply HRed.ToRRed. -Qed. - -Lemma coqeq_sound : forall Γ (a b : PTm) A, - Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b -> Γ ⊢ a ≡ b ∈ A. -Proof. sfirstorder use:coqeq_sound_mutual. Qed. - -Lemma sn_term_metric (a b : PTm) : SN a -> SN b -> exists k, term_metric k a b. -Proof. - move /LoReds.FromSN => [va [ha0 ha1]]. - move /LoReds.FromSN => [vb [hb0 hb1]]. - eapply relations.rtc_nsteps in ha0. - eapply relations.rtc_nsteps in hb0. - hauto lq:on unfold:term_metric solve+:lia. -Qed. - -Lemma sn_algo_dom a b : SN a -> SN b -> algo_dom_r a b. -Proof. - move : sn_term_metric; repeat move/[apply]. - move => [k]+. - eauto using term_metric_algo_dom. -Qed. - -Lemma coqeq_complete Γ (a b A : PTm) : - Γ ⊢ a ≡ b ∈ A -> a ⇔ b. -Proof. - move => h. - have : algo_dom_r a b /\ DJoin.R a b by - hauto lq:on use:fundamental_theorem, logrel.SemEq_SemWt, logrel.SemWt_SN, sn_algo_dom. - hauto lq:on use:regularity, coqeq_complete'. -Qed. - -Reserved Notation "a ≪ b" (at level 70). -Reserved Notation "a ⋖ b" (at level 70). -Inductive CoqLEq : PTm -> PTm -> Prop := -| CLE_UnivCong i j : - i <= j -> - (* -------------------------- *) - PUniv i ⋖ PUniv j - -| CLE_PiCong A0 A1 B0 B1 : - A1 ≪ A0 -> - B0 ≪ B1 -> - (* ---------------------------- *) - PBind PPi A0 B0 ⋖ PBind PPi A1 B1 - -| CLE_SigCong A0 A1 B0 B1 : - A0 ≪ A1 -> - B0 ≪ B1 -> - (* ---------------------------- *) - PBind PSig A0 B0 ⋖ PBind PSig A1 B1 - -| CLE_NatCong : - PNat ⋖ PNat - -| CLE_NeuNeu a0 a1 : - a0 ∼ a1 -> - a0 ⋖ a1 - -with CoqLEq_R : PTm -> PTm -> Prop := -| CLE_HRed a a' b b' : - rtc HRed.R a a' -> - rtc HRed.R b b' -> - a' ⋖ b' -> - (* ----------------------- *) - a ≪ b -where "a ≪ b" := (CoqLEq_R a b) and "a ⋖ b" := (CoqLEq a b). - -Scheme coqleq_ind := Induction for CoqLEq Sort Prop - with coqleq_r_ind := Induction for CoqLEq_R Sort Prop. - -Combined Scheme coqleq_mutual from coqleq_ind, coqleq_r_ind. - -Lemma coqleq_sound_mutual : - (forall (a b : PTm), a ⋖ b -> forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> Γ ⊢ a ≲ b ) /\ - (forall (a b : PTm), a ≪ b -> forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> Γ ⊢ a ≲ b ). -Proof. - apply coqleq_mutual. - - hauto lq:on use:wff_mutual ctrs:LEq. - - move => A0 A1 B0 B1 hA ihA hB ihB Γ i. - move /Bind_Univ_Inv => [hA0]hB0 /Bind_Univ_Inv [hA1]hB1. - have hlA : Γ ⊢ A1 ≲ A0 by sfirstorder. - have hΓ : ⊢ Γ by sfirstorder use:wff_mutual. - apply Su_Transitive with (B := PBind PPi A1 B0). - by apply : Su_Pi; eauto using E_Refl, Su_Eq. - apply : Su_Pi; eauto using E_Refl, Su_Eq. - apply : ihB; eauto using ctx_eq_subst_one. - - move => A0 A1 B0 B1 hA ihA hB ihB Γ i. - move /Bind_Univ_Inv => [hA0]hB0 /Bind_Univ_Inv [hA1]hB1. - have hlA : Γ ⊢ A0 ≲ A1 by sfirstorder. - have hΓ : ⊢ Γ by sfirstorder use:wff_mutual. - apply Su_Transitive with (B := PBind PSig A0 B1). - apply : Su_Sig; eauto using E_Refl, Su_Eq. - apply : ihB; by eauto using ctx_eq_subst_one. - apply : Su_Sig; eauto using E_Refl, Su_Eq. - - sauto lq:on use:coqeq_sound_mutual, Su_Eq. - - sauto lq:on use:coqeq_sound_mutual, Su_Eq. - - move => a a' b b' ? ? ? ih Γ i ha hb. - have /Su_Eq ? : Γ ⊢ a ≡ a' ∈ PUniv i by sfirstorder use:HReds.ToEq. - have /E_Symmetric /Su_Eq ? : Γ ⊢ b ≡ b' ∈ PUniv i by sfirstorder use:HReds.ToEq. - suff : Γ ⊢ a' ≲ b' by eauto using Su_Transitive. - eauto using HReds.preservation. -Qed. - -Lemma CLE_HRedL (a a' b : PTm ) : - HRed.R a a' -> - a' ≪ b -> - a ≪ b. -Proof. - hauto lq:on ctrs:rtc, CoqLEq_R inv:CoqLEq_R. -Qed. - -Lemma CLE_HRedR (a a' b : PTm) : - HRed.R a a' -> - b ≪ a' -> - b ≪ a. -Proof. - hauto lq:on ctrs:rtc, CoqLEq_R inv:CoqLEq_R. -Qed. - -Lemma subvar_inj (i j : nat) : - Sub.R (VarPTm i) (VarPTm j) -> i = j. -Proof. - rewrite /Sub.R. - move => [c][d][h0][h1]h2. - apply REReds.var_inv in h0, h1. subst. - inversion h2; by subst. -Qed. - -Lemma algo_dom_hf_hne (a b : PTm) : - algo_dom a b -> - (ishf a \/ ishne a) /\ (ishf b \/ ishne b). -Proof. - inversion 1;subst => //=; by sfirstorder b:on. -Qed. - -Lemma algo_dom_neu_neu_nonconf a b : - algo_dom a b -> - neuneu_nonconf a b -> - ishne a /\ ishne b. -Proof. - move /algo_dom_hf_hne => h. - move => h1. - destruct a,b => //=; sfirstorder b:on. -Qed. - -Lemma coqleq_complete' : - (forall a b, salgo_dom a b -> Sub.R a b -> forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> a ⋖ b) /\ - (forall a b, salgo_dom_r a b -> Sub.R a b -> forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> a ≪ b). -Proof. - apply salgo_dom_mutual. - - move => i j /Sub.univ_inj. - hauto lq:on ctrs:CoqLEq. - - move => A0 A1 B0 B1 hA ihA hB ihB /Sub.bind_inj. move => [_][hjA]hjB Γ i. - move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. - have {}ihA : A1 ≪ A0 by hauto l:on. - constructor => //. - have ihA' : Γ ⊢ A1 ≲ A0 by hauto l:on use:coqleq_sound_mutual. - suff : (cons A1 Γ) ⊢ B0 ∈ PUniv i - by hauto l:on. - eauto using ctx_eq_subst_one. - - move => A0 A1 B0 B1 hA ihA hB ihB /Sub.bind_inj. move => [_][hjA]hjB Γ i. - move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. - have {}ihA : A0 ≪ A1 by hauto l:on. - constructor => //. - have ihA' : Γ ⊢ A0 ≲ A1 by hauto l:on use:coqleq_sound_mutual. - suff : (cons A0 Γ) ⊢ B1 ∈ PUniv i - by hauto l:on. - eauto using ctx_eq_subst_one. - - sfirstorder. - - move => a b hconf hdom. - have [? ?] : ishne a /\ ishne b by sfirstorder use:algo_dom_neu_neu_nonconf. - move => h. apply Sub.ToJoin in h; last by tauto. - move => Γ i ha hb. - apply CLE_NeuNeu. hauto q:on use:coqeq_complete'. - - move => [:neunf] a b. - case => ha; case => hb. - move : ha hb. - + case : a => //=; try solve [intros; exfalso; eauto using T_AbsUniv_Imp', T_PairUniv_Imp', T_ZeroUniv_Imp', T_SucUniv_Imp']. - * case : b => //=; try solve [intros; exfalso; eauto using T_AbsUniv_Imp', T_PairUniv_Imp', T_ZeroUniv_Imp', T_SucUniv_Imp']. - case => + + []//=. - hauto lq:on rew:off use:Sub.bind_inj. - hauto lq:on rew:off use:Sub.bind_inj. - hauto lq:on use:Sub.bind_univ_noconf. - hauto lq:on use:Sub.nat_bind_noconf. - * case : b => //=; try solve [intros; exfalso; eauto using T_AbsUniv_Imp', T_PairUniv_Imp', T_ZeroUniv_Imp', T_SucUniv_Imp']. - hauto lq:on use:Sub.univ_bind_noconf. - hauto lq:on use:Sub.nat_univ_noconf. - * case : b => //=; try solve [intros; exfalso; eauto using T_AbsUniv_Imp', T_PairUniv_Imp', T_ZeroUniv_Imp', T_SucUniv_Imp']. - hauto lq:on use:Sub.bind_nat_noconf. - hauto lq:on use:Sub.univ_nat_noconf. - + move => h0 h1. - apply Sub.ToJoin in h1; last by tauto. - move => Γ i wta wtb. exfalso. - abstract : neunf a b ha hb h0 h1 Γ i wta wtb. - case : a ha h0 h1 wta => //=; eauto using T_AbsUniv_Imp', T_PairUniv_Imp', T_ZeroUniv_Imp', T_SucUniv_Imp'. - sfirstorder use: DJoin.hne_bind_noconf. - sfirstorder use: DJoin.hne_univ_noconf. - sfirstorder use:DJoin.hne_nat_noconf. - + move => h0 h1. apply Sub.ToJoin in h1; last by tauto. - hauto drew:off use:DJoin.symmetric, stm_conf_sym. - + move => h0 h1 Γ i wta wtb. - apply CLE_NeuNeu. - apply Sub.ToJoin in h1; last by tauto. - eapply coqeq_complete'; eauto. - apply algo_dom_r_algo_dom. - sfirstorder use:hne_no_hred. - sfirstorder use:hne_no_hred. - hauto lq:on use:sn_algo_dom, logrel.SemWt_SN, fundamental_theorem. - - hauto l:on. - - move => a a' b hr ha iha hj Γ A wta wtb. - apply : CLE_HRedL; eauto. - apply : iha; eauto; last by sfirstorder use:HRed.preservation. - apply : Sub.transitive; eauto. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply /Sub.FromJoin /DJoin.FromRRed1. by apply HRed.ToRRed. - - move => a b b' nfa hr h ih j Γ A wta wtb. - apply : CLE_HRedR; eauto. - apply : ih; eauto; last by eauto using HRed.preservation. - apply : Sub.transitive; eauto. - hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. - apply /Sub.FromJoin /DJoin.FromRRed0. by apply HRed.ToRRed. -Qed. -Lemma coqleq_complete Γ (a b : PTm) : - Γ ⊢ a ≲ b -> a ≪ b. -Proof. - move => h. - have : salgo_dom_r a b /\ Sub.R a b by - hauto lq:on use:fundamental_theorem, logrel.SemLEq_SemWt, logrel.SemWt_SN, sn_algo_dom, algo_dom_salgo_dom. - hauto lq:on use:regularity, coqleq_complete'. -Qed. - -Lemma coqleq_sound : forall Γ (a b : PTm) i j, - Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv j -> a ≪ b -> Γ ⊢ a ≲ b. -Proof. - move => Γ a b i j. - have [*] : i <= i + j /\ j <= i + j by lia. - have : Γ ⊢ a ∈ PUniv (i + j) /\ Γ ⊢ b ∈ PUniv (i + j) - by sfirstorder use:T_Univ_Raise. - sfirstorder use:coqleq_sound_mutual. -Qed. diff --git a/theories/common.v b/theories/common.v deleted file mode 100644 index 35267fc..0000000 --- a/theories/common.v +++ /dev/null @@ -1,601 +0,0 @@ -Require Import Autosubst2.unscoped Autosubst2.syntax Autosubst2.core ssreflect ssrbool. -From Equations Require Import Equations. -Derive NoConfusion for nat PTag BTag PTm. -Derive EqDec for BTag PTag PTm. -From Ltac2 Require Ltac2. -Import Ltac2.Notations. -Import Ltac2.Control. -From Hammer Require Import Tactics. -From stdpp Require Import relations (rtc(..)). - -Inductive lookup : nat -> list PTm -> PTm -> Prop := -| here A Γ : lookup 0 (cons A Γ) (ren_PTm shift A) -| there i Γ A B : - lookup i Γ A -> - lookup (S i) (cons B Γ) (ren_PTm shift A). - -Lemma lookup_deter i Γ A B : - lookup i Γ A -> - lookup i Γ B -> - A = B. -Proof. move => h. move : B. induction h; hauto lq:on inv:lookup. Qed. - -Lemma here' A Γ U : U = ren_PTm shift A -> lookup 0 (A :: Γ) U. -Proof. move => ->. apply here. Qed. - -Lemma there' i Γ A B U : U = ren_PTm shift A -> lookup i Γ A -> - lookup (S i) (cons B Γ) U. -Proof. move => ->. apply there. Qed. - -Derive Inversion lookup_inv with (forall i Γ A, lookup i Γ A). - -Definition renaming_ok (Γ : list PTm) (Δ : list PTm) (ξ : nat -> nat) := - forall i A, lookup i Δ A -> lookup (ξ i) Γ (ren_PTm ξ A). - -Definition ren_inj (ξ : nat -> nat) := forall i j, ξ i = ξ j -> i = j. - -Lemma up_injective (ξ : nat -> nat) : - ren_inj ξ -> - ren_inj (upRen_PTm_PTm ξ). -Proof. - move => h i j. - case : i => //=; case : j => //=. - move => i j. rewrite /funcomp. hauto lq:on rew:off unfold:ren_inj. -Qed. - -Local Ltac2 rec solve_anti_ren () := - let x := Fresh.in_goal (Option.get (Ident.of_string "x")) in - intro $x; - lazy_match! Constr.type (Control.hyp x) with - | nat -> nat => (ltac1:(case => *//=; qauto l:on use:up_injective unfold:ren_inj)) - | _ => solve_anti_ren () - end. - -Local Ltac solve_anti_ren := ltac2:(Control.enter solve_anti_ren). - -Lemma ren_injective (a b : PTm) (ξ : nat -> nat) : - ren_inj ξ -> - ren_PTm ξ a = ren_PTm ξ b -> - a = b. -Proof. - move : ξ b. elim : a => //; try solve_anti_ren. - move => p ihp ξ []//=. hauto lq:on inv:PTm, nat ctrs:- use:up_injective. -Qed. - -Inductive HF : Set := -| H_Pair | H_Abs | H_Univ | H_Bind (p : BTag) | H_Nat | H_Suc | H_Zero | H_Bot. - -Definition ishf (a : PTm) := - match a with - | PPair _ _ => true - | PAbs _ => true - | PUniv _ => true - | PBind _ _ _ => true - | PNat => true - | PSuc _ => true - | PZero => true - | _ => false - end. - -Definition toHF (a : PTm) := - match a with - | PPair _ _ => H_Pair - | PAbs _ => H_Abs - | PUniv _ => H_Univ - | PBind p _ _ => H_Bind p - | PNat => H_Nat - | PSuc _ => H_Suc - | PZero => H_Zero - | _ => H_Bot - end. - -Fixpoint ishne (a : PTm) := - match a with - | VarPTm _ => true - | PApp a _ => ishne a - | PProj _ a => ishne a - | PInd _ n _ _ => ishne n - | _ => false - end. - -Definition isbind (a : PTm) := if a is PBind _ _ _ then true else false. - -Definition isuniv (a : PTm) := if a is PUniv _ then true else false. - -Definition ispair (a : PTm) := - match a with - | PPair _ _ => true - | _ => false - end. - -Definition isnat (a : PTm) := if a is PNat then true else false. - -Definition iszero (a : PTm) := if a is PZero then true else false. - -Definition issuc (a : PTm) := if a is PSuc _ then true else false. - -Definition isabs (a : PTm) := - match a with - | PAbs _ => true - | _ => false - end. - -Definition tm_nonconf (a b : PTm) : bool := - match a, b with - | PAbs _, _ => (~~ ishf b) || isabs b - | _, PAbs _ => ~~ ishf a - | VarPTm _, VarPTm _ => true - | PPair _ _, _ => (~~ ishf b) || ispair b - | _, PPair _ _ => ~~ ishf a - | PZero, PZero => true - | PSuc _, PSuc _ => true - | PApp _ _, PApp _ _ => true - | PProj _ _, PProj _ _ => true - | PInd _ _ _ _, PInd _ _ _ _ => true - | PNat, PNat => true - | PUniv _, PUniv _ => true - | PBind _ _ _, PBind _ _ _ => true - | _,_=> false - end. - -Definition tm_conf (a b : PTm) := ~~ tm_nonconf a b. - -Definition ishf_ren (a : PTm) (ξ : nat -> nat) : - ishf (ren_PTm ξ a) = ishf a. -Proof. case : a => //=. Qed. - -Definition isabs_ren (a : PTm) (ξ : nat -> nat) : - isabs (ren_PTm ξ a) = isabs a. -Proof. case : a => //=. Qed. - -Definition ispair_ren (a : PTm) (ξ : nat -> nat) : - ispair (ren_PTm ξ a) = ispair a. -Proof. case : a => //=. Qed. - -Definition ishne_ren (a : PTm) (ξ : nat -> nat) : - ishne (ren_PTm ξ a) = ishne a. -Proof. move : ξ. elim : a => //=. Qed. - -Lemma renaming_shift Γ A : - renaming_ok (cons A Γ) Γ shift. -Proof. rewrite /renaming_ok. hauto lq:on ctrs:lookup. Qed. - -Lemma subst_scons_id (a : PTm) : - subst_PTm (scons (VarPTm 0) (funcomp VarPTm shift)) a = a. -Proof. - have E : subst_PTm VarPTm a = a by asimpl. - rewrite -{2}E. - apply ext_PTm. case => //=. -Qed. - -Module HRed. - Inductive R : PTm -> PTm -> Prop := - (****************** Beta ***********************) - | AppAbs a b : - R (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) - - | ProjPair p a b : - R (PProj p (PPair a b)) (if p is PL then a else b) - - | IndZero P b c : - R (PInd P PZero b c) b - - | IndSuc P a b c : - R (PInd P (PSuc a) b c) (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) - - (*************** Congruence ********************) - | AppCong a0 a1 b : - R a0 a1 -> - R (PApp a0 b) (PApp a1 b) - | ProjCong p a0 a1 : - R a0 a1 -> - R (PProj p a0) (PProj p a1) - | IndCong P a0 a1 b c : - R a0 a1 -> - R (PInd P a0 b c) (PInd P a1 b c). - - Definition nf a := forall b, ~ R a b. -End HRed. - -Inductive algo_dom : PTm -> PTm -> Prop := -| A_AbsAbs a b : - algo_dom_r a b -> - (* --------------------- *) - algo_dom (PAbs a) (PAbs b) - -| A_AbsNeu a u : - ishne u -> - algo_dom_r a (PApp (ren_PTm shift u) (VarPTm var_zero)) -> - (* --------------------- *) - algo_dom (PAbs a) u - -| A_NeuAbs a u : - ishne u -> - algo_dom_r (PApp (ren_PTm shift u) (VarPTm var_zero)) a -> - (* --------------------- *) - algo_dom u (PAbs a) - -| A_PairPair a0 a1 b0 b1 : - algo_dom_r a0 a1 -> - algo_dom_r b0 b1 -> - (* ---------------------------- *) - algo_dom (PPair a0 b0) (PPair a1 b1) - -| A_PairNeu a0 a1 u : - ishne u -> - algo_dom_r a0 (PProj PL u) -> - algo_dom_r a1 (PProj PR u) -> - (* ----------------------- *) - algo_dom (PPair a0 a1) u - -| A_NeuPair a0 a1 u : - ishne u -> - algo_dom_r (PProj PL u) a0 -> - algo_dom_r (PProj PR u) a1 -> - (* ----------------------- *) - algo_dom u (PPair a0 a1) - -| A_ZeroZero : - algo_dom PZero PZero - -| A_SucSuc a0 a1 : - algo_dom_r a0 a1 -> - algo_dom (PSuc a0) (PSuc a1) - -| A_UnivCong i j : - (* -------------------------- *) - algo_dom (PUniv i) (PUniv j) - -| A_BindCong p0 p1 A0 A1 B0 B1 : - algo_dom_r A0 A1 -> - algo_dom_r B0 B1 -> - (* ---------------------------- *) - algo_dom (PBind p0 A0 B0) (PBind p1 A1 B1) - -| A_NatCong : - algo_dom PNat PNat - -| A_VarCong i j : - (* -------------------------- *) - algo_dom (VarPTm i) (VarPTm j) - -| A_AppCong u0 u1 a0 a1 : - ishne u0 -> - ishne u1 -> - algo_dom u0 u1 -> - algo_dom_r a0 a1 -> - (* ------------------------- *) - algo_dom (PApp u0 a0) (PApp u1 a1) - -| A_ProjCong p0 p1 u0 u1 : - ishne u0 -> - ishne u1 -> - algo_dom u0 u1 -> - (* --------------------- *) - algo_dom (PProj p0 u0) (PProj p1 u1) - -| A_IndCong P0 P1 u0 u1 b0 b1 c0 c1 : - ishne u0 -> - ishne u1 -> - algo_dom_r P0 P1 -> - algo_dom u0 u1 -> - algo_dom_r b0 b1 -> - algo_dom_r c0 c1 -> - algo_dom (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) - -| A_Conf a b : - ishf a \/ ishne a -> - ishf b \/ ishne b -> - tm_conf a b -> - algo_dom a b - -with algo_dom_r : PTm -> PTm -> Prop := -| A_NfNf a b : - algo_dom a b -> - algo_dom_r a b - -| A_HRedL a a' b : - HRed.R a a' -> - algo_dom_r a' b -> - (* ----------------------- *) - algo_dom_r a b - -| A_HRedR a b b' : - HRed.nf a -> - HRed.R b b' -> - algo_dom_r a b' -> - (* ----------------------- *) - algo_dom_r a b. - -Scheme algo_ind := Induction for algo_dom Sort Prop - with algor_ind := Induction for algo_dom_r Sort Prop. - -Combined Scheme algo_dom_mutual from algo_ind, algor_ind. -#[export]Hint Constructors algo_dom algo_dom_r : adom. - -Definition stm_nonconf a b := - match a, b with - | PUniv _, PUniv _ => true - | PBind PPi _ _, PBind PPi _ _ => true - | PBind PSig _ _, PBind PSig _ _ => true - | PNat, PNat => true - | VarPTm _, VarPTm _ => true - | PApp _ _, PApp _ _ => true - | PProj _ _, PProj _ _ => true - | PInd _ _ _ _, PInd _ _ _ _ => true - | _, _ => false - end. - -Definition neuneu_nonconf a b := - match a, b with - | VarPTm _, VarPTm _ => true - | PApp _ _, PApp _ _ => true - | PProj _ _, PProj _ _ => true - | PInd _ _ _ _, PInd _ _ _ _ => true - | _, _ => false - end. - -Lemma stm_tm_nonconf a b : - stm_nonconf a b -> tm_nonconf a b. -Proof. apply /implyP. - destruct a ,b =>//=; hauto lq:on inv:PTag, BTag. -Qed. - -Definition stm_conf a b := ~~ stm_nonconf a b. - -Lemma tm_stm_conf a b : - tm_conf a b -> stm_conf a b. -Proof. - rewrite /tm_conf /stm_conf. - apply /contra /stm_tm_nonconf. -Qed. - -Inductive salgo_dom : PTm -> PTm -> Prop := -| S_UnivCong i j : - (* -------------------------- *) - salgo_dom (PUniv i) (PUniv j) - -| S_PiCong A0 A1 B0 B1 : - salgo_dom_r A1 A0 -> - salgo_dom_r B0 B1 -> - (* ---------------------------- *) - salgo_dom (PBind PPi A0 B0) (PBind PPi A1 B1) - -| S_SigCong A0 A1 B0 B1 : - salgo_dom_r A0 A1 -> - salgo_dom_r B0 B1 -> - (* ---------------------------- *) - salgo_dom (PBind PSig A0 B0) (PBind PSig A1 B1) - -| S_NatCong : - salgo_dom PNat PNat - -| S_NeuNeu a b : - neuneu_nonconf a b -> - algo_dom a b -> - salgo_dom a b - -| S_Conf a b : - ishf a \/ ishne a -> - ishf b \/ ishne b -> - stm_conf a b -> - salgo_dom a b - -with salgo_dom_r : PTm -> PTm -> Prop := -| S_NfNf a b : - salgo_dom a b -> - salgo_dom_r a b - -| S_HRedL a a' b : - HRed.R a a' -> - salgo_dom_r a' b -> - (* ----------------------- *) - salgo_dom_r a b - -| S_HRedR a b b' : - HRed.nf a -> - HRed.R b b' -> - salgo_dom_r a b' -> - (* ----------------------- *) - salgo_dom_r a b. - -#[export]Hint Constructors salgo_dom salgo_dom_r : sdom. -Scheme salgo_ind := Induction for salgo_dom Sort Prop - with salgor_ind := Induction for salgo_dom_r Sort Prop. - -Combined Scheme salgo_dom_mutual from salgo_ind, salgor_ind. - -Lemma hf_no_hred (a b : PTm) : - ishf a -> - HRed.R a b -> - False. -Proof. hauto l:on inv:HRed.R. Qed. - -Lemma hne_no_hred (a b : PTm) : - ishne a -> - HRed.R a b -> - False. -Proof. elim : a b => //=; hauto l:on inv:HRed.R. Qed. - -Ltac2 destruct_salgo () := - lazy_match! goal with - | [_ : is_true (ishne ?a) |- is_true (stm_conf ?a _) ] => - if Constr.is_var a then destruct $a; ltac1:(done) else () - | [|- is_true (stm_conf _ _)] => - unfold stm_conf; ltac1:(done) - end. - -Ltac destruct_salgo := ltac2:(destruct_salgo ()). - -Lemma algo_dom_r_inv a b : - algo_dom_r a b -> exists a0 b0, algo_dom a0 b0 /\ rtc HRed.R a a0 /\ rtc HRed.R b b0. -Proof. - induction 1; hauto lq:on ctrs:rtc. -Qed. - -Lemma A_HRedsL a a' b : - rtc HRed.R a a' -> - algo_dom_r a' b -> - algo_dom_r a b. - induction 1; sfirstorder use:A_HRedL. -Qed. - -Lemma A_HRedsR a b b' : - HRed.nf a -> - rtc HRed.R b b' -> - algo_dom a b' -> - algo_dom_r a b. -Proof. induction 2; sauto. Qed. - -Lemma tm_conf_sym a b : tm_conf a b = tm_conf b a. -Proof. case : a; case : b => //=. Qed. - -Lemma algo_dom_no_hred (a b : PTm) : - algo_dom a b -> - HRed.nf a /\ HRed.nf b. -Proof. - induction 1 =>//=; try hauto inv:HRed.R use:hne_no_hred, hf_no_hred lq:on unfold:HRed.nf. -Qed. - - -Lemma A_HRedR' a b b' : - HRed.R b b' -> - algo_dom_r a b' -> - algo_dom_r a b. -Proof. - move => hb /algo_dom_r_inv. - move => [a0 [b0 [h0 [h1 h2]]]]. - have {h2} {}hb : rtc HRed.R b b0 by hauto lq:on ctrs:rtc. - have ? : HRed.nf a0 by sfirstorder use:algo_dom_no_hred. - hauto lq:on use:A_HRedsL, A_HRedsR. -Qed. - -Lemma algo_dom_sym : - (forall a b (h : algo_dom a b), algo_dom b a) /\ - (forall a b (h : algo_dom_r a b), algo_dom_r b a). -Proof. - apply algo_dom_mutual; try qauto use:tm_conf_sym,A_HRedR' db:adom. -Qed. - -Lemma salgo_dom_r_inv a b : - salgo_dom_r a b -> exists a0 b0, salgo_dom a0 b0 /\ rtc HRed.R a a0 /\ rtc HRed.R b b0. -Proof. - induction 1; hauto lq:on ctrs:rtc. -Qed. - -Lemma S_HRedsL a a' b : - rtc HRed.R a a' -> - salgo_dom_r a' b -> - salgo_dom_r a b. - induction 1; sfirstorder use:S_HRedL. -Qed. - -Lemma S_HRedsR a b b' : - HRed.nf a -> - rtc HRed.R b b' -> - salgo_dom a b' -> - salgo_dom_r a b. -Proof. induction 2; sauto. Qed. - -Lemma stm_conf_sym a b : stm_conf a b = stm_conf b a. -Proof. case : a; case : b => //=; hauto lq:on inv:PTag, BTag. Qed. - -Lemma salgo_dom_no_hred (a b : PTm) : - salgo_dom a b -> - HRed.nf a /\ HRed.nf b. -Proof. - induction 1 =>//=; try hauto inv:HRed.R use:hne_no_hred, hf_no_hred, algo_dom_no_hred lq:on unfold:HRed.nf. -Qed. - -Lemma S_HRedR' a b b' : - HRed.R b b' -> - salgo_dom_r a b' -> - salgo_dom_r a b. -Proof. - move => hb /salgo_dom_r_inv. - move => [a0 [b0 [h0 [h1 h2]]]]. - have {h2} {}hb : rtc HRed.R b b0 by hauto lq:on ctrs:rtc. - have ? : HRed.nf a0 by sfirstorder use:salgo_dom_no_hred. - hauto lq:on use:S_HRedsL, S_HRedsR. -Qed. - -Ltac solve_conf := intros; split; - apply S_Conf; solve [destruct_salgo | sfirstorder ctrs:salgo_dom use:hne_no_hred, hf_no_hred]. - -Ltac solve_basic := hauto q:on ctrs:salgo_dom, salgo_dom_r, algo_dom use:algo_dom_sym. - -Lemma algo_dom_salgo_dom : - (forall a b, algo_dom a b -> salgo_dom a b /\ salgo_dom b a) /\ - (forall a b, algo_dom_r a b -> salgo_dom_r a b /\ salgo_dom_r b a). -Proof. - apply algo_dom_mutual => //=; try first [solve_conf | solve_basic]. - - case; case; hauto lq:on ctrs:salgo_dom use:algo_dom_sym inv:HRed.R unfold:HRed.nf. - - move => a b ha hb hc. split; - apply S_Conf; hauto l:on use:tm_conf_sym, tm_stm_conf. - - hauto lq:on ctrs:salgo_dom_r use:S_HRedR'. -Qed. - -Fixpoint hred (a : PTm) : option (PTm) := - match a with - | VarPTm i => None - | PAbs a => None - | PApp (PAbs a) b => Some (subst_PTm (scons b VarPTm) a) - | PApp a b => - match hred a with - | Some a => Some (PApp a b) - | None => None - end - | PPair a b => None - | PProj p (PPair a b) => if p is PL then Some a else Some b - | PProj p a => - match hred a with - | Some a => Some (PProj p a) - | None => None - end - | PUniv i => None - | PBind p A B => None - | PNat => None - | PZero => None - | PSuc a => None - | PInd P PZero b c => Some b - | PInd P (PSuc a) b c => - Some (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) - | PInd P a b c => - match hred a with - | Some a => Some (PInd P a b c) - | None => None - end - end. - -Lemma hred_complete (a b : PTm) : - HRed.R a b -> hred a = Some b. -Proof. - induction 1; hauto lq:on rew:off inv:HRed.R b:on. -Qed. - -Lemma hred_sound (a b : PTm): - hred a = Some b -> HRed.R a b. -Proof. - elim : a b; hauto q:on dep:on ctrs:HRed.R. -Qed. - -Lemma hred_deter (a b0 b1 : PTm) : - HRed.R a b0 -> HRed.R a b1 -> b0 = b1. -Proof. - move /hred_complete => + /hred_complete. congruence. -Qed. - -Definition fancy_hred (a : PTm) : HRed.nf a + {b | HRed.R a b}. - destruct (hred a) eqn:eq. - right. exists p. by apply hred_sound in eq. - left. move => b /hred_complete. congruence. -Defined. - -Lemma hreds_nf_refl a b : - HRed.nf a -> - rtc HRed.R a b -> - a = b. -Proof. inversion 2; sfirstorder. Qed. - -Lemma algo_dom_r_algo_dom : forall a b, HRed.nf a -> HRed.nf b -> algo_dom_r a b -> algo_dom a b. -Proof. hauto l:on use:algo_dom_r_inv, hreds_nf_refl. Qed. diff --git a/theories/executable.v b/theories/executable.v deleted file mode 100644 index 558aa75..0000000 --- a/theories/executable.v +++ /dev/null @@ -1,350 +0,0 @@ -From Equations Require Import Equations. -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. -Require Import Logic.PropExtensionality (propositional_extensionality). -Require Import ssreflect ssrbool. -Import Logic (inspect). -From Ltac2 Require Import Ltac2. -Import Ltac2.Constr. -Set Default Proof Mode "Classic". - - -Require Import ssreflect ssrbool. -From Hammer Require Import Tactics. - -Ltac2 destruct_algo () := - lazy_match! goal with - | [h : algo_dom ?a ?b |- _ ] => - if is_var a then destruct $a; ltac1:(done) else - (if is_var b then destruct $b; ltac1:(done) else ()) - end. - - -Ltac check_equal_triv := - intros;subst; - lazymatch goal with - (* | [h : algo_dom (VarPTm _) (PAbs _) |- _] => idtac *) - | [h : algo_dom _ _ |- _] => try (inversion h; subst => //=; ltac2:(Control.enter destruct_algo)) - | _ => idtac - end. - -Ltac solve_check_equal := - try solve [intros *; - match goal with - | [|- _ = _] => sauto - | _ => idtac - end]. - -Global Set Transparent Obligations. - -Local Obligation Tactic := try solve [check_equal_triv | sfirstorder]. - -Program Fixpoint check_equal (a b : PTm) (h : algo_dom a b) {struct h} : bool := - match a, b with - | VarPTm i, VarPTm j => nat_eqdec i j - | PAbs a, PAbs b => check_equal_r a b _ - | PAbs a, VarPTm _ => check_equal_r a (PApp (ren_PTm shift b) (VarPTm var_zero)) _ - | PAbs a, PApp _ _ => check_equal_r a (PApp (ren_PTm shift b) (VarPTm var_zero)) _ - | PAbs a, PInd _ _ _ _ => check_equal_r a (PApp (ren_PTm shift b) (VarPTm var_zero)) _ - | PAbs a, PProj _ _ => check_equal_r a (PApp (ren_PTm shift b) (VarPTm var_zero)) _ - | VarPTm _, PAbs b => check_equal_r (PApp (ren_PTm shift a) (VarPTm var_zero)) b _ - | PApp _ _, PAbs b => check_equal_r (PApp (ren_PTm shift a) (VarPTm var_zero)) b _ - | PProj _ _, PAbs b => check_equal_r (PApp (ren_PTm shift a) (VarPTm var_zero)) b _ - | PInd _ _ _ _, PAbs b => check_equal_r (PApp (ren_PTm shift a) (VarPTm var_zero)) b _ - | PPair a0 b0, PPair a1 b1 => - check_equal_r a0 a1 _ && check_equal_r b0 b1 _ - | PPair a0 b0, VarPTm _ => check_equal_r a0 (PProj PL b) _ && check_equal_r b0 (PProj PR b) _ - | PPair a0 b0, PProj _ _ => check_equal_r a0 (PProj PL b) _ && check_equal_r b0 (PProj PR b) _ - | PPair a0 b0, PApp _ _ => check_equal_r a0 (PProj PL b) _ && check_equal_r b0 (PProj PR b) _ - | PPair a0 b0, PInd _ _ _ _ => check_equal_r a0 (PProj PL b) _ && check_equal_r b0 (PProj PR b) _ - | VarPTm _, PPair a1 b1 => check_equal_r (PProj PL a) a1 _ && check_equal_r (PProj PR a) b1 _ - | PApp _ _, PPair a1 b1 => check_equal_r (PProj PL a) a1 _ && check_equal_r (PProj PR a) b1 _ - | PProj _ _, PPair a1 b1 => check_equal_r (PProj PL a) a1 _ && check_equal_r (PProj PR a) b1 _ - | PInd _ _ _ _, PPair a1 b1 => check_equal_r (PProj PL a) a1 _ && check_equal_r (PProj PR a) b1 _ - | PNat, PNat => true - | PZero, PZero => true - | PSuc a, PSuc b => check_equal_r a b _ - | PProj p0 a, PProj p1 b => PTag_eqdec p0 p1 && check_equal a b _ - | PApp a0 b0, PApp a1 b1 => check_equal a0 a1 _ && check_equal_r b0 b1 _ - | PInd P0 u0 b0 c0, PInd P1 u1 b1 c1 => - check_equal_r P0 P1 _ && check_equal u0 u1 _ && check_equal_r b0 b1 _ && check_equal_r c0 c1 _ - | PUniv i, PUniv j => nat_eqdec i j - | PBind p0 A0 B0, PBind p1 A1 B1 => BTag_eqdec p0 p1 && check_equal_r A0 A1 _ && check_equal_r B0 B1 _ - | _, _ => false - end -with check_equal_r (a b : PTm) (h : algo_dom_r a b) {struct h} : bool := - match fancy_hred a with - | inr a' => check_equal_r (proj1_sig a') b _ - | inl ha' => match fancy_hred b with - | inr b' => check_equal_r a (proj1_sig b') _ - | inl hb' => check_equal a b _ - end - end. - -Next Obligation. - simpl. intros. clear Heq_anonymous. destruct a' as [a' ha']. simpl. - inversion h; subst => //=. - exfalso. sfirstorder use:algo_dom_no_hred. - assert (a' = a'0) by eauto using hred_deter. by subst. - exfalso. sfirstorder. -Defined. - -Next Obligation. - simpl. intros. clear Heq_anonymous Heq_anonymous0. - destruct b' as [b' hb']. simpl. - inversion h; subst. - - exfalso. - sfirstorder use:algo_dom_no_hred. - - exfalso. - sfirstorder. - - assert (b' = b'0) by eauto using hred_deter. by subst. -Defined. - -(* Need to avoid ssreflect tactics since they generate terms that make the termination checker upset *) -Next Obligation. - move => /= a b hdom ha _ hb _. - inversion hdom; subst. - - assumption. - - exfalso; sfirstorder. - - exfalso; sfirstorder. -Defined. - -Lemma check_equal_abs_abs a b h : check_equal (PAbs a) (PAbs b) (A_AbsAbs a b h) = check_equal_r a b h. -Proof. reflexivity. Qed. - -Lemma check_equal_abs_neu a u neu h : check_equal (PAbs a) u (A_AbsNeu a u neu h) = check_equal_r a (PApp (ren_PTm shift u) (VarPTm var_zero)) h. -Proof. case : u neu h => //=. Qed. - -Lemma check_equal_neu_abs a u neu h : check_equal u (PAbs a) (A_NeuAbs a u neu h) = check_equal_r (PApp (ren_PTm shift u) (VarPTm var_zero)) a h. -Proof. case : u neu h => //=. Qed. - -Lemma check_equal_pair_pair a0 b0 a1 b1 a h : - check_equal (PPair a0 b0) (PPair a1 b1) (A_PairPair a0 a1 b0 b1 a h) = - check_equal_r a0 a1 a && check_equal_r b0 b1 h. -Proof. reflexivity. Qed. - -Lemma check_equal_pair_neu a0 a1 u neu h h' - : check_equal (PPair a0 a1) u (A_PairNeu a0 a1 u neu h h') = check_equal_r a0 (PProj PL u) h && check_equal_r a1 (PProj PR u) h'. -Proof. - case : u neu h h' => //=. -Qed. - -Lemma check_equal_neu_pair a0 a1 u neu h h' - : check_equal u (PPair a0 a1) (A_NeuPair a0 a1 u neu h h') = check_equal_r (PProj PL u) a0 h && check_equal_r (PProj PR u) a1 h'. -Proof. - case : u neu h h' => //=. -Qed. - -Lemma check_equal_bind_bind p0 A0 B0 p1 A1 B1 h0 h1 : - check_equal (PBind p0 A0 B0) (PBind p1 A1 B1) (A_BindCong p0 p1 A0 A1 B0 B1 h0 h1) = - BTag_eqdec p0 p1 && check_equal_r A0 A1 h0 && check_equal_r B0 B1 h1. -Proof. reflexivity. Qed. - -Lemma check_equal_proj_proj p0 u0 p1 u1 neu0 neu1 h : - check_equal (PProj p0 u0) (PProj p1 u1) (A_ProjCong p0 p1 u0 u1 neu0 neu1 h) = - PTag_eqdec p0 p1 && check_equal u0 u1 h. -Proof. reflexivity. Qed. - -Lemma check_equal_app_app u0 a0 u1 a1 hu0 hu1 hdom hdom' : - check_equal (PApp u0 a0) (PApp u1 a1) (A_AppCong u0 u1 a0 a1 hu0 hu1 hdom hdom') = - check_equal u0 u1 hdom && check_equal_r a0 a1 hdom'. -Proof. reflexivity. Qed. - -Lemma check_equal_ind_ind P0 u0 b0 c0 P1 u1 b1 c1 neu0 neu1 domP domu domb domc : - check_equal (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) - (A_IndCong P0 P1 u0 u1 b0 b1 c0 c1 neu0 neu1 domP domu domb domc) = - check_equal_r P0 P1 domP && check_equal u0 u1 domu && check_equal_r b0 b1 domb && check_equal_r c0 c1 domc. -Proof. reflexivity. Qed. - -Lemma hred_none a : HRed.nf a -> hred a = None. -Proof. - destruct (hred a) eqn:eq; - sfirstorder use:hred_complete, hred_sound. -Qed. - -Ltac simp_check_r := with_strategy opaque [check_equal] simpl in *. - -Lemma check_equal_nfnf a b dom : check_equal_r a b (A_NfNf a b dom) = check_equal a b dom. -Proof. - have [h0 h1] : HRed.nf a /\ HRed.nf b by hauto l:on use:algo_dom_no_hred. - have [h3 h4] : hred a = None /\ hred b = None by sfirstorder use:hf_no_hred, hne_no_hred, hred_none. - simp_check_r. - destruct (fancy_hred a). - destruct (fancy_hred b). - reflexivity. - exfalso. hauto l:on use:hred_complete. - exfalso. hauto l:on use:hred_complete. -Qed. - -Lemma check_equal_hredl a b a' ha doma : - check_equal_r a b (A_HRedL a a' b ha doma) = check_equal_r a' b doma. -Proof. - simpl. - destruct (fancy_hred a). - - hauto q:on unfold:HRed.nf. - - destruct s as [x ?]. - have ? : x = a' by eauto using hred_deter. subst. - simpl. - f_equal. - apply PropExtensionality.proof_irrelevance. -Qed. - -Lemma check_equal_hredr a b b' hu r a0 : - check_equal_r a b (A_HRedR a b b' hu r a0) = - check_equal_r a b' a0. -Proof. - simpl. - destruct (fancy_hred a). - - simpl. - destruct (fancy_hred b) as [|[b'' hb']]. - + hauto lq:on unfold:HRed.nf. - + simpl. - have ? : (b'' = b') by eauto using hred_deter. subst. - f_equal. - apply PropExtensionality.proof_irrelevance. - - exfalso. - sfirstorder use:hne_no_hred, hf_no_hred. -Qed. - -Lemma check_equal_univ i j : - check_equal (PUniv i) (PUniv j) (A_UnivCong i j) = nat_eqdec i j. -Proof. reflexivity. Qed. - -Lemma check_equal_conf a b nfa nfb nfab : - check_equal a b (A_Conf a b nfa nfb nfab) = false. -Proof. destruct a; destruct b => //=. Qed. - -#[export]Hint Rewrite check_equal_abs_abs check_equal_abs_neu check_equal_neu_abs check_equal_pair_pair check_equal_pair_neu check_equal_neu_pair check_equal_bind_bind check_equal_hredl check_equal_hredr check_equal_nfnf check_equal_conf : ce_prop. - -Ltac2 destruct_salgo () := - lazy_match! goal with - | [h : salgo_dom ?a ?b |- _ ] => - if is_var a then destruct $a; ltac1:(done) else - (if is_var b then destruct $b; ltac1:(done) else ()) - end. - -Ltac check_sub_triv := - intros;subst; - lazymatch goal with - (* | [h : algo_dom (VarPTm _) (PAbs _) |- _] => idtac *) - | [_ : salgo_dom _ _ |- _] => try (inversion h; subst => //=; ltac2:(Control.enter destruct_algo)) - | _ => idtac - end. - -Local Obligation Tactic := try solve [check_sub_triv | sfirstorder]. - -Program Fixpoint check_sub (a b : PTm) (h : salgo_dom a b) {struct h} := - match a, b with - | PBind PPi A0 B0, PBind PPi A1 B1 => - check_sub_r A1 A0 _ && check_sub_r B0 B1 _ - | PBind PSig A0 B0, PBind PSig A1 B1 => - check_sub_r A0 A1 _ && check_sub_r B0 B1 _ - | PUniv i, PUniv j => - PeanoNat.Nat.leb i j - | PNat, PNat => true - | PApp _ _ , PApp _ _ => check_equal a b _ - | VarPTm _, VarPTm _ => check_equal a b _ - | PInd _ _ _ _, PInd _ _ _ _ => check_equal a b _ - | PProj _ _, PProj _ _ => check_equal a b _ - | _, _ => false - end -with check_sub_r (a b : PTm) (h : salgo_dom_r a b) {struct h} := - match fancy_hred a with - | inr a' => check_sub_r (proj1_sig a') b _ - | inl ha' => match fancy_hred b with - | inr b' => check_sub_r a (proj1_sig b') _ - | inl hb' => check_sub a b _ - end - end. - -Next Obligation. - simpl. intros. clear Heq_anonymous. destruct a' as [a' ha']. simpl. - inversion h; subst => //=. - exfalso. sfirstorder use:salgo_dom_no_hred. - assert (a' = a'0) by eauto using hred_deter. by subst. - exfalso. sfirstorder. -Defined. - -Next Obligation. - simpl. intros. clear Heq_anonymous Heq_anonymous0. - destruct b' as [b' hb']. simpl. - inversion h; subst. - - exfalso. - sfirstorder use:salgo_dom_no_hred. - - exfalso. - sfirstorder. - - assert (b' = b'0) by eauto using hred_deter. by subst. -Defined. - -(* Need to avoid ssreflect tactics since they generate terms that make the termination checker upset *) -Next Obligation. - move => /= a b hdom ha _ hb _. - inversion hdom; subst. - - assumption. - - exfalso; sfirstorder. - - exfalso; sfirstorder. -Defined. - -Lemma check_sub_pi_pi A0 B0 A1 B1 h0 h1 : - check_sub (PBind PPi A0 B0) (PBind PPi A1 B1) (S_PiCong A0 A1 B0 B1 h0 h1) = - check_sub_r A1 A0 h0 && check_sub_r B0 B1 h1. -Proof. reflexivity. Qed. - -Lemma check_sub_sig_sig A0 B0 A1 B1 h0 h1 : - check_sub (PBind PSig A0 B0) (PBind PSig A1 B1) (S_SigCong A0 A1 B0 B1 h0 h1) = - check_sub_r A0 A1 h0 && check_sub_r B0 B1 h1. -Proof. reflexivity. Qed. - -Lemma check_sub_univ_univ i j : - check_sub (PUniv i) (PUniv j) (S_UnivCong i j) = PeanoNat.Nat.leb i j. -Proof. reflexivity. Qed. - -Lemma check_sub_nfnf a b dom : check_sub_r a b (S_NfNf a b dom) = check_sub a b dom. -Proof. - have [h0 h1] : HRed.nf a /\ HRed.nf b by hauto l:on use:salgo_dom_no_hred. - have [h3 h4] : hred a = None /\ hred b = None by sfirstorder use:hf_no_hred, hne_no_hred, hred_none. - simpl. - destruct (fancy_hred b)=>//=. - destruct (fancy_hred a) =>//=. - destruct s as [a' ha']. simpl. - hauto l:on use:hred_complete. - destruct s as [b' hb']. simpl. - hauto l:on use:hred_complete. -Qed. - -Lemma check_sub_hredl a b a' ha doma : - check_sub_r a b (S_HRedL a a' b ha doma) = check_sub_r a' b doma. -Proof. - simpl. - destruct (fancy_hred a). - - hauto q:on unfold:HRed.nf. - - destruct s as [x ?]. - have ? : x = a' by eauto using hred_deter. subst. - simpl. - f_equal. - apply PropExtensionality.proof_irrelevance. -Qed. - -Lemma check_sub_hredr a b b' hu r a0 : - check_sub_r a b (S_HRedR a b b' hu r a0) = - check_sub_r a b' a0. -Proof. - simpl. - destruct (fancy_hred a). - - simpl. - destruct (fancy_hred b) as [|[b'' hb']]. - + hauto lq:on unfold:HRed.nf. - + simpl. - have ? : (b'' = b') by eauto using hred_deter. subst. - f_equal. - apply PropExtensionality.proof_irrelevance. - - exfalso. - sfirstorder use:hne_no_hred, hf_no_hred. -Qed. - -Lemma check_sub_neuneu a b i a0 : check_sub a b (S_NeuNeu a b i a0) = check_equal a b a0. -Proof. destruct a,b => //=. Qed. - -Lemma check_sub_conf a b n n0 i : check_sub a b (S_Conf a b n n0 i) = false. -Proof. destruct a,b=>//=; ecrush inv:BTag. Qed. - -#[export]Hint Rewrite check_sub_neuneu check_sub_conf check_sub_hredl check_sub_hredr check_sub_nfnf check_sub_univ_univ check_sub_pi_pi check_sub_sig_sig : ce_prop. diff --git a/theories/executable_correct.v b/theories/executable_correct.v deleted file mode 100644 index 40debce..0000000 --- a/theories/executable_correct.v +++ /dev/null @@ -1,259 +0,0 @@ -From Equations Require Import Equations. -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common executable algorithmic. -Require Import ssreflect ssrbool. -From stdpp Require Import relations (rtc(..)). -From Hammer Require Import Tactics. - -Lemma coqeqr_no_hred a b : a ∼ b -> HRed.nf a /\ HRed.nf b. -Proof. induction 1; sauto lq:on unfold:HRed.nf. Qed. - -Lemma coqeq_no_hred a b : a ↔ b -> HRed.nf a /\ HRed.nf b. -Proof. induction 1; - qauto inv:HRed.R use:coqeqr_no_hred, hne_no_hred unfold:HRed.nf. -Qed. - -Lemma coqleq_no_hred a b : a ⋖ b -> HRed.nf a /\ HRed.nf b. -Proof. - induction 1; qauto inv:HRed.R use:coqeqr_no_hred, hne_no_hred, coqeqr_no_hred unfold:HRed.nf. -Qed. - -Lemma coqeq_neuneu u0 u1 : - ishne u0 -> ishne u1 -> u0 ↔ u1 -> u0 ∼ u1. -Proof. - inversion 3; subst => //=. -Qed. - -Lemma coqeq_neuneu' u0 u1 : - neuneu_nonconf u0 u1 -> - u0 ↔ u1 -> - u0 ∼ u1. -Proof. - induction 2 => //=; destruct u => //=. -Qed. - -Lemma check_equal_sound : - (forall a b (h : algo_dom a b), check_equal a b h -> a ↔ b) /\ - (forall a b (h : algo_dom_r a b), check_equal_r a b h -> a ⇔ b). -Proof. - apply algo_dom_mutual. - - move => a b h. - move => h0. - rewrite check_equal_abs_abs. - constructor. tauto. - - move => a u i h0 ih h. - apply CE_AbsNeu => //. - apply : ih. simp check_equal tm_to_eq_view in h. - by rewrite check_equal_abs_neu in h. - - move => a u i h ih h0. - apply CE_NeuAbs=>//. - apply ih. - by rewrite check_equal_neu_abs in h0. - - move => a0 a1 b0 b1 a ha h. - move => h0. - rewrite check_equal_pair_pair. move /andP => [h1 h2]. - sauto lq:on. - - move => a0 a1 u neu h ih h' ih' he. - rewrite check_equal_pair_neu in he. - apply CE_PairNeu => //; hauto lqb:on. - - move => a0 a1 u i a ha a2 hb. - rewrite check_equal_neu_pair => *. - apply CE_NeuPair => //; hauto lqb:on. - - sfirstorder. - - hauto l:on use:CE_SucSuc. - - move => i j /sumboolP. - hauto lq:on use:CE_UnivCong. - - move => p0 p1 A0 A1 B0 B1 h0 ih0 h1 ih1 h2. - rewrite check_equal_bind_bind in h2. - move : h2. - move /andP => [/andP [h20 h21] h3]. - move /sumboolP : h20 => ?. subst. - hauto l:on use:CE_BindCong. - - sfirstorder. - - move => i j /sumboolP ?. subst. - apply : CE_NeuNeu. apply CE_VarCong. - - move => u0 u1 a0 a1 hu0 hu1 hdom ih hdom' ih' hE. - rewrite check_equal_app_app in hE. - move /andP : hE => [h0 h1]. - sauto lq:on use:coqeq_neuneu. - - move => p0 p1 u0 u1 neu0 neu1 h ih he. - apply CE_NeuNeu. - rewrite check_equal_proj_proj in he. - move /andP : he => [/sumboolP ? h1]. subst. - sauto lq:on use:coqeq_neuneu. - - move => P0 P1 u0 u1 b0 b1 c0 c1 neu0 neu1 domP ihP domu ihu domb ihb domc ihc. - rewrite check_equal_ind_ind. - move /andP => [/andP [/andP [h0 h1] h2 ] h3]. - sauto lq:on use:coqeq_neuneu. - - move => a b n n0 i. by rewrite check_equal_conf. - - move => a b dom h ih. apply : CE_HRed; eauto using rtc_refl. - rewrite check_equal_nfnf in ih. - tauto. - - move => a a' b ha doma ih hE. - rewrite check_equal_hredl in hE. sauto lq:on. - - move => a b b' hu r a0 ha hb. rewrite check_equal_hredr in hb. - sauto lq:on rew:off. -Qed. - -Ltac ce_solv := move => *; simp ce_prop in *; hauto qb:on rew:off inv:CoqEq, CoqEq_Neu. - -Lemma check_equal_complete : - (forall a b (h : algo_dom a b), ~ check_equal a b h -> ~ a ↔ b) /\ - (forall a b (h : algo_dom_r a b), ~ check_equal_r a b h -> ~ a ⇔ b). -Proof. - apply algo_dom_mutual. - - ce_solv. - - ce_solv. - - ce_solv. - - ce_solv. - - ce_solv. - - ce_solv. - - ce_solv. - - ce_solv. - - move => i j. - rewrite check_equal_univ. - case : nat_eqdec => //=. - ce_solv. - - move => p0 p1 A0 A1 B0 B1 h0 ih0 h1 ih1. - rewrite check_equal_bind_bind. - move /negP. - move /nandP. - case. move /nandP. - case. move => h. have : p0 <> p1 by sauto lqb:on. - clear. move => ?. hauto lq:on rew:off inv:CoqEq, CoqEq_Neu. - hauto qb:on inv:CoqEq,CoqEq_Neu. - hauto qb:on inv:CoqEq,CoqEq_Neu. - - simp check_equal. done. - - move => i j. move => h. have {h} : ~ nat_eqdec i j by done. - case : nat_eqdec => //=. ce_solv. - - move => u0 u1 a0 a1 hu0 hu1 h0 ih0 h1 ih1. - rewrite check_equal_app_app. - move /negP /nandP. sauto b:on inv:CoqEq, CoqEq_Neu. - - move => p0 p1 u0 u1 neu0 neu1 h ih. - rewrite check_equal_proj_proj. - move /negP /nandP. case. - case : PTag_eqdec => //=. sauto lq:on. - sauto lqb:on. - - move => P0 P1 u0 u1 b0 b1 c0 c1 neu0 neu1 domP ihP domu ihu domb ihb domc ihc. - rewrite check_equal_ind_ind. - move => + h. - inversion h; subst. - inversion H; subst. - move /negP /nandP. - case. move/nandP. - case. move/nandP. - case. qauto b:on inv:CoqEq, CoqEq_Neu. - sauto lqb:on inv:CoqEq, CoqEq_Neu. - sauto lqb:on inv:CoqEq, CoqEq_Neu. - sauto lqb:on inv:CoqEq, CoqEq_Neu. - - rewrite /tm_conf. - move => a b n n0 i. simp ce_prop. - move => _. inversion 1; subst => //=. - + destruct b => //=. - + destruct a => //=. - + destruct b => //=. - + destruct a => //=. - + hauto l:on inv:CoqEq_Neu. - - move => a b h ih. - rewrite check_equal_nfnf. - move : ih => /[apply]. - move => + h0. - have {h} [? ?] : HRed.nf a /\ HRed.nf b by sfirstorder use:algo_dom_no_hred. - inversion h0; subst. - hauto l:on use:hreds_nf_refl. - - move => a a' b h dom. - simp ce_prop => /[apply]. - move => + h1. inversion h1; subst. - inversion H; subst. - + sfirstorder use:coqeq_no_hred unfold:HRed.nf. - + have ? : y = a' by eauto using hred_deter. subst. - sauto lq:on. - - move => a b b' u hr dom ihdom. - rewrite check_equal_hredr. - move => + h. inversion h; subst. - have {}u : HRed.nf a by sfirstorder use:hne_no_hred, hf_no_hred. - move => {}/ihdom. - inversion H0; subst. - + have ? : HRed.nf b'0 by hauto l:on use:coqeq_no_hred. - sfirstorder unfold:HRed.nf. - + sauto lq:on use:hred_deter. -Qed. - -Ltac simp_sub := with_strategy opaque [check_equal] simpl in *. - -Lemma check_sub_sound : - (forall a b (h : salgo_dom a b), check_sub a b h -> a ⋖ b) /\ - (forall a b (h : salgo_dom_r a b), check_sub_r a b h -> a ≪ b). -Proof. - apply salgo_dom_mutual; try done. - - simpl. move => i j []; - sauto lq:on use:Reflect.Nat_leb_le. - - move => A0 A1 B0 B1 s ihs s0 ihs0. - simp ce_prop. - hauto lqb:on ctrs:CoqLEq. - - move => A0 A1 B0 B1 s ihs s0 ihs0. - simp ce_prop. - hauto lqb:on ctrs:CoqLEq. - - qauto ctrs:CoqLEq. - - move => a b i a0. - simp ce_prop. - move => h. apply CLE_NeuNeu. - hauto lq:on use:check_equal_sound, coqeq_neuneu', coqeq_symmetric_mutual. - - move => a b n n0 i. - by simp ce_prop. - - move => a b h ih. simp ce_prop. hauto l:on. - - move => a a' b hr h ih. - simp ce_prop. - sauto lq:on rew:off. - - move => a b b' n r dom ihdom. - simp ce_prop. - move : ihdom => /[apply]. - move {dom}. - sauto lq:on rew:off. -Qed. - -Lemma check_sub_complete : - (forall a b (h : salgo_dom a b), check_sub a b h = false -> ~ a ⋖ b) /\ - (forall a b (h : salgo_dom_r a b), check_sub_r a b h = false -> ~ a ≪ b). -Proof. - apply salgo_dom_mutual; try first [done | hauto depth:4 lq:on inv:CoqLEq, CoqEq_Neu]. - - move => i j /=. - move => + h. inversion h; subst => //=. - sfirstorder use:PeanoNat.Nat.leb_le. - hauto lq:on inv:CoqEq_Neu. - - move => A0 A1 B0 B1 s ihs s' ihs'. simp ce_prop. - move /nandP. - case. - move => /negbTE {}/ihs. hauto q:on inv:CoqLEq, CoqEq_Neu. - move => /negbTE {}/ihs'. hauto q:on inv:CoqLEq, CoqEq_Neu. - - move => A0 A1 B0 B1 s ihs s' ihs'. simp ce_prop. - move /nandP. - case. - move => /negbTE {}/ihs. hauto q:on inv:CoqLEq, CoqEq_Neu. - move => /negbTE {}/ihs'. hauto q:on inv:CoqLEq, CoqEq_Neu. - - move => a b i hs. simp ce_prop. - move => + h. inversion h; subst => //=. - move => /negP h0. - eapply check_equal_complete in h0. - apply h0. by constructor. - - move => a b s ihs. simp ce_prop. - move => h0 h1. apply ihs =>//. - have [? ?] : HRed.nf a /\ HRed.nf b by hauto l:on use:salgo_dom_no_hred. - inversion h1; subst. - hauto l:on use:hreds_nf_refl. - - move => a a' b h dom. - simp ce_prop => /[apply]. - move => + h1. inversion h1; subst. - inversion H; subst. - + sfirstorder use:coqleq_no_hred unfold:HRed.nf. - + have ? : y = a' by eauto using hred_deter. subst. - sauto lq:on. - - move => a b b' u hr dom ihdom. - rewrite check_sub_hredr. - move => + h. inversion h; subst. - have {}u : HRed.nf a by sfirstorder use:hne_no_hred, hf_no_hred. - move => {}/ihdom. - inversion H0; subst. - + have ? : HRed.nf b'0 by hauto l:on use:coqleq_no_hred. - sfirstorder unfold:HRed.nf. - + sauto lq:on use:hred_deter. -Qed. diff --git a/theories/fp_red.v b/theories/fp_red.v index 382f25b..ac5ec3d 100644 --- a/theories/fp_red.v +++ b/theories/fp_red.v @@ -8,9 +8,9 @@ Require Import Arith.Wf_nat (well_founded_lt_compat). Require Import Psatz. From stdpp Require Import relations (rtc (..), rtc_once, rtc_r, sn). From Hammer Require Import Tactics. -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. +Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax. Require Import Btauto. - +Require Import Cdcl.Itauto. Ltac2 spec_refl () := List.iter @@ -20,10 +20,10 @@ Ltac2 spec_refl () := try (specialize $h with (1 := eq_refl)) end) (Control.hyps ()). -Ltac spec_refl := ltac2:(Control.enter spec_refl). +Ltac spec_refl := ltac2:(spec_refl ()). Module EPar. - Inductive R : PTm -> PTm -> Prop := + Inductive R {n} : PTm n -> PTm n -> Prop := (****************** Eta ***********************) | AppEta a0 a1 : R a0 a1 -> @@ -54,80 +54,62 @@ Module EPar. R A0 A1 -> R B0 B1 -> R (PBind p A0 B0) (PBind p A1 B1) - | NatCong : - R PNat PNat - | IndCong P0 P1 a0 a1 b0 b1 c0 c1 : - R P0 P1 -> - R a0 a1 -> - R b0 b1 -> - R c0 c1 -> - (* ----------------------- *) - R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) - | ZeroCong : - R PZero PZero - | SucCong a0 a1 : - R a0 a1 -> - (* ------------ *) - R (PSuc a0) (PSuc a1). + | BotCong : + R PBot PBot. - Lemma refl (a : PTm) : R a a. + Lemma refl n (a : PTm n) : R a a. Proof. - elim : a; hauto lq:on ctrs:R. + elim : n / a; hauto lq:on ctrs:R. Qed. - Derive Dependent Inversion inv with (forall (a b : PTm), R a b) Sort Prop. + Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. - Lemma AppEta' a0 a1 (u : PTm) : + Lemma AppEta' n a0 a1 (u : PTm n) : u = (PAbs (PApp (ren_PTm shift a0) (VarPTm var_zero))) -> R a0 a1 -> R u a1. Proof. move => ->. apply AppEta. Qed. - Lemma renaming (a b : PTm) (ξ : nat -> nat) : + Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : ξ. - elim : a b /h. + move => h. move : m ξ. + elim : n a b /h. - all : try qauto ctrs:R. - - move => a0 a1 ha iha ξ /=. + move => n a0 a1 ha iha m ξ /=. eapply AppEta'; eauto. by asimpl. + all : qauto ctrs:R. Qed. - Lemma morphing_ren (ρ0 ρ1 : nat -> PTm) (ξ : nat -> nat) : + Lemma morphing_ren n m p (ρ0 ρ1 : fin n -> PTm m) (ξ : fin m -> fin p) : (forall i, R (ρ0 i) (ρ1 i)) -> - (forall i, R (funcomp (ren_PTm ξ) ρ0 i) ((funcomp (ren_PTm ξ) ρ1) i)). + (forall i, R ((funcomp (ren_PTm ξ) ρ0) i) ((funcomp (ren_PTm ξ) ρ1) i)). Proof. eauto using renaming. Qed. - Lemma morphing_ext (ρ0 ρ1 : nat -> PTm) a b : + Lemma morphing_ext n m (ρ0 ρ1 : fin n -> PTm m) a b : R a b -> (forall i, R (ρ0 i) (ρ1 i)) -> (forall i, R ((scons a ρ0) i) ((scons b ρ1) i)). - Proof. hauto q:on inv:nat. Qed. + Proof. hauto q:on inv:option. Qed. - Lemma morphing_up (ρ0 ρ1 : nat -> PTm) : + Lemma morphing_up n m (ρ0 ρ1 : fin n -> PTm m) : (forall i, R (ρ0 i) (ρ1 i)) -> (forall i, R (up_PTm_PTm ρ0 i) (up_PTm_PTm ρ1 i)). Proof. hauto l:on ctrs:R use:morphing_ext, morphing_ren unfold:up_PTm_PTm. Qed. - Lemma morphing (a b : PTm) (ρ0 ρ1 : nat -> PTm) : + Lemma morphing n m (a b : PTm n) (ρ0 ρ1 : fin n -> PTm m) : (forall i, R (ρ0 i) (ρ1 i)) -> R a b -> R (subst_PTm ρ0 a) (subst_PTm ρ1 b). Proof. - move => + h. move : ρ0 ρ1. elim : a b / h. - move => a0 a1 ha iha ρ0 ρ1 hρ /=. + move => + h. move : m ρ0 ρ1. elim : n a b / h => n. + move => a0 a1 ha iha m ρ0 ρ1 hρ /=. eapply AppEta'; eauto. by asimpl. all : hauto lq:on ctrs:R use:morphing_up. Qed. - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. hauto l:on use:morphing, refl. Qed. - End EPar. -Inductive SNe : PTm -> Prop := +Inductive SNe {n} : PTm n -> Prop := | N_Var i : SNe (VarPTm i) | N_App a b : @@ -137,13 +119,9 @@ Inductive SNe : PTm -> Prop := | N_Proj p a : SNe a -> SNe (PProj p a) -| N_Ind P a b c : - SN P -> - SNe a -> - SN b -> - SN c -> - SNe (PInd P a b c) -with SN : PTm -> Prop := +| N_Bot : + SNe PBot +with SN {n} : PTm n -> Prop := | N_Pair a b : SN a -> SN b -> @@ -164,14 +142,7 @@ with SN : PTm -> Prop := SN (PBind p A B) | N_Univ i : SN (PUniv i) -| N_Nat : - SN PNat -| N_Zero : - SN PZero -| N_Suc a : - SN a -> - SN (PSuc a) -with TRedSN : PTm -> PTm -> Prop := +with TRedSN {n} : PTm n -> PTm n -> Prop := | N_β a b : SN b -> TRedSN (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -187,93 +158,103 @@ with TRedSN : PTm -> PTm -> Prop := TRedSN (PProj PR (PPair a b)) b | N_ProjCong p a b : TRedSN a b -> - TRedSN (PProj p a) (PProj p b) -| N_IndZero P b c : - SN P -> - SN b -> - SN c -> - TRedSN (PInd P PZero b c) b -| N_IndSuc P a b c : - SN P -> - SN a -> - SN b -> - SN c -> - TRedSN (PInd P (PSuc a) b c) (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) -| N_IndCong P a0 a1 b c : - SN P -> - SN b -> - SN c -> - TRedSN a0 a1 -> - TRedSN (PInd P a0 b c) (PInd P a1 b c). + TRedSN (PProj p a) (PProj p b). -Derive Inversion tred_inv with (forall (a b : PTm), TRedSN a b) Sort Prop. +Derive Dependent Inversion tred_inv with (forall n (a b : PTm n), TRedSN a b) Sort Prop. -Inductive SNat : PTm -> Prop := -| S_Zero : SNat PZero -| S_Neu a : SNe a -> SNat a -| S_Suc a : SNat a -> SNat (PSuc a) -| S_Red a b : TRedSN a b -> SNat b -> SNat a. +Definition ishf {n} (a : PTm n) := + match a with + | PPair _ _ => true + | PAbs _ => true + | PUniv _ => true + | PBind _ _ _ => true + | _ => false + end. -Lemma PProj_imp p a : - ishf a -> +Definition ispair {n} (a : PTm n) := + match a with + | PPair _ _ => true + | _ => false + end. + +Definition isabs {n} (a : PTm n) := + match a with + | PAbs _ => true + | _ => false + end. + +Definition ishf_ren n m (a : PTm n) (ξ : fin n -> fin m) : + ishf (ren_PTm ξ a) = ishf a. +Proof. case : a => //=. Qed. + +Definition isabs_ren n m (a : PTm n) (ξ : fin n -> fin m) : + isabs (ren_PTm ξ a) = isabs a. +Proof. case : a => //=. Qed. + +Definition ispair_ren n m (a : PTm n) (ξ : fin n -> fin m) : + ispair (ren_PTm ξ a) = ispair a. +Proof. case : a => //=. Qed. + + +Lemma PProj_imp n p a : + @ishf n a -> ~~ ispair a -> ~ SN (PProj p a). Proof. move => + + h. move E : (PProj p a) h => u h. move : p a E. - elim : u / h => //=. + elim : n u / h => //=. hauto lq:on inv:SNe,PTm. hauto lq:on inv:TRedSN. Qed. -Lemma PApp_imp a b : - ishf a -> +Lemma PAbs_imp n a b : + @ishf n a -> ~~ isabs a -> ~ SN (PApp a b). Proof. move => + + h. move E : (PApp a b) h => u h. - move : a b E. elim : u /h=>//=. + move : a b E. elim : n u /h=>//=. hauto lq:on inv:SNe,PTm. hauto lq:on inv:TRedSN. Qed. -Lemma PInd_imp P (a : PTm) b c : - ishf a -> - ~~ iszero a -> - ~~ issuc a -> - ~ SN (PInd P a b c). -Proof. - move => + + + h. move E : (PInd P a b c) h => u h. - move : P a b c E. - elim : u /h => //=. - hauto lq:on inv:SNe,PTm. - hauto lq:on inv:TRedSN. -Qed. - -Lemma PProjAbs_imp p (a : PTm) : +Lemma PProjAbs_imp n p (a : PTm (S n)) : ~ SN (PProj p (PAbs a)). Proof. - sfirstorder use:PProj_imp. + move E : (PProj p (PAbs a)) => u hu. + move : p a E. + elim : n u / hu=>//=. + hauto lq:on inv:SNe. + hauto lq:on inv:TRedSN. Qed. -Lemma PAppPair_imp (a b0 b1 : PTm ) : +Lemma PAppPair_imp n (a b0 b1 : PTm n ) : ~ SN (PApp (PPair b0 b1) a). Proof. - sfirstorder use:PApp_imp. + move E : (PApp (PPair b0 b1) a) => u hu. + move : a b0 b1 E. + elim : n u / hu=>//=. + hauto lq:on inv:SNe. + hauto lq:on inv:TRedSN. Qed. -Lemma PAppBind_imp p (A : PTm) B b : +Lemma PAppBind_imp n p (A : PTm n) B b : ~ SN (PApp (PBind p A B) b). Proof. - sfirstorder use:PApp_imp. + move E :(PApp (PBind p A B) b) => u hu. + move : p A B b E. + elim : n u /hu=> //=. + hauto lq:on inv:SNe. + hauto lq:on inv:TRedSN. Qed. -Lemma PProjBind_imp p p' (A : PTm) B : +Lemma PProjBind_imp n p p' (A : PTm n) B : ~ SN (PProj p (PBind p' A B)). Proof. move E :(PProj p (PBind p' A B)) => u hu. move : p p' A B E. - elim : u /hu=>//=. + elim : n u /hu=>//=. hauto lq:on inv:SNe. hauto lq:on inv:TRedSN. Qed. @@ -284,7 +265,7 @@ Scheme sne_ind := Induction for SNe Sort Prop Combined Scheme sn_mutual from sne_ind, sn_ind, sred_ind. -Fixpoint ne (a : PTm) := +Fixpoint ne {n} (a : PTm n) := match a with | VarPTm i => true | PApp a b => ne a && nf b @@ -293,12 +274,9 @@ Fixpoint ne (a : PTm) := | PProj _ a => ne a | PUniv _ => false | PBind _ _ _ => false - | PInd P a b c => nf P && ne a && nf b && nf c - | PNat => false - | PSuc a => false - | PZero => false + | PBot => true end -with nf (a : PTm) := +with nf {n} (a : PTm n) := match a with | VarPTm i => true | PApp a b => ne a && nf b @@ -307,66 +285,41 @@ with nf (a : PTm) := | PProj _ a => ne a | PUniv _ => true | PBind _ A B => nf A && nf B - | PInd P a b c => nf P && ne a && nf b && nf c - | PNat => true - | PSuc a => nf a - | PZero => true + | PBot => true end. -Lemma ne_nf a : ne a -> nf a. +Lemma ne_nf n a : @ne n a -> nf a. Proof. elim : a => //=. Qed. -Lemma ne_nf_ren (a : PTm) (ξ : nat -> nat) : - (ne a <-> ne (ren_PTm ξ a)) /\ (nf a <-> nf (ren_PTm ξ a)). -Proof. - move : ξ. elim : a => //=; solve [hauto b:on]. -Qed. - -Inductive TRedSN' (a : PTm) : PTm -> Prop := +Inductive TRedSN' {n} (a : PTm n) : PTm n -> Prop := | T_Refl : TRedSN' a a | T_Once b : TRedSN a b -> TRedSN' a b. -Lemma SN_Proj p (a : PTm) : +Lemma SN_Proj n p (a : PTm n) : SN (PProj p a) -> SN a. Proof. move E : (PProj p a) => u h. move : a E. - elim : u / h => n //=; sauto. + elim : n u / h => n //=; sauto. Qed. -Lemma N_β' a (b : PTm) u : +Lemma N_β' n a (b : PTm n) u : u = (subst_PTm (scons b VarPTm) a) -> SN b -> TRedSN (PApp (PAbs a) b) u. Proof. move => ->. apply N_β. Qed. -Lemma N_IndSuc' P a b c u : - u = (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) -> - SN P -> - SN a -> - SN b -> - SN c -> - TRedSN (PInd P (PSuc a) b c) u. -Proof. move => ->. apply N_IndSuc. Qed. - -Lemma sn_renaming : - (forall (a : PTm) (s : SNe a), forall (ξ : nat -> nat), SNe (ren_PTm ξ a)) /\ - (forall (a : PTm) (s : SN a), forall (ξ : nat -> nat), SN (ren_PTm ξ a)) /\ - (forall (a b : PTm) (_ : TRedSN a b), forall (ξ : nat -> nat), TRedSN (ren_PTm ξ a) (ren_PTm ξ b)). +Lemma sn_renaming n : + (forall (a : PTm n) (s : SNe a), forall m (ξ : fin n -> fin m), SNe (ren_PTm ξ a)) /\ + (forall (a : PTm n) (s : SN a), forall m (ξ : fin n -> fin m), SN (ren_PTm ξ a)) /\ + (forall (a b : PTm n) (_ : TRedSN a b), forall m (ξ : fin n -> fin m), TRedSN (ren_PTm ξ a) (ren_PTm ξ b)). Proof. - apply sn_mutual => n; try qauto ctrs:SN, SNe, TRedSN depth:1. - move => */=. apply N_β';eauto. by asimpl. - - move => */=. apply N_IndSuc'; eauto. by asimpl. -Qed. - -Lemma ne_nf_embed (a : PTm) : - (ne a -> SNe a) /\ (nf a -> SN a). -Proof. - elim : a => //=; hauto qb:on ctrs:SNe, SN. + move : n. apply sn_mutual => n; try qauto ctrs:SN, SNe, TRedSN depth:1. + move => a b ha iha m ξ /=. + apply N_β'. by asimpl. eauto. Qed. #[export]Hint Constructors SN SNe TRedSN : sn. @@ -375,53 +328,41 @@ Ltac2 rec solve_anti_ren () := let x := Fresh.in_goal (Option.get (Ident.of_string "x")) in intro $x; lazy_match! Constr.type (Control.hyp x) with - | nat -> nat => (ltac1:(case;qauto depth:2 db:sn)) - | nat -> PTm => (ltac1:(case;qauto depth:2 db:sn)) + | fin _ -> _ _ => (ltac1:(case;qauto depth:2 db:sn)) | _ => solve_anti_ren () end. Ltac solve_anti_ren := ltac2:(Control.enter solve_anti_ren). -Lemma sn_antirenaming : - (forall (a : PTm) (s : SNe a), forall (ξ : nat -> nat) b, a = ren_PTm ξ b -> SNe b) /\ - (forall (a : PTm) (s : SN a), forall (ξ : nat -> nat) b, a = ren_PTm ξ b -> SN b) /\ - (forall (a b : PTm) (_ : TRedSN a b), forall (ξ : nat -> nat) a0, +Lemma sn_antirenaming n : + (forall (a : PTm n) (s : SNe a), forall m (ξ : fin m -> fin n) b, a = ren_PTm ξ b -> SNe b) /\ + (forall (a : PTm n) (s : SN a), forall m (ξ : fin m -> fin n) b, a = ren_PTm ξ b -> SN b) /\ + (forall (a b : PTm n) (_ : TRedSN a b), forall m (ξ : fin m -> fin n) a0, a = ren_PTm ξ a0 -> exists b0, TRedSN a0 b0 /\ b = ren_PTm ξ b0). Proof. - apply sn_mutual; try solve_anti_ren. - move => *. subst. spec_refl. hauto lq:on ctrs:TRedSN, SN. + move : n. apply sn_mutual => n; try solve_anti_ren. - move => a b ha iha ξ []//= u u0 [+ ?]. subst. + move => a b ha iha m ξ []//= u u0 [+ ?]. subst. case : u => //= => u [*]. subst. spec_refl. eexists. split. apply N_β=>//. by asimpl. - move => a b hb ihb ξ[]//= p p0 [? +]. subst. + move => a b hb ihb m ξ[]//= p p0 [? +]. subst. case : p0 => //= p p0 [*]. subst. spec_refl. by eauto with sn. - move => a b ha iha ξ[]//= u u0 [? ]. subst. + move => a b ha iha m ξ[]//= u u0 [? ]. subst. case : u0 => //=. move => p p0 [*]. subst. spec_refl. by eauto with sn. - - move => P b c ha iha hb ihb hc ihc ξ []//= P0 a0 b0 c0 [?]. subst. - case : a0 => //= _ *. subst. - spec_refl. by eauto with sn. - - move => P a b c hP ihP ha iha hb ihb hc ihc ξ []//= P0 a0 b0 c0 [?]. subst. - case : a0 => //= a0 [*]. subst. - spec_refl. eexists; repeat split; eauto with sn. - by asimpl. Qed. -Lemma sn_unmorphing : - (forall (a : PTm) (s : SNe a), forall (ρ : nat -> PTm) b, a = subst_PTm ρ b -> SNe b) /\ - (forall (a : PTm) (s : SN a), forall (ρ : nat -> PTm) b, a = subst_PTm ρ b -> SN b) /\ - (forall (a b : PTm) (_ : TRedSN a b), forall (ρ : nat -> PTm) a0, +Lemma sn_unmorphing n : + (forall (a : PTm n) (s : SNe a), forall m (ρ : fin m -> PTm n) b, a = subst_PTm ρ b -> SNe b) /\ + (forall (a : PTm n) (s : SN a), forall m (ρ : fin m -> PTm n) b, a = subst_PTm ρ b -> SN b) /\ + (forall (a b : PTm n) (_ : TRedSN a b), forall m (ρ : fin m -> PTm n) a0, a = subst_PTm ρ a0 -> (exists b0, b = subst_PTm ρ b0 /\ TRedSN a0 b0) \/ SNe a0). Proof. - apply sn_mutual; try solve_anti_ren. - - hauto q:on db:sn. - - move => a b ha iha ξ b0. + move : n. apply sn_mutual => n; try solve_anti_ren. + - move => a b ha iha m ξ b0. case : b0 => //=. + hauto lq:on rew:off db:sn. + move => p p0 [+ ?]. subst. @@ -432,7 +373,7 @@ Proof. spec_refl. eexists. split; last by eauto using N_β. by asimpl. - - move => a0 a1 b hb ihb ha iha ρ []//=. + - move => a0 a1 b hb ihb ha iha m ρ []//=. + hauto lq:on rew:off db:sn. + move => t0 t1 [*]. subst. spec_refl. @@ -443,18 +384,16 @@ Proof. * move => h. right. apply N_App => //. - - move => a b hb ihb ρ []//=. + - move => a b hb ihb m ρ []//=. + hauto l:on ctrs:TRedSN. + move => p p0 [?]. subst. case : p0 => //=. * hauto lq:on rew:off db:sn. * move => p p0 [*]. subst. hauto lq:on db:sn. - - move => a b ha iha ρ []//=; first by hauto l:on db:sn. - case => //=. move => []//=. - + hauto lq:on db:sn. - + hauto lq:on db:sn. - - move => p a b ha iha ρ []//=; first by hauto l:on db:sn. + - move => a b ha iha m ρ []//=; first by hauto l:on db:sn. + hauto q:on inv:PTm db:sn. + - move => p a b ha iha m ρ []//=; first by hauto l:on db:sn. move => t0 t1 [*]. subst. spec_refl. case : iha. @@ -462,66 +401,35 @@ Proof. left. eexists. split; last by eauto with sn. reflexivity. + hauto lq:on db:sn. - - move => P b c hP ihP hb ihb hc ihc ρ []//=. - + hauto lq:on db:sn. - + move => p []//=. - * hauto lq:on db:sn. - * hauto q:on db:sn. - - move => P a b c hP ihP ha iha hb ihb hc ihc ρ []//=. - + hauto lq:on db:sn. - + move => P0 a0 b0 c0 [?]. subst. - case : a0 => //=. - * hauto lq:on db:sn. - * move => a0 [*]. subst. - spec_refl. - left. eexists. split; last by eauto with sn. - by asimpl. - - move => P a0 a1 b c hP ihP hb ihb hc ihc ha iha ρ[]//=. - + hauto lq:on db:sn. - + move => P1 a2 b2 c2 [*]. subst. - spec_refl. - case : iha. - * move => [a3][?]h. subst. - left. eexists; split; last by eauto with sn. - asimpl. eauto with sn. - * hauto lq:on db:sn. Qed. -Lemma SN_AppInv : forall (a b : PTm), SN (PApp a b) -> SN a /\ SN b. +Lemma SN_AppInv : forall n (a b : PTm n), SN (PApp a b) -> SN a /\ SN b. Proof. - move => a b. move E : (PApp a b) => u hu. move : a b E. - elim : u /hu=>//=. + move => n a b. move E : (PApp a b) => u hu. move : a b E. + elim : n u /hu=>//=. hauto lq:on rew:off inv:SNe db:sn. - move => a b ha hb ihb a0 b0 ?. subst. + move => n a b ha hb ihb a0 b0 ?. subst. inversion ha; subst. move {ihb}. hecrush use:sn_unmorphing. hauto lq:on db:sn. Qed. -Lemma SN_ProjInv : forall p (a : PTm), SN (PProj p a) -> SN a. +Lemma SN_ProjInv : forall n p (a : PTm n), SN (PProj p a) -> SN a. Proof. - move => p a. move E : (PProj p a) => u hu. + move => n p a. move E : (PProj p a) => u hu. move : p a E. - elim : u / hu => //=. + elim : n u / hu => //=. hauto lq:on rew:off inv:SNe db:sn. hauto lq:on rew:off inv:TRedSN db:sn. Qed. -Lemma SN_IndInv : forall P (a : PTm) b c, SN (PInd P a b c) -> SN P /\ SN a /\ SN b /\ SN c. +Lemma epar_sn_preservation n : + (forall (a : PTm n) (s : SNe a), forall b, EPar.R a b -> SNe b) /\ + (forall (a : PTm n) (s : SN a), forall b, EPar.R a b -> SN b) /\ + (forall (a b : PTm n) (_ : TRedSN a b), forall c, EPar.R a c -> exists d, TRedSN' c d /\ EPar.R b d). Proof. - move => P a b c. move E : (PInd P a b c) => u hu. move : P a b c E. - elim : u / hu => //=. - hauto lq:on rew:off inv:SNe db:sn. - hauto lq:on rew:off inv:TRedSN db:sn. -Qed. - -Lemma epar_sn_preservation : - (forall (a : PTm) (s : SNe a), forall b, EPar.R a b -> SNe b) /\ - (forall (a : PTm) (s : SN a), forall b, EPar.R a b -> SN b) /\ - (forall (a b : PTm) (_ : TRedSN a b), forall c, EPar.R a c -> exists d, TRedSN' c d /\ EPar.R b d). -Proof. - apply sn_mutual. + move : n. apply sn_mutual => n. - sauto lq:on. - sauto lq:on. - sauto lq:on. @@ -544,9 +452,6 @@ Proof. - sauto lq:on. - sauto lq:on. - sauto lq:on. - - sauto lq:on. - - sauto lq:on. - - sauto lq:on. - move => a b ha iha c h0. inversion h0; subst. inversion H1; subst. @@ -557,7 +462,7 @@ Proof. exists (subst_PTm (scons b1 VarPTm) a2). split. sauto lq:on. - hauto lq:on use:EPar.morphing, EPar.refl inv:nat. + hauto lq:on use:EPar.morphing, EPar.refl inv:option. - sauto. - move => a b hb ihb c. elim /EPar.inv => //= _. @@ -578,31 +483,17 @@ Proof. sauto lq:on. + sauto lq:on. - sauto. - - sauto q:on. - - move => P a b c hP ihP ha iha hb ihb hc ihc u. - elim /EPar.inv => //=_. - move => P0 P1 a0 a1 b0 b1 c0 c1 hP0 ha0 hb0 hc0 [*]. subst. - elim /EPar.inv : ha0 => //=_. - move => a0 a2 ha0 [*]. subst. - eexists. split. apply T_Once. apply N_IndSuc; eauto. - hauto q:on ctrs:EPar.R use:EPar.morphing, EPar.refl inv:nat. - - sauto q:on. Qed. Module RRed. - Inductive R : PTm -> PTm -> Prop := - (****************** Beta ***********************) + Inductive R {n} : PTm n -> PTm n -> Prop := + (****************** Eta ***********************) | AppAbs a b : R (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) | ProjPair p a b : R (PProj p (PPair a b)) (if p is PL then a else b) - | IndZero P b c : - R (PInd P PZero b c) b - - | IndSuc P a b c : - R (PInd P (PSuc a) b c) (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) (*************** Congruence ********************) | AbsCong a0 a1 : R a0 a1 -> @@ -627,102 +518,57 @@ Module RRed. R (PBind p A0 B) (PBind p A1 B) | BindCong1 p A B0 B1 : R B0 B1 -> - R (PBind p A B0) (PBind p A B1) - | IndCong0 P0 P1 a b c : - R P0 P1 -> - R (PInd P0 a b c) (PInd P1 a b c) - | IndCong1 P a0 a1 b c : - R a0 a1 -> - R (PInd P a0 b c) (PInd P a1 b c) - | IndCong2 P a b0 b1 c : - R b0 b1 -> - R (PInd P a b0 c) (PInd P a b1 c) - | IndCong3 P a b c0 c1 : - R c0 c1 -> - R (PInd P a b c0) (PInd P a b c1) - | SucCong a0 a1 : - R a0 a1 -> - R (PSuc a0) (PSuc a1). + R (PBind p A B0) (PBind p A B1). - Derive Inversion inv with (forall (a b : PTm), R a b) Sort Prop. + Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. - Lemma AppAbs' a (b : PTm) u : + Lemma AppAbs' n a (b : PTm n) u : u = (subst_PTm (scons b VarPTm) a) -> R (PApp (PAbs a) b) u. Proof. move => ->. by apply AppAbs. Qed. - Lemma IndSuc' P a b c u : - u = (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) -> - R (PInd P (PSuc a) b c) u. - Proof. move => ->. apply IndSuc. Qed. - - Lemma renaming (a b : PTm) (ξ : nat -> nat) : + Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : ξ. - elim : a b /h. + move => h. move : m ξ. + elim : n a b /h. - all : try qauto ctrs:R. - move => a b ξ /=. + move => n a b m ξ /=. apply AppAbs'. by asimpl. - move => */=; apply IndSuc'; eauto. by asimpl. + all : qauto ctrs:R. Qed. Ltac2 rec solve_anti_ren () := let x := Fresh.in_goal (Option.get (Ident.of_string "x")) in intro $x; lazy_match! Constr.type (Control.hyp x) with - | nat -> nat => (ltac1:(case;hauto q:on depth:2 ctrs:RRed.R)) - | nat -> PTm => (ltac1:(case;hauto q:on depth:2 ctrs:RRed.R)) + | fin _ -> _ _ => (ltac1:(case;hauto q:on depth:2 ctrs:RRed.R)) | _ => solve_anti_ren () end. Ltac solve_anti_ren := ltac2:(Control.enter solve_anti_ren). - Lemma antirenaming (a : PTm) (b : PTm) (ξ : nat -> nat) : + Lemma antirenaming n m (a : PTm n) (b : PTm m) (ξ : fin n -> fin m) : R (ren_PTm ξ a) b -> exists b0, R a b0 /\ ren_PTm ξ b0 = b. Proof. move E : (ren_PTm ξ a) => u h. - move : ξ a E. elim : u b/h; try solve_anti_ren. - - move => a b ξ []//=. move => []//= t t0 [*]. subst. + move : n ξ a E. elim : m u b/h; try solve_anti_ren. + - move => n a b m ξ []//=. move => []//= t t0 [*]. subst. eexists. split. apply AppAbs. by asimpl. - - move => p a b ξ []//=. + - move => n p a b m ξ []//=. move => p0 []//=. hauto q:on ctrs:R. - - move => p b c ξ []//= P a0 b0 c0 [*]. subst. - destruct a0 => //=. - hauto lq:on ctrs:R. - - move => P a b c ξ []//=. - move => p p0 p1 p2 [?]. subst. - case : p0 => //=. - move => p0 [?] *. subst. eexists. split; eauto using IndSuc. - by asimpl. Qed. - Lemma nf_imp (a b : PTm) : + Lemma nf_imp n (a b : PTm n) : nf a -> R a b -> False. Proof. move/[swap]. induction 1; hauto qb:on inv:PTm. Qed. - Lemma FromRedSN (a b : PTm) : - TRedSN a b -> - RRed.R a b. - Proof. induction 1; hauto lq:on ctrs:RRed.R. Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. - move => h. move : ρ. elim : a b / h => n. - - all : try hauto lq:on ctrs:R. - move => */=. eapply AppAbs'; eauto; cycle 1. by asimpl. - move => */=; apply : IndSuc'; eauto. by asimpl. - Qed. - End RRed. Module RPar. - Inductive R : PTm -> PTm -> Prop := + Inductive R {n} : PTm n -> PTm n -> Prop := (****************** Beta ***********************) | AppAbs a0 a1 b0 b1 : R a0 a1 -> @@ -734,18 +580,6 @@ Module RPar. R b0 b1 -> R (PProj p (PPair a0 b0)) (if p is PL then a1 else b1) - | IndZero P b0 b1 c : - R b0 b1 -> - R (PInd P PZero b0 c) b1 - - | IndSuc P0 P1 a0 a1 b0 b1 c0 c1 : - R P0 P1 -> - R a0 a1 -> - R b0 b1 -> - R c0 c1 -> - (* ----------------------------- *) - R (PInd P0 (PSuc a0) b0 c0) (subst_PTm (scons (PInd P1 a1 b1 c1) (scons a1 VarPTm)) c1) - (*************** Congruence ********************) | AbsCong a0 a1 : R a0 a1 -> @@ -769,120 +603,92 @@ Module RPar. R A0 A1 -> R B0 B1 -> R (PBind p A0 B0) (PBind p A1 B1) - | NatCong : - R PNat PNat - | IndCong P0 P1 a0 a1 b0 b1 c0 c1 : - R P0 P1 -> - R a0 a1 -> - R b0 b1 -> - R c0 c1 -> - (* ----------------------- *) - R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) - | ZeroCong : - R PZero PZero - | SucCong a0 a1 : - R a0 a1 -> - (* ------------ *) - R (PSuc a0) (PSuc a1). + | BotCong : + R PBot PBot. - Lemma refl (a : PTm) : R a a. + Lemma refl n (a : PTm n) : R a a. Proof. - elim : a; hauto lq:on ctrs:R. + elim : n / a; hauto lq:on ctrs:R. Qed. - Derive Dependent Inversion inv with (forall (a b : PTm), R a b) Sort Prop. + Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. - Lemma AppAbs' a0 a1 (b0 b1 : PTm) u : + Lemma AppAbs' n a0 a1 (b0 b1 : PTm n) u : u = (subst_PTm (scons b1 VarPTm) a1) -> R a0 a1 -> R b0 b1 -> R (PApp (PAbs a0) b0) u. Proof. move => ->. apply AppAbs. Qed. - Lemma ProjPair' p u (a0 a1 b0 b1 : PTm) : + Lemma ProjPair' n p u (a0 a1 b0 b1 : PTm n) : u = (if p is PL then a1 else b1) -> R a0 a1 -> R b0 b1 -> R (PProj p (PPair a0 b0)) u. Proof. move => ->. apply ProjPair. Qed. - Lemma IndSuc' P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 u : - u = (subst_PTm (scons (PInd P1 a1 b1 c1) (scons a1 VarPTm)) c1) -> - R P0 P1 -> - R a0 a1 -> - R b0 b1 -> - R c0 c1 -> - (* ----------------------------- *) - R (PInd P0 (PSuc a0) b0 c0) u. - Proof. move => ->. apply IndSuc. Qed. - - Lemma renaming (a b : PTm) (ξ : nat -> nat) : + Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : ξ. - elim : a b /h. + move => h. move : m ξ. + elim : n a b /h. - all : try qauto ctrs:R use:ProjPair'. - - move => a0 a1 b0 b1 ha iha hb ihb ξ /=. + move => n a0 a1 b0 b1 ha iha hb ihb m ξ /=. eapply AppAbs'; eauto. by asimpl. - - move => * /=. apply : IndSuc'; eauto. by asimpl. + all : qauto ctrs:R use:ProjPair'. Qed. - Lemma morphing_ren (ρ0 ρ1 : nat -> PTm) (ξ : nat -> nat) : + Lemma morphing_ren n m p (ρ0 ρ1 : fin n -> PTm m) (ξ : fin m -> fin p) : (forall i, R (ρ0 i) (ρ1 i)) -> (forall i, R ((funcomp (ren_PTm ξ) ρ0) i) ((funcomp (ren_PTm ξ) ρ1) i)). Proof. eauto using renaming. Qed. - Lemma morphing_ext (ρ0 ρ1 : nat -> PTm) a b : + Lemma morphing_ext n m (ρ0 ρ1 : fin n -> PTm m) a b : R a b -> (forall i, R (ρ0 i) (ρ1 i)) -> (forall i, R ((scons a ρ0) i) ((scons b ρ1) i)). - Proof. hauto q:on inv:nat. Qed. + Proof. hauto q:on inv:option. Qed. - Lemma morphing_up (ρ0 ρ1 : nat -> PTm) : + Lemma morphing_up n m (ρ0 ρ1 : fin n -> PTm m) : (forall i, R (ρ0 i) (ρ1 i)) -> (forall i, R (up_PTm_PTm ρ0 i) (up_PTm_PTm ρ1 i)). Proof. hauto l:on ctrs:R use:morphing_ext, morphing_ren unfold:up_PTm_PTm. Qed. - Lemma morphing (a b : PTm) (ρ0 ρ1 : nat -> PTm) : + Lemma morphing n m (a b : PTm n) (ρ0 ρ1 : fin n -> PTm m) : (forall i, R (ρ0 i) (ρ1 i)) -> R a b -> R (subst_PTm ρ0 a) (subst_PTm ρ1 b). Proof. - move => + h. move : ρ0 ρ1. elim : a b / h. - all : try hauto lq:on ctrs:R use:morphing_up, ProjPair'. - move => a0 a1 b0 b1 ha iha hb ihb ρ0 ρ1 hρ /=. - eapply AppAbs'; eauto; cycle 1. sfirstorder use:morphing_up. by asimpl. - move => */=; eapply IndSuc'; eauto; cycle 1. - sfirstorder use:morphing_up. - sfirstorder use:morphing_up. + move => + h. move : m ρ0 ρ1. elim : n a b / h => n. + move => a0 a1 b0 b1 ha iha hb ihb m ρ0 ρ1 hρ /=. + eapply AppAbs'; eauto; cycle 1. sfirstorder use:morphing_up. by asimpl. + all : hauto lq:on ctrs:R use:morphing_up, ProjPair'. Qed. - Lemma substing (a : PTm) b (ρ : nat -> PTm) : + Lemma substing n m (a : PTm n) b (ρ : fin n -> PTm m) : R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). Proof. hauto l:on use:morphing, refl. Qed. - Lemma cong (a0 a1 : PTm) b0 b1 : + + Lemma cong n (a0 a1 : PTm (S n)) b0 b1 : R a0 a1 -> R b0 b1 -> R (subst_PTm (scons b0 VarPTm) a0) (subst_PTm (scons b1 VarPTm) a1). Proof. move => h0 h1. apply morphing=>//. - hauto q:on inv:nat ctrs:R. + hauto q:on inv:option ctrs:R. Qed. - Lemma FromRRed (a b : PTm) : + Lemma FromRRed n (a b : PTm n) : RRed.R a b -> RPar.R a b. Proof. induction 1; qauto l:on use:RPar.refl ctrs:RPar.R. Qed. - Function tstar (a : PTm) := + Function tstar {n} (a : PTm n) := match a with | VarPTm i => a | PAbs a => PAbs (tstar a) @@ -893,20 +699,14 @@ Module RPar. | PProj p a => PProj p (tstar a) | PUniv i => PUniv i | PBind p A B => PBind p (tstar A) (tstar B) - | PNat => PNat - | PZero => PZero - | PSuc a => PSuc (tstar a) - | PInd P PZero b c => tstar b - | PInd P (PSuc a) b c => - (subst_PTm (scons (PInd (tstar P) (tstar a) (tstar b) (tstar c)) (scons (tstar a) VarPTm)) (tstar c)) - | PInd P a b c => PInd (tstar P) (tstar a) (tstar b) (tstar c) + | PBot => PBot end. - Lemma triangle (a b : PTm) : + Lemma triangle n (a b : PTm n) : RPar.R a b -> RPar.R b (tstar a). Proof. move : b. - apply tstar_ind => {}a. + apply tstar_ind => {}n{}a. - hauto lq:on ctrs:R inv:R. - hauto lq:on ctrs:R inv:R. - hauto lq:on rew:off inv:R use:cong ctrs:R. @@ -931,43 +731,29 @@ Module RPar. - hauto lq:on ctrs:R inv:R. - hauto lq:on ctrs:R inv:R. - hauto lq:on ctrs:R inv:R. - - hauto lq:on ctrs:R inv:R. - - hauto lq:on ctrs:R inv:R. - - hauto lq:on ctrs:R inv:R. - - move => P a0 b c ? hP ihP ha iha hb ihb u. subst. - elim /inv => //= _. - + move => P0 P1 a1 a2 b0 b1 c0 c1 hP' ha' hb' hc' [*]. subst. - apply morphing. hauto lq:on ctrs:R inv:nat. - eauto. - + sauto q:on ctrs:R. - - sauto lq:on. Qed. - Lemma diamond (a b c : PTm) : + Lemma diamond n (a b c : PTm n) : R a b -> R a c -> exists d, R b d /\ R c d. Proof. eauto using triangle. Qed. End RPar. -Lemma red_sn_preservation : - (forall (a : PTm) (s : SNe a), forall b, RPar.R a b -> SNe b) /\ - (forall (a : PTm) (s : SN a), forall b, RPar.R a b -> SN b) /\ - (forall (a b : PTm) (_ : TRedSN a b), forall c, RPar.R a c -> exists d, TRedSN' c d /\ RPar.R b d). +Lemma red_sn_preservation n : + (forall (a : PTm n) (s : SNe a), forall b, RPar.R a b -> SNe b) /\ + (forall (a : PTm n) (s : SN a), forall b, RPar.R a b -> SN b) /\ + (forall (a b : PTm n) (_ : TRedSN a b), forall c, RPar.R a c -> exists d, TRedSN' c d /\ RPar.R b d). Proof. - apply sn_mutual. + move : n. apply sn_mutual => n. - hauto l:on inv:RPar.R. - qauto l:on inv:RPar.R,SNe,SN ctrs:SNe. - hauto lq:on inv:RPar.R, SNe ctrs:SNe. - hauto lq:on inv:RPar.R, SNe ctrs:SNe. - (* - qauto l:on inv:RPar.R, SN,SNe ctrs:SNe. *) - qauto l:on ctrs:SN inv:RPar.R. - hauto lq:on ctrs:SN inv:RPar.R. - hauto lq:on ctrs:SN. - hauto q:on ctrs:SN inv:SN, TRedSN'. - hauto lq:on ctrs:SN inv:RPar.R. - hauto lq:on ctrs:SN inv:RPar.R. - - hauto l:on inv:RPar.R. - - hauto l:on inv:RPar.R. - - hauto lq:on ctrs:SN inv:RPar.R. - move => a b ha iha hb ihb. elim /RPar.inv : ihb => //=_. + move => a0 a1 b0 b1 ha0 hb0 [*]. subst. @@ -987,19 +773,6 @@ Proof. - hauto lq:on inv:RPar.R ctrs:RPar.R, TRedSN', TRedSN. - hauto lq:on inv:RPar.R ctrs:RPar.R, TRedSN', TRedSN. - sauto. - - sauto. - - move => P a b c hP ihP ha iha hb ihb hc ihc u. - elim /RPar.inv => //=_. - + move => P0 P1 a0 a1 b0 b1 c0 c1 hP' ha' hb' hc' [*]. subst. - eexists. split; first by apply T_Refl. - apply RPar.morphing=>//. hauto lq:on ctrs:RPar.R inv:nat. - + move => P0 P1 a0 a1 b0 b1 c0 c1 hP' ha' hb' hc' [*]. subst. - elim /RPar.inv : ha' => //=_. - move => a0 a2 ha' [*]. subst. - eexists. split. apply T_Once. - apply N_IndSuc; eauto. - hauto q:on use:RPar.morphing ctrs:RPar.R inv:nat. - - sauto q:on. Qed. Module RReds. @@ -1011,73 +784,54 @@ Module RReds. #[local]Ltac solve_s := repeat (induction 1; last by solve_s_rec); apply rtc_refl. - Lemma AbsCong (a b : PTm) : + Lemma AbsCong n (a b : PTm (S n)) : rtc RRed.R a b -> rtc RRed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong (a0 a1 b0 b1 : PTm) : + Lemma AppCong n (a0 a1 b0 b1 : PTm n) : rtc RRed.R a0 a1 -> rtc RRed.R b0 b1 -> rtc RRed.R (PApp a0 b0) (PApp a1 b1). Proof. solve_s. Qed. - Lemma PairCong (a0 a1 b0 b1 : PTm) : + Lemma PairCong n (a0 a1 b0 b1 : PTm n) : rtc RRed.R a0 a1 -> rtc RRed.R b0 b1 -> rtc RRed.R (PPair a0 b0) (PPair a1 b1). Proof. solve_s. Qed. - Lemma ProjCong p (a0 a1 : PTm) : + Lemma ProjCong n p (a0 a1 : PTm n) : rtc RRed.R a0 a1 -> rtc RRed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma SucCong (a0 a1 : PTm) : - rtc RRed.R a0 a1 -> - rtc RRed.R (PSuc a0) (PSuc a1). - Proof. solve_s. Qed. - - Lemma IndCong P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : - rtc RRed.R P0 P1 -> - rtc RRed.R a0 a1 -> - rtc RRed.R b0 b1 -> - rtc RRed.R c0 c1 -> - rtc RRed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). - Proof. solve_s. Qed. - - Lemma BindCong p (A0 A1 : PTm) B0 B1 : + Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : rtc RRed.R A0 A1 -> rtc RRed.R B0 B1 -> rtc RRed.R (PBind p A0 B0) (PBind p A1 B1). Proof. solve_s. Qed. - Lemma renaming (a b : PTm) (ξ : nat -> nat) : + Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : rtc RRed.R a b -> rtc RRed.R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : ξ. elim : a b /h; hauto lq:on ctrs:rtc use:RRed.renaming. + move => h. move : m ξ. elim : a b /h; hauto lq:on ctrs:rtc use:RRed.renaming. Qed. - Lemma FromRPar (a b : PTm) (h : RPar.R a b) : + Lemma FromRPar n (a b : PTm n) (h : RPar.R a b) : rtc RRed.R a b. Proof. - elim : a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong, IndCong, SucCong. - move => a0 a1 b0 b1 ha iha hb ihb. + elim : n a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong. + move => n a0 a1 b0 b1 ha iha hb ihb. apply : rtc_r; last by apply RRed.AppAbs. by eauto using AppCong, AbsCong. - move => p a0 a1 b0 b1 ha iha hb ihb. + move => n p a0 a1 b0 b1 ha iha hb ihb. apply : rtc_r; last by apply RRed.ProjPair. by eauto using PairCong, ProjCong. - - hauto lq:on ctrs:RRed.R, rtc. - - move => *. - apply : rtc_r; last by apply RRed.IndSuc. - by eauto using SucCong, IndCong. Qed. - Lemma RParIff (a b : PTm) : + Lemma RParIff n (a b : PTm n) : rtc RRed.R a b <-> rtc RPar.R a b. Proof. split. @@ -1085,20 +839,21 @@ Module RReds. induction 1; hauto l:on ctrs:rtc use:FromRPar, @relations.rtc_transitive. Qed. - Lemma nf_refl (a b : PTm) : + Lemma nf_refl n (a b : PTm n) : rtc RRed.R a b -> nf a -> a = b. Proof. induction 1; sfirstorder use:RRed.nf_imp. Qed. - Lemma FromRedSNs (a b : PTm) : - rtc TRedSN a b -> - rtc RRed.R a b. - Proof. induction 1; hauto lq:on ctrs:rtc use:RRed.FromRedSN. Qed. - End RReds. +Lemma ne_nf_ren n m (a : PTm n) (ξ : fin n -> fin m) : + (ne a <-> ne (ren_PTm ξ a)) /\ (nf a <-> nf (ren_PTm ξ a)). +Proof. + move : m ξ. elim : n / a => //=; solve [hauto b:on]. +Qed. + Module NeEPar. - Inductive R_nonelim : PTm -> PTm -> Prop := + Inductive R_nonelim {n} : PTm n -> PTm n -> Prop := (****************** Eta ***********************) | AppEta a0 a1 : ~~ ishf a0 -> @@ -1131,22 +886,9 @@ Module NeEPar. R_nonelim A0 A1 -> R_nonelim B0 B1 -> R_nonelim (PBind p A0 B0) (PBind p A1 B1) - | NatCong : - R_nonelim PNat PNat - | IndCong P0 P1 a0 a1 b0 b1 c0 c1 : - R_nonelim P0 P1 -> - R_elim a0 a1 -> - R_nonelim b0 b1 -> - R_nonelim c0 c1 -> - (* ----------------------- *) - R_nonelim (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) - | ZeroCong : - R_nonelim PZero PZero - | SucCong a0 a1 : - R_nonelim a0 a1 -> - (* ------------ *) - R_nonelim (PSuc a0) (PSuc a1) - with R_elim : PTm -> PTm -> Prop := + | BotCong : + R_nonelim PBot PBot + with R_elim {n} : PTm n -> PTm n -> Prop := | NAbsCong a0 a1 : R_nonelim a0 a1 -> R_elim (PAbs a0) (PAbs a1) @@ -1169,32 +911,19 @@ Module NeEPar. R_nonelim A0 A1 -> R_nonelim B0 B1 -> R_elim (PBind p A0 B0) (PBind p A1 B1) - | NNatCong : - R_elim PNat PNat - | NIndCong P0 P1 a0 a1 b0 b1 c0 c1 : - R_nonelim P0 P1 -> - R_elim a0 a1 -> - R_nonelim b0 b1 -> - R_nonelim c0 c1 -> - (* ----------------------- *) - R_elim (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) - | NZeroCong : - R_elim PZero PZero - | NSucCong a0 a1 : - R_nonelim a0 a1 -> - (* ------------ *) - R_elim (PSuc a0) (PSuc a1). + | NBotCong : + R_elim PBot PBot. Scheme epar_elim_ind := Induction for R_elim Sort Prop with epar_nonelim_ind := Induction for R_nonelim Sort Prop. Combined Scheme epar_mutual from epar_elim_ind, epar_nonelim_ind. - Lemma R_elim_nf : - (forall (a b : PTm), R_elim a b -> nf b -> nf a) /\ - (forall (a b : PTm), R_nonelim a b -> nf b -> nf a). + Lemma R_elim_nf n : + (forall (a b : PTm n), R_elim a b -> nf b -> nf a) /\ + (forall (a b : PTm n), R_nonelim a b -> nf b -> nf a). Proof. - apply epar_mutual => //=. + move : n. apply epar_mutual => n //=. - move => a0 a1 b0 b1 h ih h' ih' /andP [h0 h1]. have hb0 : nf b0 by eauto. suff : ne a0 by qauto b:on. @@ -1202,7 +931,6 @@ Module NeEPar. - hauto lb:on. - hauto lq:on inv:R_elim. - hauto b:on. - - hauto lqb:on inv:R_elim. - move => a0 a1 /negP ha' ha ih ha1. have {ih} := ih ha1. move => ha0. @@ -1220,25 +948,24 @@ Module NeEPar. - hauto lb: on drew: off. - hauto lq:on rew:off inv:R_elim. - sfirstorder b:on. - - hauto lqb:on inv:R_elim. Qed. - Lemma R_nonelim_nothf (a b : PTm) : + Lemma R_nonelim_nothf n (a b : PTm n) : R_nonelim a b -> ~~ ishf a -> R_elim a b. Proof. - move => h. elim : a b /h=>//=; hauto lq:on ctrs:R_elim. + move => h. elim : n a b /h=>//=; hauto lq:on ctrs:R_elim. Qed. - Lemma R_elim_nonelim (a b : PTm) : + Lemma R_elim_nonelim n (a b : PTm n) : R_elim a b -> R_nonelim a b. - move => h. elim : a b /h=>//=; hauto lq:on ctrs:R_nonelim. + move => h. elim : n a b /h=>//=; hauto lq:on ctrs:R_nonelim. Qed. - Lemma ToEPar : (forall (a b : PTm), R_elim a b -> EPar.R a b) /\ - (forall (a b : PTm), R_nonelim a b -> EPar.R a b). + Lemma ToEPar : forall n, (forall (a b : PTm n), R_elim a b -> EPar.R a b) /\ + (forall (a b : PTm n), R_nonelim a b -> EPar.R a b). Proof. apply epar_mutual; qauto l:on ctrs:EPar.R. Qed. @@ -1246,45 +973,45 @@ Module NeEPar. End NeEPar. Module Type NoForbid. - Parameter P : PTm -> Prop. + Parameter P : forall n, PTm n -> Prop. + Arguments P {n}. - Axiom P_EPar : forall (a b : PTm), EPar.R a b -> P a -> P b. - Axiom P_RRed : forall (a b : PTm), RRed.R a b -> P a -> P b. - Axiom PApp_imp : forall a b, ishf a -> ~~ isabs a -> ~ P (PApp a b). - Axiom PProj_imp : forall p a, ishf a -> ~~ ispair a -> ~ P (PProj p a). - Axiom PInd_imp : forall Q (a : PTm) b c, - ishf a -> - ~~ iszero a -> - ~~ issuc a -> ~ P (PInd Q a b c). + Axiom P_EPar : forall n (a b : PTm n), EPar.R a b -> P a -> P b. + Axiom P_RRed : forall n (a b : PTm n), RRed.R a b -> P a -> P b. + (* Axiom P_AppPair : forall n (a b c : PTm n), ~ P (PApp (PPair a b) c). *) + (* Axiom P_ProjAbs : forall n p (a : PTm (S n)), ~ P (PProj p (PAbs a)). *) + (* Axiom P_ProjBind : forall n p p' (A : PTm n) B, ~ P (PProj p (PBind p' A B)). *) + (* Axiom P_AppBind : forall n p (A : PTm n) B b, ~ P (PApp (PBind p A B) b). *) + Axiom PAbs_imp : forall n a b, @ishf n a -> ~~ isabs a -> ~ P (PApp a b). + Axiom PProj_imp : forall n p a, @ishf n a -> ~~ ispair a -> ~ P (PProj p a). - Axiom P_AppInv : forall (a b : PTm), P (PApp a b) -> P a /\ P b. - Axiom P_AbsInv : forall (a : PTm), P (PAbs a) -> P a. - Axiom P_SucInv : forall (a : PTm), P (PSuc a) -> P a. - Axiom P_BindInv : forall p (A : PTm) B, P (PBind p A B) -> P A /\ P B. - Axiom P_IndInv : forall Q (a : PTm) b c, P (PInd Q a b c) -> P Q /\ P a /\ P b /\ P c. + Axiom P_AppInv : forall n (a b : PTm n), P (PApp a b) -> P a /\ P b. + Axiom P_AbsInv : forall n (a : PTm (S n)), P (PAbs a) -> P a. + Axiom P_BindInv : forall n p (A : PTm n) B, P (PBind p A B) -> P A /\ P B. + + Axiom P_PairInv : forall n (a b : PTm n), P (PPair a b) -> P a /\ P b. + Axiom P_ProjInv : forall n p (a : PTm n), P (PProj p a) -> P a. + Axiom P_renaming : forall n m (ξ : fin n -> fin m) a , P (ren_PTm ξ a) <-> P a. - Axiom P_PairInv : forall (a b : PTm), P (PPair a b) -> P a /\ P b. - Axiom P_ProjInv : forall p (a : PTm), P (PProj p a) -> P a. - Axiom P_renaming : forall (ξ : nat -> nat) a , P (ren_PTm ξ a) <-> P a. End NoForbid. Module Type NoForbid_FactSig (M : NoForbid). - Axiom P_EPars : forall (a b : PTm), rtc EPar.R a b -> M.P a -> M.P b. + Axiom P_EPars : forall n (a b : PTm n), rtc EPar.R a b -> M.P a -> M.P b. - Axiom P_RReds : forall (a b : PTm), rtc RRed.R a b -> M.P a -> M.P b. + Axiom P_RReds : forall n (a b : PTm n), rtc RRed.R a b -> M.P a -> M.P b. End NoForbid_FactSig. Module NoForbid_Fact (M : NoForbid) : NoForbid_FactSig M. Import M. - Lemma P_EPars : forall (a b : PTm), rtc EPar.R a b -> P a -> P b. + Lemma P_EPars : forall n (a b : PTm n), rtc EPar.R a b -> P a -> P b. Proof. induction 1; eauto using P_EPar, rtc_l, rtc_refl. Qed. - Lemma P_RReds : forall (a b : PTm), rtc RRed.R a b -> P a -> P b. + Lemma P_RReds : forall n (a b : PTm n), rtc RRed.R a b -> P a -> P b. Proof. induction 1; eauto using P_RRed, rtc_l, rtc_refl. Qed. @@ -1292,78 +1019,67 @@ End NoForbid_Fact. Module SN_NoForbid <: NoForbid. Definition P := @SN. + Arguments P {n}. - Lemma P_EPar : forall (a b : PTm), EPar.R a b -> P a -> P b. + Lemma P_EPar : forall n (a b : PTm n), EPar.R a b -> P a -> P b. Proof. sfirstorder use:epar_sn_preservation. Qed. - Lemma P_RRed : forall (a b : PTm), RRed.R a b -> P a -> P b. + Lemma P_RRed : forall n (a b : PTm n), RRed.R a b -> P a -> P b. Proof. hauto q:on use:red_sn_preservation, RPar.FromRRed. Qed. - Lemma PApp_imp : forall a b, ishf a -> ~~ isabs a -> ~ P (PApp a b). - sfirstorder use:fp_red.PApp_imp. Qed. - Lemma PProj_imp : forall p a, ishf a -> ~~ ispair a -> ~ P (PProj p a). + Lemma PAbs_imp : forall n a b, @ishf n a -> ~~ isabs a -> ~ P (PApp a b). + sfirstorder use:fp_red.PAbs_imp. Qed. + Lemma PProj_imp : forall n p a, @ishf n a -> ~~ ispair a -> ~ P (PProj p a). sfirstorder use:fp_red.PProj_imp. Qed. - Lemma PInd_imp : forall Q (a : PTm) b c, - ishf a -> - ~~ iszero a -> - ~~ issuc a -> ~ P (PInd Q a b c). - Proof. sfirstorder use: fp_red.PInd_imp. Qed. - - Lemma P_AppInv : forall (a b : PTm), P (PApp a b) -> P a /\ P b. + Lemma P_AppInv : forall n (a b : PTm n), P (PApp a b) -> P a /\ P b. Proof. sfirstorder use:SN_AppInv. Qed. - Lemma P_PairInv : forall (a b : PTm), P (PPair a b) -> P a /\ P b. - move => a b. move E : (PPair a b) => u h. - move : a b E. elim : u / h; sauto lq:on rew:off. Qed. + Lemma P_PairInv : forall n (a b : PTm n), P (PPair a b) -> P a /\ P b. + move => n a b. move E : (PPair a b) => u h. + move : a b E. elim : n u / h; sauto lq:on rew:off. Qed. - Lemma P_ProjInv : forall p (a : PTm), P (PProj p a) -> P a. + Lemma P_ProjInv : forall n p (a : PTm n), P (PProj p a) -> P a. Proof. sfirstorder use:SN_ProjInv. Qed. - Lemma P_BindInv : forall p (A : PTm) B, P (PBind p A B) -> P A /\ P B. + Lemma P_BindInv : forall n p (A : PTm n) B, P (PBind p A B) -> P A /\ P B. Proof. - move => p A B. + move => n p A B. move E : (PBind p A B) => u hu. - move : p A B E. elim : u /hu=>//=;sauto lq:on rew:off. + move : p A B E. elim : n u /hu=>//=;sauto lq:on rew:off. Qed. - Lemma P_SucInv : forall (a : PTm), P (PSuc a) -> P a. - Proof. sauto lq:on. Qed. - - Lemma P_AbsInv : forall (a : PTm), P (PAbs a) -> P a. + Lemma P_AbsInv : forall n (a : PTm (S n)), P (PAbs a) -> P a. Proof. - move => a. move E : (PAbs a) => u h. + move => n a. move E : (PAbs a) => u h. move : E. move : a. induction h; sauto lq:on rew:off. Qed. - Lemma P_renaming : forall (ξ : nat -> nat) a , P (ren_PTm ξ a) <-> P a. + Lemma P_renaming : forall n m (ξ : fin n -> fin m) a , P (ren_PTm ξ a) <-> P a. Proof. hauto lq:on use:sn_antirenaming, sn_renaming. Qed. - Lemma P_ProjBind : forall p p' (A : PTm) B, ~ P (PProj p (PBind p' A B)). + Lemma P_ProjBind : forall n p p' (A : PTm n) B, ~ P (PProj p (PBind p' A B)). Proof. sfirstorder use:PProjBind_imp. Qed. - Lemma P_AppBind : forall p (A : PTm) B b, ~ P (PApp (PBind p A B) b). + Lemma P_AppBind : forall n p (A : PTm n) B b, ~ P (PApp (PBind p A B) b). Proof. sfirstorder use:PAppBind_imp. Qed. - Lemma P_IndInv : forall Q (a : PTm) b c, P (PInd Q a b c) -> P Q /\ P a /\ P b /\ P c. - Proof. sfirstorder use:SN_IndInv. Qed. - End SN_NoForbid. Module NoForbid_FactSN := NoForbid_Fact SN_NoForbid. Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). Import M MFacts. - #[local]Hint Resolve P_EPar P_RRed PApp_imp PProj_imp : forbid. + #[local]Hint Resolve P_EPar P_RRed PAbs_imp PProj_imp : forbid. - Lemma η_split (a0 a1 : PTm) : + Lemma η_split n (a0 a1 : PTm n) : EPar.R a0 a1 -> P a0 -> exists b, rtc RRed.R a0 b /\ NeEPar.R_nonelim b a1. Proof. - move => h. elim : a0 a1 /h . - - move => a0 a1 ha ih /[dup] hP. + move => h. elim : n a0 a1 /h . + - move => n a0 a1 ha ih /[dup] hP. move /P_AbsInv /P_AppInv => [/P_renaming ha0 _]. have {ih} := ih ha0. move => [b [ih0 ih1]]. @@ -1383,13 +1099,7 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). by eauto using RReds.renaming. apply rtc_refl. apply : RRed.AbsCong => /=. - apply RRed.AppAbs'. asimpl. - set y := subst_PTm _ _. - suff : ren_PTm id p = y. by asimpl. - subst y. - substify. - apply ext_PTm. - case => //=. + apply RRed.AppAbs'. by asimpl. (* violates SN *) + move /P_AbsInv in hP. have {}hP : P (PApp (ren_PTm shift b) (VarPTm var_zero)) @@ -1398,8 +1108,8 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). have ? : ~~ isabs (ren_PTm shift b) by scongruence use:isabs_ren. have ? : ishf (ren_PTm shift b) by scongruence use:ishf_ren. exfalso. - sfirstorder use:PApp_imp. - - move => a0 a1 h ih /[dup] hP. + sfirstorder use:PAbs_imp. + - move => n a0 a1 h ih /[dup] hP. move /P_PairInv => [/P_ProjInv + _]. move : ih => /[apply]. move => [b [ih0 ih1]]. @@ -1424,7 +1134,7 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). move : P_RReds hP. repeat move/[apply] => /=. sfirstorder use:PProj_imp. - hauto lq:on ctrs:NeEPar.R_nonelim use:RReds.AbsCong, P_AbsInv. - - move => a0 a1 b0 b1 ha iha hb ihb. + - move => n a0 a1 b0 b1 ha iha hb ihb. move => /[dup] hP /P_AppInv [hP0 hP1]. have {iha} [a2 [iha0 iha1]] := iha hP0. have {ihb} [b2 [ihb0 ihb1]] := ihb hP1. @@ -1445,9 +1155,9 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). (* Impossible *) * move =>*. exfalso. have : P (PApp a2 b0) by sfirstorder use:RReds.AppCong, @rtc_refl, P_RReds. - sfirstorder use:PApp_imp. + sfirstorder use:PAbs_imp. - hauto lq:on ctrs:NeEPar.R_nonelim use:RReds.PairCong, P_PairInv. - - move => p a0 a1 ha ih /[dup] hP /P_ProjInv. + - move => n p a0 a1 ha ih /[dup] hP /P_ProjInv. move : ih => /[apply]. move => [a2 [iha0 iha1]]. case /orP : (orNb (ishf a2)) => [h|]. exists (PProj p a2). @@ -1472,58 +1182,35 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). - hauto l:on. - hauto lq:on ctrs:NeEPar.R_nonelim, rtc use:RReds.BindCong, P_BindInv. - hauto lq:on ctrs:NeEPar.R_nonelim, rtc use:RReds.BindCong, P_BindInv. - - move => P0 P1 a0 a1 b0 b1 c0 c1 hP ihP ha iha hb ihb hc ihc /[dup] hInd /P_IndInv. - move => []. move : ihP => /[apply]. - move => [P01][ihP0]ihP1. - move => []. move : iha => /[apply]. - move => [a01][iha0]iha1. - move => []. move : ihb => /[apply]. - move => [b01][ihb0]ihb1. - move : ihc => /[apply]. - move => [c01][ihc0]ihc1. - case /orP : (orNb (ishf a01)) => [h|]. - + eexists. split. by eauto using RReds.IndCong. - hauto q:on ctrs:NeEPar.R_nonelim use:NeEPar.R_nonelim_nothf. - + move => h. - case /orP : (orNb (issuc a01 || iszero a01)). - * move /norP. - have : P (PInd P01 a01 b01 c01) by eauto using P_RReds, RReds.IndCong. - hauto lq:on use:PInd_imp. - * move => ha01. - eexists. split. eauto using RReds.IndCong. - apply NeEPar.IndCong; eauto. - move : iha1 ha01. clear. - inversion 1; subst => //=; hauto lq:on ctrs:NeEPar.R_elim. - - hauto l:on. - - hauto lq:on ctrs:NeEPar.R_nonelim use:RReds.SucCong, P_SucInv. Qed. - Lemma eta_postponement a b c : - P a -> + + Lemma eta_postponement n a b c : + @P n a -> EPar.R a b -> RRed.R b c -> exists d, rtc RRed.R a d /\ EPar.R d c. Proof. move => + h. move : c. - elim : a b /h => //=. - - move => a0 a1 ha iha c /[dup] hP /P_AbsInv /P_AppInv [/P_renaming hP' _] hc. + elim : n a b /h => //=. + - move => n a0 a1 ha iha c /[dup] hP /P_AbsInv /P_AppInv [/P_renaming hP' _] hc. move : iha (hP') (hc); repeat move/[apply]. move => [d [h0 h1]]. exists (PAbs (PApp (ren_PTm shift d) (VarPTm var_zero))). split. hauto lq:on rew:off ctrs:rtc use:RReds.AbsCong, RReds.AppCong, RReds.renaming. hauto lq:on ctrs:EPar.R. - - move => a0 a1 ha iha c /P_PairInv [/P_ProjInv + _]. + - move => n a0 a1 ha iha c /P_PairInv [/P_ProjInv + _]. move /iha => /[apply]. move => [d [h0 h1]]. exists (PPair (PProj PL d) (PProj PR d)). hauto lq:on ctrs:EPar.R use:RReds.PairCong, RReds.ProjCong. - - move => a0 a1 ha iha c /P_AbsInv /[swap]. + - move => n a0 a1 ha iha c /P_AbsInv /[swap]. elim /RRed.inv => //=_. move => a2 a3 + [? ?]. subst. move : iha; repeat move/[apply]. hauto lq:on use:RReds.AbsCong ctrs:EPar.R. - - move => a0 a1 b0 b1 ha iha hb ihb c hP. + - move => n a0 a1 b0 b1 ha iha hb ihb c hP. elim /RRed.inv => //= _. + move => a2 b2 [*]. subst. have [hP' hP''] : P a0 /\ P b0 by sfirstorder use:P_AppInv. @@ -1542,18 +1229,18 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). apply RRed.AppCong0. apply RRed.AbsCong. simpl. apply RRed.AppAbs. asimpl. apply rtc_once. - apply RRed.AppAbs'. by asimpl. + apply RRed.AppAbs. * exfalso. move : hP h0. clear => hP h0. have : rtc RRed.R (PApp a0 b0) (PApp (PPair (PProj PL a1) (PProj PR a1)) b0) by qauto l:on ctrs:rtc use:RReds.AppCong. move : P_RReds hP. repeat move/[apply]. - sfirstorder use:PApp_imp. + sfirstorder use:PAbs_imp. * exists (subst_PTm (scons b0 VarPTm) a1). split. apply : rtc_r; last by apply RRed.AppAbs. hauto lq:on ctrs:rtc use:RReds.AppCong. - hauto l:on inv:nat use:EPar.morphing,NeEPar.ToEPar. + hauto l:on inv:option use:EPar.morphing,NeEPar.ToEPar. + move => a2 a3 b2 ha2 [*]. subst. move : iha (ha2) {ihb} => /[apply]. have : P a0 by sfirstorder use:P_AppInv. @@ -1566,10 +1253,10 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). have : P b0 by sfirstorder use:P_AppInv. move : ihb hb2; repeat move /[apply]. hauto lq:on rew:off ctrs:EPar.R, rtc use:RReds.AppCong. - - move => a0 a1 b0 b1 ha iha hb ihb c /P_PairInv [hP hP']. + - move => n a0 a1 b0 b1 ha iha hb ihb c /P_PairInv [hP hP']. elim /RRed.inv => //=_; hauto lq:on rew:off ctrs:EPar.R, rtc use:RReds.PairCong. - - move => p a0 a1 ha iha c /[dup] hP /P_ProjInv hP'. + - move => n p a0 a1 ha iha c /[dup] hP /P_ProjInv hP'. elim / RRed.inv => //= _. + move => p0 a2 b0 [*]. subst. move : η_split hP' ha; repeat move/[apply]. @@ -1603,74 +1290,10 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). - hauto lq:on inv:RRed.R ctrs:rtc. - sauto lq:on ctrs:EPar.R, rtc use:RReds.BindCong, P_BindInv, @relations.rtc_transitive. - hauto lq:on inv:RRed.R ctrs:rtc. - - move => P0 P1 a0 a1 b0 b1 c0 c1 hP ihP ha iha hb ihb hc ihc u. - move => /[dup] hInd. - move /P_IndInv. - move => [pP0][pa0][pb0]pc0. - elim /RRed.inv => //= _. - + move => P2 b2 c2 [*]. subst. - move /η_split : pa0 ha; repeat move/[apply]. - move => [a1][h0]h1 {iha}. - inversion h1; subst. - * exfalso. - have :P (PInd P0 (PAbs (PApp (ren_PTm shift a2) (VarPTm var_zero))) b0 c0) by eauto using RReds.IndCong, rtc_refl, P_RReds. - clear. hauto lq:on use:PInd_imp. - * have :P (PInd P0 (PPair (PProj PL a2) (PProj PR a2)) b0 c0) by eauto using RReds.IndCong, rtc_refl, P_RReds. - clear. hauto lq:on use:PInd_imp. - * eexists. split; eauto. - apply : rtc_r. - apply : RReds.IndCong; eauto; eauto using rtc_refl. - apply RRed.IndZero. - + move => P2 a2 b2 c [*]. subst. - move /η_split /(_ pa0) : ha. - move => [a1][h0]h1. - inversion h1; subst. - * have :P (PInd P0 (PAbs (PApp (ren_PTm shift a3) (VarPTm var_zero))) b0 c0) by eauto using RReds.IndCong, rtc_refl, P_RReds. - clear. hauto q:on use:PInd_imp. - * have :P (PInd P0 (PPair (PProj PL a3) (PProj PR a3)) b0 c0) by eauto using RReds.IndCong, rtc_refl, P_RReds. - clear. hauto q:on use:PInd_imp. - * eexists. split. - apply : rtc_r. - apply RReds.IndCong; eauto; eauto using rtc_refl. - apply RRed.IndSuc. - apply EPar.morphing;eauto. - case => [|]. - hauto lq:on rew:off ctrs:EPar.R use:NeEPar.ToEPar. - case => [|i]. - hauto lq:on rew:off ctrs:EPar.R use:NeEPar.ToEPar. - asimpl. apply EPar.VarTm. - + move => P2 P3 a2 b2 c hP0 [*]. subst. - move : ihP hP0 pP0. repeat move/[apply]. - move => [P2][h0]h1. - exists (PInd P2 a0 b0 c0). - sfirstorder use:RReds.IndCong, @rtc_refl, EPar.IndCong. - + move => P2 a2 a3 b2 c + [*]. subst. - move : iha pa0; repeat move/[apply]. - move => [a2][*]. - exists (PInd P0 a2 b0 c0). - sfirstorder use:RReds.IndCong, @rtc_refl, EPar.IndCong. - + move => P2 a2 b2 b3 c + [*]. subst. - move : ihb pb0; repeat move/[apply]. - move => [b2][*]. - exists (PInd P0 a0 b2 c0). - sfirstorder use:RReds.IndCong, @rtc_refl, EPar.IndCong. - + move => P2 a2 b2 b3 c + [*]. subst. - move : ihc pc0; repeat move/[apply]. - move => [c2][*]. - exists (PInd P0 a0 b0 c2). - sfirstorder use:RReds.IndCong, @rtc_refl, EPar.IndCong. - - hauto lq:on inv:RRed.R ctrs:rtc, EPar.R. - - move => a0 a1 ha iha u /P_SucInv ha0. - elim /RRed.inv => //= _ a2 a3 h [*]. subst. - move : iha (ha0) (h); repeat move/[apply]. - move => [a2 [ih0 ih1]]. - exists (PSuc a2). - split. by apply RReds.SucCong. - by apply EPar.SucCong. Qed. - Lemma η_postponement_star a b c : - P a -> + Lemma η_postponement_star n a b c : + @P n a -> EPar.R a b -> rtc RRed.R b c -> exists d, rtc RRed.R a d /\ EPar.R d c. @@ -1686,8 +1309,8 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). sfirstorder use:@relations.rtc_transitive. Qed. - Lemma η_postponement_star' a b c : - P a -> + Lemma η_postponement_star' n a b c : + @P n a -> EPar.R a b -> rtc RRed.R b c -> exists d, rtc RRed.R a d /\ NeEPar.R_nonelim d c. @@ -1704,7 +1327,7 @@ End UniqueNF. Module SN_UniqueNF := UniqueNF SN_NoForbid NoForbid_FactSN. Module ERed. - Inductive R : PTm -> PTm -> Prop := + Inductive R {n} : PTm n -> PTm n -> Prop := (****************** Eta ***********************) | AppEta a : @@ -1736,26 +1359,11 @@ Module ERed. R (PBind p A0 B) (PBind p A1 B) | BindCong1 p A B0 B1 : R B0 B1 -> - R (PBind p A B0) (PBind p A B1) - | IndCong0 P0 P1 a b c : - R P0 P1 -> - R (PInd P0 a b c) (PInd P1 a b c) - | IndCong1 P a0 a1 b c : - R a0 a1 -> - R (PInd P a0 b c) (PInd P a1 b c) - | IndCong2 P a b0 b1 c : - R b0 b1 -> - R (PInd P a b0 c) (PInd P a b1 c) - | IndCong3 P a b c0 c1 : - R c0 c1 -> - R (PInd P a b c0) (PInd P a b c1) - | SucCong a0 a1 : - R a0 a1 -> - R (PSuc a0) (PSuc a1). + R (PBind p A B0) (PBind p A B1). - Derive Inversion inv with (forall (a b : PTm), R a b) Sort Prop. + Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. - Lemma ToEPar (a b : PTm) : + Lemma ToEPar n (a b : PTm n) : ERed.R a b -> EPar.R a b. Proof. induction 1; hauto lq:on use:EPar.refl ctrs:EPar.R. @@ -1765,157 +1373,102 @@ Module ERed. let x := Fresh.in_goal (Option.get (Ident.of_string "x")) in intro $x; lazy_match! Constr.type (Control.hyp x) with - | nat -> _ => (ltac1:(case;hauto q:on depth:2 ctrs:ERed.R)) + | fin _ -> _ _ => (ltac1:(case;hauto q:on depth:2 ctrs:ERed.R)) | _ => solve_anti_ren () end. Ltac solve_anti_ren := ltac2:(Control.enter solve_anti_ren). - Lemma AppEta' a u : - u = (PApp (ren_PTm shift a) (VarPTm var_zero)) -> + (* Definition down n m (ξ : fin n -> fin m) (a : fin (S n)) : fin m. *) + (* destruct a. *) + (* exact (ξ f). *) + + Lemma up_injective n m (ξ : fin n -> fin m) : + (forall i j, ξ i = ξ j -> i = j) -> + forall i j, (upRen_PTm_PTm ξ) i = (upRen_PTm_PTm ξ) j -> i = j. + Proof. + sblast inv:option. + Qed. + + Lemma ren_injective n m (a b : PTm n) (ξ : fin n -> fin m) : + (forall i j, ξ i = ξ j -> i = j) -> + ren_PTm ξ a = ren_PTm ξ b -> + a = b. + Proof. + move : m ξ b. + elim : n / a => //; try solve_anti_ren. + + move => n a iha m ξ []//=. + move => u hξ [h]. + apply iha in h. by subst. + destruct i, j=>//=. + hauto l:on. + + move => n p A ihA B ihB m ξ []//=. + move => b A0 B0 hξ [?]. subst. + move => ?. have ? : A0 = A by firstorder. subst. + move => ?. have : B = B0. apply : ihB; eauto. + sauto. + congruence. + Qed. + + Lemma AppEta' n a u : + u = (@PApp (S n) (ren_PTm shift a) (VarPTm var_zero)) -> R (PAbs u) a. Proof. move => ->. apply AppEta. Qed. - Lemma renaming (a b : PTm) (ξ : nat -> nat) : + Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : ξ. - elim : a b /h. + move => h. move : m ξ. + elim : n a b /h. - move => a ξ /=. + move => n a m ξ /=. apply AppEta'; eauto. by asimpl. all : qauto ctrs:R. Qed. - (* Characterization of variable freeness conditions *) - Definition tm_i_free a (i : nat) := exists (ξ ξ0 : nat -> nat), ξ i <> ξ0 i /\ ren_PTm ξ a = ren_PTm ξ0 a. - - Lemma subst_differ_one_ren_up i (ξ0 ξ1 : nat -> nat) : - (forall j, i <> j -> ξ0 j = ξ1 j) -> - (forall j, shift i <> j -> upRen_PTm_PTm ξ0 j = upRen_PTm_PTm ξ1 j). - Proof. - move => hξ. - case => // j. - asimpl. - move => h. have : i<> j by hauto lq:on rew:off. - move /hξ. by rewrite /funcomp => ->. - Qed. - - Lemma tm_free_ren_any a i : - tm_i_free a i -> - forall (ξ0 ξ1 : nat -> nat), (forall j, i <> j -> ξ0 j = ξ1 j) -> - ren_PTm ξ0 a = ren_PTm ξ1 a. - Proof. - rewrite /tm_i_free. - move => [+ [+ [+ +]]]. - move : i. - elim : a. - - hauto q:on. - - move => a iha i ρ0 ρ1 h [] h' ξ0 ξ1 hξ /=. - f_equal. move /subst_differ_one_ren_up in hξ. - move /(_ (shift i)) in iha. - move : iha hξ; move/[apply]. - apply; cycle 1; eauto. - - hauto lq:on rew:off. - - hauto lq:on rew:off. - - hauto lq:on rew:off. - - move => p A ihA a iha i ρ0 ρ1 hρ [] ? h ξ0 ξ1 hξ /=. - f_equal. hauto lq:on rew:off. - move /subst_differ_one_ren_up in hξ. - move /(_ (shift i)) in iha. - move : iha (hξ). repeat move/[apply]. - move /(_ (upRen_PTm_PTm ρ0) (upRen_PTm_PTm ρ1)). - apply. simpl. rewrite /funcomp. scongruence. - sfirstorder. - - hauto lq:on rew:off. - - hauto lq:on rew:off. - - hauto lq:on rew:off. - - hauto lq:on rew:off. - - move => P ihP a iha b ihb c ihc i ρ0 ρ1 hρ /= []hP - ha hb hc ξ0 ξ1 hξ. - f_equal;eauto. - apply : ihP; cycle 1; eauto using subst_differ_one_ren_up. - apply : ihc; cycle 1; eauto using subst_differ_one_ren_up. - hauto l:on. - Qed. - - Lemma antirenaming (a : PTm) (b : PTm) (ξ : nat -> nat) : + (* Need to generalize to injective renaming *) + Lemma antirenaming n m (a : PTm n) (b : PTm m) (ξ : fin n -> fin m) : (forall i j, ξ i = ξ j -> i = j) -> R (ren_PTm ξ a) b -> exists b0, R a b0 /\ ren_PTm ξ b0 = b. Proof. move => hξ. move E : (ren_PTm ξ a) => u hu. - move : ξ a hξ E. - elim : u b / hu; try solve_anti_ren. - - move => a ξ []//=. + move : n ξ a hξ E. + elim : m u b / hu; try solve_anti_ren. + - move => n a m ξ []//=. move => u hξ []. case : u => //=. move => u0 u1 []. case : u1 => //=. move => i /[swap] []. case : i => //= _ h. - suff : exists p, ren_PTm shift p = u0. + have : exists p, ren_PTm shift p = u0 by admit. move => [p ?]. subst. move : h. asimpl. - replace (ren_PTm (funcomp S ξ) p) with + replace (ren_PTm (funcomp shift ξ) p) with (ren_PTm shift (ren_PTm ξ p)); last by asimpl. move /ren_injective. - move /(_ ltac:(hauto l:on unfold:ren_inj)). + move /(_ ltac:(hauto l:on)). move => ?. subst. exists p. split=>//. apply AppEta. - set u := ren_PTm (scons 0 id) u0. - suff : ren_PTm shift u = u0 by eauto. - subst u. - asimpl. - have hE : u0 = ren_PTm id u0 by asimpl. - rewrite {2}hE. move{hE}. - apply (tm_free_ren_any _ 0); last by qauto l:on inv:nat. - rewrite /tm_i_free. - have h' := h. - apply f_equal with (f := ren_PTm (scons 0 id)) in h. - apply f_equal with (f := ren_PTm (scons 1 id)) in h'. - move : h'. asimpl => *. subst. - move : h. asimpl. move => *. do 2 eexists. split; eauto. - scongruence. - - move => a ξ [] //=. + - move => n a m ξ [] //=. move => u u0 hξ []. case : u => //=. case : u0 => //=. move => p p0 p1 p2 [? ?] [? h]. subst. have ? : p0 = p2 by eauto using ren_injective. subst. hauto l:on. - - move => a0 a1 ha iha ξ []//= p hξ [?]. subst. - fcrush use:up_injective. - - move => p A B0 B1 hB ihB ξ + hξ. + - move => n a0 a1 ha iha m ξ []//= p hξ [?]. subst. + sauto lq:on use:up_injective. + - move => n p A B0 B1 hB ihB m ξ + hξ. case => //= p' A2 B2 [*]. subst. - have : (forall i j, (upRen_PTm_PTm ξ) i = (upRen_PTm_PTm ξ) j -> i = j) by sfirstorder use:up_injective. + have : (forall i j, (upRen_PTm_PTm ξ) i = (upRen_PTm_PTm ξ) j -> i = j) by sauto. move => {}/ihB => ihB. spec_refl. sauto lq:on. - - move => P0 P1 a b c hP ihP ξ []//=. - move => > /up_injective. - hauto q:on ctrs:R. - - move => P a b c0 c1 hc ihc ξ []//=. - move => > /up_injective /up_injective. - hauto q:on ctrs:R. - Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. - move => h. move : ρ. elim : a b /h. - move => a ρ /=. - eapply AppEta'; eauto. by asimpl. - all : hauto lq:on ctrs:R. - Qed. - - Lemma nf_preservation (a b : PTm) : - ERed.R a b -> (nf a -> nf b) /\ (ne a -> ne b). - Proof. - move => h. - elim : a b /h => //=; - hauto lqb:on use:ne_nf_ren,ne_nf. - Qed. + Admitted. End ERed. @@ -1928,188 +1481,61 @@ Module EReds. #[local]Ltac solve_s := repeat (induction 1; last by solve_s_rec); apply rtc_refl. - Lemma AbsCong (a b : PTm) : + Lemma AbsCong n (a b : PTm (S n)) : rtc ERed.R a b -> rtc ERed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong (a0 a1 b0 b1 : PTm) : + Lemma AppCong n (a0 a1 b0 b1 : PTm n) : rtc ERed.R a0 a1 -> rtc ERed.R b0 b1 -> rtc ERed.R (PApp a0 b0) (PApp a1 b1). Proof. solve_s. Qed. - Lemma PairCong (a0 a1 b0 b1 : PTm) : + Lemma PairCong n (a0 a1 b0 b1 : PTm n) : rtc ERed.R a0 a1 -> rtc ERed.R b0 b1 -> rtc ERed.R (PPair a0 b0) (PPair a1 b1). Proof. solve_s. Qed. - Lemma ProjCong p (a0 a1 : PTm) : + Lemma ProjCong n p (a0 a1 : PTm n) : rtc ERed.R a0 a1 -> rtc ERed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma BindCong p (A0 A1 : PTm) B0 B1 : + Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : rtc ERed.R A0 A1 -> rtc ERed.R B0 B1 -> rtc ERed.R (PBind p A0 B0) (PBind p A1 B1). Proof. solve_s. Qed. - Lemma SucCong (a0 a1 : PTm) : - rtc ERed.R a0 a1 -> - rtc ERed.R (PSuc a0) (PSuc a1). - Proof. solve_s. Qed. - Lemma IndCong P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : - rtc ERed.R P0 P1 -> - rtc ERed.R a0 a1 -> - rtc ERed.R b0 b1 -> - rtc ERed.R c0 c1 -> - rtc ERed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). - Proof. solve_s. Qed. - - Lemma renaming (a b : PTm) (ξ : nat -> nat) : + Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : rtc ERed.R a b -> rtc ERed.R (ren_PTm ξ a) (ren_PTm ξ b). Proof. induction 1; hauto l:on use:ERed.renaming ctrs:rtc. Qed. - Lemma FromEPar (a b : PTm) : + Lemma FromEPar n (a b : PTm n) : EPar.R a b -> rtc ERed.R a b. Proof. - move => h. elim : a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong, IndCong, SucCong. - - move => a0 a1 _ h. + move => h. elim : n a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong. + - move => n a0 a1 _ h. have {}h : rtc ERed.R (ren_PTm shift a0) (ren_PTm shift a1) by apply renaming. apply : rtc_r. apply AbsCong. apply AppCong; eauto. apply rtc_refl. apply ERed.AppEta. - - move => a0 a1 _ h. + - move => n a0 a1 _ h. apply : rtc_r. apply PairCong; eauto using ProjCong. apply ERed.PairEta. Qed. - Lemma FromEPars (a b : PTm) : - rtc EPar.R a b -> - rtc ERed.R a b. - Proof. induction 1; hauto l:on use:FromEPar, @relations.rtc_transitive. Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - rtc ERed.R a b -> rtc ERed.R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. - induction 1; hauto lq:on ctrs:rtc use:ERed.substing. - Qed. - - Lemma app_inv (a0 b0 C : PTm) : - rtc ERed.R (PApp a0 b0) C -> - exists a1 b1, C = PApp a1 b1 /\ - rtc ERed.R a0 a1 /\ - rtc ERed.R b0 b1. - Proof. - move E : (PApp a0 b0) => u hu. - move : a0 b0 E. - elim : u C / hu. - - hauto lq:on ctrs:rtc. - - move => a0 a1 a2 ha ha0 iha b0 b1 ?. subst. - inversion ha; subst; spec_refl; - hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R. - Qed. - - Lemma proj_inv p (a C : PTm) : - rtc ERed.R (PProj p a) C -> - exists c, C = PProj p c /\ rtc ERed.R a c. - Proof. - move E : (PProj p a) => u hu. - move : p a E. - elim : u C /hu; - scrush ctrs:rtc,ERed.R inv:ERed.R. - Qed. - - Lemma bind_inv p (A : PTm) B C : - rtc ERed.R (PBind p A B) C -> - exists A0 B0, C = PBind p A0 B0 /\ rtc ERed.R A A0 /\ rtc ERed.R B B0. - Proof. - move E : (PBind p A B) => u hu. - move : p A B E. - elim : u C / hu. - hauto lq:on ctrs:rtc. - hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. - Qed. - - Lemma suc_inv (a : PTm) C : - rtc ERed.R (PSuc a) C -> - exists b, rtc ERed.R a b /\ C = PSuc b. - Proof. - move E : (PSuc a) => u hu. - move : a E. - elim : u C / hu=>//=. - - hauto l:on. - - hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. - Qed. - - Lemma zero_inv (C : PTm) : - rtc ERed.R PZero C -> C = PZero. - move E : PZero => u hu. - move : E. elim : u C /hu=>//=. - - hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. - Qed. - - Lemma ind_inv P (a : PTm) b c C : - rtc ERed.R (PInd P a b c) C -> - exists P0 a0 b0 c0, rtc ERed.R P P0 /\ rtc ERed.R a a0 /\ - rtc ERed.R b b0 /\ rtc ERed.R c c0 /\ - C = PInd P0 a0 b0 c0. - Proof. - move E : (PInd P a b c) => u hu. - move : P a b c E. - elim : u C / hu. - - hauto lq:on ctrs:rtc. - - scrush ctrs:rtc, ERed.R inv:ERed.R, rtc. - Qed. - End EReds. #[export]Hint Constructors ERed.R RRed.R EPar.R : red. -Module EJoin. - Definition R (a b : PTm) := exists c, rtc ERed.R a c /\ rtc ERed.R b c. - - Lemma hne_app_inj (a0 b0 a1 b1 : PTm) : - R (PApp a0 b0) (PApp a1 b1) -> - R a0 a1 /\ R b0 b1. - Proof. - hauto lq:on use:EReds.app_inv. - Qed. - - Lemma hne_proj_inj p0 p1 (a0 a1 : PTm) : - R (PProj p0 a0) (PProj p1 a1) -> - p0 = p1 /\ R a0 a1. - Proof. - hauto lq:on rew:off use:EReds.proj_inv. - Qed. - - Lemma bind_inj p0 p1 (A0 A1 : PTm) B0 B1 : - R (PBind p0 A0 B0) (PBind p1 A1 B1) -> - p0 = p1 /\ R A0 A1 /\ R B0 B1. - Proof. - hauto lq:on rew:off use:EReds.bind_inv. - Qed. - - Lemma suc_inj (A0 A1 : PTm) : - R (PSuc A0) (PSuc A1) -> - R A0 A1. - Proof. - hauto lq:on rew:off use:EReds.suc_inv. - Qed. - - Lemma ind_inj P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : - R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) -> - R P0 P1 /\ R a0 a1 /\ R b0 b1 /\ R c0 c1. - Proof. hauto q:on use:EReds.ind_inv. Qed. - -End EJoin. Module RERed. - Inductive R : PTm -> PTm -> Prop := + Inductive R {n} : PTm n -> PTm n -> Prop := (****************** Beta ***********************) | AppAbs a b : R (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -2117,12 +1543,6 @@ Module RERed. | ProjPair p a b : R (PProj p (PPair a b)) (if p is PL then a else b) - | IndZero P b c : - R (PInd P PZero b c) b - - | IndSuc P a b c : - R (PInd P (PSuc a) b c) (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) - (****************** Eta ***********************) | AppEta a : R (PAbs (PApp (ren_PTm shift a) (VarPTm var_zero))) a @@ -2153,309 +1573,92 @@ Module RERed. R (PBind p A0 B) (PBind p A1 B) | BindCong1 p A B0 B1 : R B0 B1 -> - R (PBind p A B0) (PBind p A B1) - | IndCong0 P0 P1 a b c : - R P0 P1 -> - R (PInd P0 a b c) (PInd P1 a b c) - | IndCong1 P a0 a1 b c : - R a0 a1 -> - R (PInd P a0 b c) (PInd P a1 b c) - | IndCong2 P a b0 b1 c : - R b0 b1 -> - R (PInd P a b0 c) (PInd P a b1 c) - | IndCong3 P a b c0 c1 : - R c0 c1 -> - R (PInd P a b c0) (PInd P a b c1) - | SucCong a0 a1 : - R a0 a1 -> - R (PSuc a0) (PSuc a1). + R (PBind p A B0) (PBind p A B1). - Lemma ToBetaEta (a b : PTm) : + Lemma ToBetaEta n (a b : PTm n) : R a b -> ERed.R a b \/ RRed.R a b. Proof. induction 1; hauto lq:on db:red. Qed. - Lemma FromBeta (a b : PTm) : + Lemma FromBeta n (a b : PTm n) : RRed.R a b -> RERed.R a b. Proof. induction 1; qauto l:on ctrs:R. Qed. - Lemma FromEta (a b : PTm) : + Lemma FromEta n (a b : PTm n) : ERed.R a b -> RERed.R a b. Proof. induction 1; qauto l:on ctrs:R. Qed. - Lemma ToBetaEtaPar (a b : PTm) : + Lemma ToBetaEtaPar n (a b : PTm n) : R a b -> EPar.R a b \/ RRed.R a b. Proof. hauto q:on use:ERed.ToEPar, ToBetaEta. Qed. - Lemma sn_preservation (a b : PTm) : + Lemma sn_preservation n (a b : PTm n) : R a b -> SN a -> SN b. Proof. hauto q:on use:ToBetaEtaPar, epar_sn_preservation, red_sn_preservation, RPar.FromRRed. Qed. - Lemma bind_preservation (a b : PTm) : - R a b -> isbind a -> isbind b. - Proof. hauto q:on inv:R. Qed. - - Lemma univ_preservation (a b : PTm) : - R a b -> isuniv a -> isuniv b. - Proof. hauto q:on inv:R. Qed. - - Lemma nat_preservation (a b : PTm) : - R a b -> isnat a -> isnat b. - Proof. hauto q:on inv:R. Qed. - - Lemma sne_preservation (a b : PTm) : - R a b -> SNe a -> SNe b. - Proof. - hauto q:on use:ToBetaEtaPar, RPar.FromRRed use:red_sn_preservation, epar_sn_preservation. - Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - RERed.R a b -> RERed.R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. - hauto q:on use:ToBetaEta, FromBeta, FromEta, RRed.substing, ERed.substing. - Qed. - - Lemma hne_preservation (a b : PTm) : - RERed.R a b -> ishne a -> ishne b. - Proof. induction 1; sfirstorder. Qed. - End RERed. Module REReds. - Lemma hne_preservation (a b : PTm) : - rtc RERed.R a b -> ishne a -> ishne b. - Proof. induction 1; eauto using RERed.hne_preservation, rtc_refl, rtc. Qed. - - Lemma sn_preservation (a b : PTm) : + Lemma sn_preservation n (a b : PTm n) : rtc RERed.R a b -> SN a -> SN b. Proof. induction 1; eauto using RERed.sn_preservation. Qed. - Lemma FromRReds (a b : PTm) : + Lemma FromRReds n (a b : PTm n) : rtc RRed.R a b -> rtc RERed.R a b. Proof. induction 1; hauto lq:on ctrs:rtc use:RERed.FromBeta. Qed. - Lemma FromEReds (a b : PTm) : + Lemma FromEReds n (a b : PTm n) : rtc ERed.R a b -> rtc RERed.R a b. Proof. induction 1; hauto lq:on ctrs:rtc use:RERed.FromEta. Qed. #[local]Ltac solve_s_rec := - move => *; eapply rtc_l; eauto; - hauto lq:on ctrs:RERed.R. + move => *; eapply rtc_l; eauto; + hauto lq:on ctrs:RERed.R. #[local]Ltac solve_s := repeat (induction 1; last by solve_s_rec); apply rtc_refl. - Lemma AbsCong (a b : PTm) : + Lemma AbsCong n (a b : PTm (S n)) : rtc RERed.R a b -> rtc RERed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong (a0 a1 b0 b1 : PTm) : + Lemma AppCong n (a0 a1 b0 b1 : PTm n) : rtc RERed.R a0 a1 -> rtc RERed.R b0 b1 -> rtc RERed.R (PApp a0 b0) (PApp a1 b1). Proof. solve_s. Qed. - Lemma PairCong (a0 a1 b0 b1 : PTm) : + Lemma PairCong n (a0 a1 b0 b1 : PTm n) : rtc RERed.R a0 a1 -> rtc RERed.R b0 b1 -> rtc RERed.R (PPair a0 b0) (PPair a1 b1). Proof. solve_s. Qed. - Lemma ProjCong p (a0 a1 : PTm) : + Lemma ProjCong n p (a0 a1 : PTm n) : rtc RERed.R a0 a1 -> rtc RERed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma SucCong (a0 a1 : PTm) : - rtc RERed.R a0 a1 -> - rtc RERed.R (PSuc a0) (PSuc a1). - Proof. solve_s. Qed. - - Lemma IndCong P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : - rtc RERed.R P0 P1 -> - rtc RERed.R a0 a1 -> - rtc RERed.R b0 b1 -> - rtc RERed.R c0 c1 -> - rtc RERed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). - Proof. solve_s. Qed. - - Lemma BindCong p (A0 A1 : PTm) B0 B1 : + Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : rtc RERed.R A0 A1 -> rtc RERed.R B0 B1 -> rtc RERed.R (PBind p A0 B0) (PBind p A1 B1). Proof. solve_s. Qed. - Lemma bind_preservation (a b : PTm) : - rtc RERed.R a b -> isbind a -> isbind b. - Proof. induction 1; qauto l:on ctrs:rtc use:RERed.bind_preservation. Qed. - - Lemma univ_preservation (a b : PTm) : - rtc RERed.R a b -> isuniv a -> isuniv b. - Proof. induction 1; qauto l:on ctrs:rtc use:RERed.univ_preservation. Qed. - - Lemma nat_preservation (a b : PTm) : - rtc RERed.R a b -> isnat a -> isnat b. - Proof. induction 1; qauto l:on ctrs:rtc use:RERed.nat_preservation. Qed. - - Lemma sne_preservation (a b : PTm) : - rtc RERed.R a b -> SNe a -> SNe b. - Proof. induction 1; qauto l:on ctrs:rtc use:RERed.sne_preservation. Qed. - - Lemma bind_inv p A B C : - rtc RERed.R(PBind p A B) C -> - exists A0 B0, C = PBind p A0 B0 /\ rtc RERed.R A A0 /\ rtc RERed.R B B0. - Proof. - move E : (PBind p A B) => u hu. - move : p A B E. - elim : u C / hu; sauto lq:on rew:off. - Qed. - - Lemma univ_inv i C : - rtc RERed.R (PUniv i) C -> - C = PUniv i. - Proof. - move E : (PUniv i) => u hu. - move : i E. elim : u C / hu=>//=. - hauto lq:on rew:off ctrs:rtc inv:RERed.R. - Qed. - - Lemma var_inv (i : nat) C : - rtc RERed.R (VarPTm i) C -> - C = VarPTm i. - Proof. - move E : (VarPTm i) => u hu. - move : i E. elim : u C /hu; hauto lq:on rew:off inv:RERed.R. - Qed. - - Lemma hne_app_inv (a0 b0 C : PTm) : - rtc RERed.R (PApp a0 b0) C -> - ishne a0 -> - exists a1 b1, C = PApp a1 b1 /\ - rtc RERed.R a0 a1 /\ - rtc RERed.R b0 b1. - Proof. - move E : (PApp a0 b0) => u hu. - move : a0 b0 E. - elim : u C / hu. - - hauto lq:on ctrs:rtc. - - move => a b c ha0 ha1 iha a0 b0 ?. subst. - hauto lq:on rew:off ctrs:rtc, RERed.R use:RERed.hne_preservation inv:RERed.R. - Qed. - - Lemma hne_proj_inv p (a C : PTm) : - rtc RERed.R (PProj p a) C -> - ishne a -> - exists c, C = PProj p c /\ rtc RERed.R a c. - Proof. - move E : (PProj p a) => u hu. - move : p a E. - elim : u C /hu => //=; - scrush ctrs:rtc,RERed.R use:RERed.hne_preservation inv:RERed.R. - Qed. - - Lemma hne_ind_inv P a b c (C : PTm) : - rtc RERed.R (PInd P a b c) C -> ishne a -> - exists P0 a0 b0 c0, C = PInd P0 a0 b0 c0 /\ - rtc RERed.R P P0 /\ - rtc RERed.R a a0 /\ - rtc RERed.R b b0 /\ - rtc RERed.R c c0. - Proof. - move E : (PInd P a b c) => u hu. - move : P a b c E. - elim : u C / hu => //=; - scrush ctrs:rtc,RERed.R use:RERed.hne_preservation inv:RERed.R. - Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - rtc RERed.R a b -> rtc RERed.R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. - induction 1; hauto lq:on ctrs:rtc use:RERed.substing. - Qed. - - - Lemma cong_up (ρ0 ρ1 : nat -> PTm) : - (forall i, rtc RERed.R (ρ0 i) (ρ1 i)) -> - (forall i, rtc RERed.R (up_PTm_PTm ρ0 i) (up_PTm_PTm ρ1 i)). - Proof. move => h [|i]; cycle 1. - simpl. rewrite /funcomp. - substify. by apply substing. - apply rtc_refl. - Qed. - - Lemma cong_up2 (ρ0 ρ1 : nat -> PTm) : - (forall i, rtc RERed.R (ρ0 i) (ρ1 i)) -> - (forall i, rtc RERed.R (up_PTm_PTm (up_PTm_PTm ρ0) i) (up_PTm_PTm (up_PTm_PTm ρ1) i)). - Proof. hauto l:on use:cong_up. Qed. - - Lemma cong (a : PTm) (ρ0 ρ1 : nat -> PTm) : - (forall i, rtc RERed.R (ρ0 i) (ρ1 i)) -> - rtc RERed.R (subst_PTm ρ0 a) (subst_PTm ρ1 a). - Proof. - move : ρ0 ρ1. elim : a => /=; - eauto 20 using AppCong, AbsCong, BindCong, ProjCong, PairCong, cong_up, rtc_refl, IndCong, SucCong, cong_up2. - Qed. - - Lemma cong' (a b : PTm) (ρ0 ρ1 : nat -> PTm) : - rtc RERed.R a b -> - (forall i, rtc RERed.R (ρ0 i) (ρ1 i)) -> - rtc RERed.R (subst_PTm ρ0 a) (subst_PTm ρ1 b). - Proof. - move => h0 h1. - have : rtc RERed.R (subst_PTm ρ0 a) (subst_PTm ρ1 a) by eauto using cong. - move => ?. apply : relations.rtc_transitive; eauto. - hauto l:on use:substing. - Qed. - - Lemma ToEReds (a b : PTm) : - nf a -> - rtc RERed.R a b -> rtc ERed.R a b. - Proof. - move => + h. - induction h; hauto lq:on rew:off ctrs:rtc use:RERed.ToBetaEta, RReds.nf_refl, @rtc_once, ERed.nf_preservation. - Qed. - - Lemma zero_inv (C : PTm) : - rtc RERed.R PZero C -> C = PZero. - move E : PZero => u hu. - move : E. elim : u C /hu=>//=. - - hauto lq:on rew:off ctrs:rtc, RERed.R inv:RERed.R, rtc. - Qed. - - Lemma suc_inv (a : PTm) C : - rtc RERed.R (PSuc a) C -> - exists b, rtc RERed.R a b /\ C = PSuc b. - Proof. - move E : (PSuc a) => u hu. - move : a E. - elim : u C / hu=>//=. - - hauto l:on. - - hauto lq:on rew:off ctrs:rtc, RERed.R inv:RERed.R, rtc. - Qed. - - Lemma nat_inv C : - rtc RERed.R PNat C -> - C = PNat. - Proof. - move E : PNat => u hu. move : E. - elim : u C / hu=>//=. - hauto lq:on rew:off ctrs:rtc, RERed.R inv:RERed.R. - Qed. - End REReds. Module LoRed. - Inductive R : PTm -> PTm -> Prop := + Inductive R {n} : PTm n -> PTm n -> Prop := (****************** Beta ***********************) | AppAbs a b : R (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -2463,13 +1666,6 @@ Module LoRed. | ProjPair p a b : R (PProj p (PPair a b)) (if p is PL then a else b) - | IndZero P b c : - R (PInd P PZero b c) b - - | IndSuc P a b c : - R (PInd P (PSuc a) b c) (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) - - (*************** Congruence ********************) | AbsCong a0 a1 : R a0 a1 -> @@ -2499,69 +1695,25 @@ Module LoRed. | BindCong1 p A B0 B1 : nf A -> R B0 B1 -> - R (PBind p A B0) (PBind p A B1) - | IndCong0 P0 P1 a b c : - ne a -> - R P0 P1 -> - R (PInd P0 a b c) (PInd P1 a b c) - | IndCong1 P a0 a1 b c : - ~~ ishf a0 -> - R a0 a1 -> - R (PInd P a0 b c) (PInd P a1 b c) - | IndCong2 P a b0 b1 c : - nf P -> - ne a -> - R b0 b1 -> - R (PInd P a b0 c) (PInd P a b1 c) - | IndCong3 P a b c0 c1 : - nf P -> - ne a -> - nf b -> - R c0 c1 -> - R (PInd P a b c0) (PInd P a b c1) - | SucCong a0 a1 : - R a0 a1 -> - R (PSuc a0) (PSuc a1). + R (PBind p A B0) (PBind p A B1). - Lemma hf_preservation (a b : PTm) : + Lemma hf_preservation n (a b : PTm n) : LoRed.R a b -> ishf a -> ishf b. Proof. - move => h. elim : a b /h=>//=. + move => h. elim : n a b /h=>//=. Qed. - Lemma ToRRed (a b : PTm) : + Lemma ToRRed n (a b : PTm n) : LoRed.R a b -> RRed.R a b. Proof. induction 1; hauto lq:on ctrs:RRed.R. Qed. - Lemma AppAbs' a (b : PTm) u : - u = (subst_PTm (scons b VarPTm) a) -> - R (PApp (PAbs a) b) u. - Proof. move => ->. apply AppAbs. Qed. - - Lemma IndSuc' P a b c u : - u = (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) -> - R (@PInd P (PSuc a) b c) u. - Proof. move => ->. apply IndSuc. Qed. - - Lemma renaming (a b : PTm) (ξ : nat -> nat) : - R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). - Proof. - move => h. move : ξ. - elim : a b /h. - - move => a b ξ /=. - apply AppAbs'. by asimpl. - all : try qauto ctrs:R use:ne_nf_ren, ishf_ren. - move => * /=; apply IndSuc'. by asimpl. - Qed. - End LoRed. Module LoReds. - Lemma hf_preservation (a b : PTm) : + Lemma hf_preservation n (a b : PTm n) : rtc LoRed.R a b -> ishf a -> ishf b. @@ -2569,13 +1721,13 @@ Module LoReds. induction 1; eauto using LoRed.hf_preservation. Qed. - Lemma hf_ne_imp (a b : PTm) : + Lemma hf_ne_imp n (a b : PTm n) : rtc LoRed.R a b -> ne b -> ~~ ishf a. Proof. move : hf_preservation. repeat move/[apply]. - case : a; case : b => //=; sfirstorder b:on. + case : a; case : b => //=; itauto. Qed. #[local]Ltac solve_s_rec := @@ -2585,100 +1737,77 @@ Module LoReds. #[local]Ltac solve_s := repeat (induction 1; last by solve_s_rec); (move => *; apply rtc_refl). - Lemma AbsCong (a b : PTm) : + Lemma AbsCong n (a b : PTm (S n)) : rtc LoRed.R a b -> rtc LoRed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong (a0 a1 b0 b1 : PTm) : + Lemma AppCong n (a0 a1 b0 b1 : PTm n) : rtc LoRed.R a0 a1 -> rtc LoRed.R b0 b1 -> ne a1 -> rtc LoRed.R (PApp a0 b0) (PApp a1 b1). Proof. solve_s. Qed. - Lemma PairCong (a0 a1 b0 b1 : PTm) : + Lemma PairCong n (a0 a1 b0 b1 : PTm n) : rtc LoRed.R a0 a1 -> rtc LoRed.R b0 b1 -> nf a1 -> rtc LoRed.R (PPair a0 b0) (PPair a1 b1). Proof. solve_s. Qed. - Lemma ProjCong p (a0 a1 : PTm) : + Lemma ProjCong n p (a0 a1 : PTm n) : rtc LoRed.R a0 a1 -> ne a1 -> rtc LoRed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma BindCong p (A0 A1 : PTm) B0 B1 : + Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : rtc LoRed.R A0 A1 -> rtc LoRed.R B0 B1 -> nf A1 -> rtc LoRed.R (PBind p A0 B0) (PBind p A1 B1). Proof. solve_s. Qed. - Lemma IndCong P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : - rtc LoRed.R a0 a1 -> - rtc LoRed.R P0 P1 -> - rtc LoRed.R b0 b1 -> - rtc LoRed.R c0 c1 -> - ne a1 -> - nf P1 -> - nf b1 -> - rtc LoRed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). - Proof. solve_s. Qed. + Local Ltac triv := simpl in *; itauto. - Lemma SucCong (a0 a1 : PTm) : - rtc LoRed.R a0 a1 -> - rtc LoRed.R (PSuc a0) (PSuc a1). - Proof. solve_s. Qed. - - Local Ltac triv := simpl in *; sfirstorder b:on. - - Lemma FromSN_mutual : - (forall (a : PTm) (_ : SNe a), exists v, rtc LoRed.R a v /\ ne v) /\ - (forall (a : PTm) (_ : SN a), exists v, rtc LoRed.R a v /\ nf v) /\ - (forall (a b : PTm) (_ : TRedSN a b), LoRed.R a b). + Lemma FromSN_mutual : forall n, + (forall (a : PTm n) (_ : SNe a), exists v, rtc LoRed.R a v /\ ne v) /\ + (forall (a : PTm n) (_ : SN a), exists v, rtc LoRed.R a v /\ nf v) /\ + (forall (a b : PTm n) (_ : TRedSN a b), LoRed.R a b). Proof. apply sn_mutual. - hauto lq:on ctrs:rtc. - hauto lq:on rew:off use:LoReds.AppCong solve+:triv. - hauto l:on use:LoReds.ProjCong solve+:triv. - - hauto lq:on use:LoReds.IndCong solve+:triv. + - hauto lq:on ctrs:rtc. - hauto q:on use:LoReds.PairCong solve+:triv. - hauto q:on use:LoReds.AbsCong solve+:triv. - sfirstorder use:ne_nf. - hauto lq:on ctrs:rtc. - hauto lq:on use:LoReds.BindCong solve+:triv. - hauto lq:on ctrs:rtc. - - hauto lq:on ctrs:rtc. - - hauto lq:on ctrs:rtc. - - hauto l:on use:SucCong. - qauto ctrs:LoRed.R. - - move => a0 a1 b hb ihb h. + - move => n a0 a1 b hb ihb h. have : ~~ ishf a0 by inversion h. hauto lq:on ctrs:LoRed.R. - qauto ctrs:LoRed.R. - qauto ctrs:LoRed.R. - - move => p a b h. + - move => n p a b h. have : ~~ ishf a by inversion h. hauto lq:on ctrs:LoRed.R. - - sfirstorder. - - sfirstorder. - - move => P a0 a1 b c hP ihP hb ihb hc ihc hr. - have : ~~ ishf a0 by inversion hr. - hauto q:on ctrs:LoRed.R. Qed. - Lemma FromSN : forall a, SN a -> exists v, rtc LoRed.R a v /\ nf v. + Lemma FromSN : forall n a, @SN n a -> exists v, rtc LoRed.R a v /\ nf v. Proof. firstorder using FromSN_mutual. Qed. - Lemma ToRReds : forall (a b : PTm), rtc LoRed.R a b -> rtc RRed.R a b. + Lemma ToRReds : forall n (a b : PTm n), rtc LoRed.R a b -> rtc RRed.R a b. Proof. induction 1; hauto lq:on ctrs:rtc use:LoRed.ToRRed. Qed. + End LoReds. -Fixpoint size_PTm (a : PTm) := +Fixpoint size_PTm {n} (a : PTm n) := match a with | VarPTm _ => 1 | PAbs a => 3 + size_PTm a @@ -2687,39 +1816,36 @@ Fixpoint size_PTm (a : PTm) := | PPair a b => 3 + Nat.add (size_PTm a) (size_PTm b) | PUniv _ => 3 | PBind p A B => 3 + Nat.add (size_PTm A) (size_PTm B) - | PInd P a b c => 3 + size_PTm P + size_PTm a + size_PTm b + size_PTm c - | PNat => 3 - | PSuc a => 3 + size_PTm a - | PZero => 3 + | PBot => 1 end. -Lemma size_PTm_ren (ξ : nat -> nat) a : size_PTm (ren_PTm ξ a) = size_PTm a. +Lemma size_PTm_ren n m (ξ : fin n -> fin m) a : size_PTm (ren_PTm ξ a) = size_PTm a. Proof. - move : ξ. elim : a => //=; scongruence. + move : m ξ. elim : n / a => //=; scongruence. Qed. #[export]Hint Rewrite size_PTm_ren : sizetm. -Lemma ered_size (a b : PTm) : +Lemma ered_size {n} (a b : PTm n) : ERed.R a b -> size_PTm b < size_PTm a. Proof. - move => h. elim : a b /h; try hauto l:on rew:db:sizetm solve+:lia. + move => h. elim : n a b /h; hauto l:on rew:db:sizetm. Qed. -Lemma ered_sn (a : PTm) : sn ERed.R a. +Lemma ered_sn n (a : PTm n) : sn ERed.R a. Proof. hauto lq:on rew:off use:size_PTm_ren, ered_size, well_founded_lt_compat unfold:well_founded. Qed. -Lemma ered_local_confluence (a b c : PTm) : +Lemma ered_local_confluence n (a b c : PTm n) : ERed.R a b -> ERed.R a c -> exists d, rtc ERed.R b d /\ rtc ERed.R c d. Proof. move => h. move : c. - elim : a b / h. + elim : n a b / h => n. - move => a c. elim /ERed.inv => //= _. + move => a0 [+ ?]. subst => h. @@ -2780,46 +1906,10 @@ Proof. hauto lq:on ctrs:rtc use:EReds.BindCong. - move => p A B0 B1 hB ihB u. elim /ERed.inv => //=_; - hauto lq:on ctrs:rtc use:EReds.BindCong. - - move => P0 P1 a b c hP ihP u. - elim /ERed.inv => //=_. - + move => P2 P3 a0 b0 c0 hP' [*]. subst. - move : ihP hP' => /[apply]. move => [P4][hP0]hP1. - eauto using EReds.IndCong, rtc_refl. - + move => P2 a0 a1 b0 c0 + [*]. subst. - eauto 20 using rtc_refl, EReds.IndCong, rtc_l. - + move => P2 a0 b0 b1 c0 hb [*] {ihP}. subst. - eauto 20 using rtc_refl, EReds.IndCong, rtc_l. - + move => P2 a0 b0 c0 c1 h [*] {ihP}. subst. - eauto 20 using rtc_refl, EReds.IndCong, rtc_l. - - move => P a0 a1 b c ha iha u. - elim /ERed.inv => //=_; - try solve [move => P0 P1 a2 b0 c0 hP[*]; subst; - eauto 20 using rtc_refl, EReds.IndCong, rtc_l]. - move => P0 P1 a2 b0 c0 hP[*]. subst. - move : iha hP => /[apply]. - move => [? [*]]. - eauto 20 using rtc_refl, EReds.IndCong, rtc_l. - - move => P a b0 b1 c hb ihb u. - elim /ERed.inv => //=_; - try solve [ - move => P0 P1 a0 b2 c0 hP [*]; subst; - eauto 20 using rtc_refl, EReds.IndCong, rtc_l]. - move => P0 a0 b2 b3 c0 h [*]. subst. - move : ihb h => /[apply]. move => [b2 [*]]. - eauto 20 using rtc_refl, EReds.IndCong, rtc_l. - - move => P a b c0 c1 hc ihc u. - elim /ERed.inv => //=_; - try solve [ - move => P0 P1 a0 b0 c hP [*]; subst; - eauto 20 using rtc_refl, EReds.IndCong, rtc_l]. - move => P0 a0 b0 c2 c3 h [*]. subst. - move : ihc h => /[apply]. move => [c2][*]. - eauto 20 using rtc_refl, EReds.IndCong, rtc_l. - - qauto l:on inv:ERed.R ctrs:rtc use:EReds.SucCong. + hauto lq:on ctrs:rtc use:EReds.BindCong. Qed. -Lemma ered_confluence (a b c : PTm) : +Lemma ered_confluence n (a b c : PTm n) : rtc ERed.R a b -> rtc ERed.R a c -> exists d, rtc ERed.R b d /\ rtc ERed.R c d. @@ -2827,18 +1917,18 @@ Proof. sfirstorder use:relations.locally_confluent_confluent, ered_sn, ered_local_confluence. Qed. -Lemma red_confluence (a b c : PTm) : +Lemma red_confluence n (a b c : PTm n) : rtc RRed.R a b -> rtc RRed.R a c -> exists d, rtc RRed.R b d /\ rtc RRed.R c d. - suff : rtc RPar.R a b -> rtc RPar.R a c -> exists d : PTm, rtc RPar.R b d /\ rtc RPar.R c d + suff : rtc RPar.R a b -> rtc RPar.R a c -> exists d : PTm n, rtc RPar.R b d /\ rtc RPar.R c d by hauto lq:on use:RReds.RParIff. apply relations.diamond_confluent. rewrite /relations.diamond. eauto using RPar.diamond. Qed. -Lemma red_uniquenf (a b c : PTm) : +Lemma red_uniquenf n (a b c : PTm n) : rtc RRed.R a b -> rtc RRed.R a c -> nf b -> @@ -2853,20 +1943,20 @@ Proof. Qed. Module NeEPars. - Lemma R_nonelim_nf (a b : PTm) : + Lemma R_nonelim_nf n (a b : PTm n) : rtc NeEPar.R_nonelim a b -> nf b -> nf a. Proof. induction 1; sfirstorder use:NeEPar.R_elim_nf. Qed. - Lemma ToEReds : (forall (a b : PTm), rtc NeEPar.R_nonelim a b -> rtc ERed.R a b). + Lemma ToEReds : forall n, (forall (a b : PTm n), rtc NeEPar.R_nonelim a b -> rtc ERed.R a b). Proof. induction 1; hauto l:on use:NeEPar.ToEPar, EReds.FromEPar, @relations.rtc_transitive. Qed. End NeEPars. -Lemma rered_standardization (a c : PTm) : +Lemma rered_standardization n (a c : PTm n) : SN a -> rtc RERed.R a c -> exists b, rtc RRed.R a b /\ rtc NeEPar.R_nonelim b c. @@ -2883,7 +1973,7 @@ Proof. - hauto lq:on ctrs:rtc use:red_sn_preservation, RPar.FromRRed. Qed. -Lemma rered_confluence (a b c : PTm) : +Lemma rered_confluence n (a b c : PTm n) : SN a -> rtc RERed.R a b -> rtc RERed.R a c -> @@ -2915,52 +2005,17 @@ Proof. move /REReds.FromRReds : hc0. move /REReds.FromEReds : hv'. eauto using relations.rtc_transitive. Qed. -(* Beta joinability *) -Module BJoin. - Definition R (a b : PTm) := exists c, rtc RRed.R a c /\ rtc RRed.R b c. - Lemma refl (a : PTm) : R a a. - Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - - Lemma symmetric (a b : PTm) : R a b -> R b a. - Proof. sfirstorder unfold:R. Qed. - - Lemma transitive (a b c : PTm) : R a b -> R b c -> R a c. - Proof. - rewrite /R. - move => [ab [ha +]] [bc [+ hc]]. - move : red_confluence; repeat move/[apply]. - move => [v [h0 h1]]. - exists v. sfirstorder use:@relations.rtc_transitive. - Qed. - - (* Lemma AbsCong n (a b : PTm (S n)) : *) - (* R a b -> *) - (* R (PAbs a) (PAbs b). *) - (* Proof. hauto lq:on use:RReds.AbsCong unfold:R. Qed. *) - - (* Lemma AppCong n (a0 a1 b0 b1 : PTm) : *) - (* R a0 a1 -> *) - (* R b0 b1 -> *) - (* R (PApp a0 b0) (PApp a1 b1). *) - (* Proof. hauto lq:on use:RReds.AppCong unfold:R. Qed. *) -End BJoin. - +(* "Declarative" Joinability *) Module DJoin. - Definition R (a b : PTm) := exists c, rtc RERed.R a c /\ rtc RERed.R b c. + Definition R {n} (a b : PTm n) := exists c, rtc RERed.R a c /\ rtc RERed.R b c. - Lemma refl (a : PTm) : R a a. + Lemma refl n (a : PTm n) : R a a. Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma FromEJoin (a b : PTm) : EJoin.R a b -> DJoin.R a b. - Proof. hauto q:on use:REReds.FromEReds. Qed. - - Lemma ToEJoin (a b : PTm) : nf a -> nf b -> DJoin.R a b -> EJoin.R a b. - Proof. hauto q:on use:REReds.ToEReds. Qed. - - Lemma symmetric (a b : PTm) : R a b -> R b a. + Lemma symmetric n (a b : PTm n) : R a b -> R b a. Proof. sfirstorder unfold:R. Qed. - Lemma transitive (a b c : PTm) : SN b -> R a b -> R b c -> R a c. + Lemma transitive n (a b c : PTm n) : SN b -> R a b -> R b c -> R a c. Proof. rewrite /R. move => + [ab [ha +]] [bc [+ hc]]. @@ -2969,725 +2024,26 @@ Module DJoin. exists v. sfirstorder use:@relations.rtc_transitive. Qed. - Lemma AbsCong (a b : PTm) : + Lemma AbsCong n (a b : PTm (S n)) : R a b -> R (PAbs a) (PAbs b). Proof. hauto lq:on use:REReds.AbsCong unfold:R. Qed. - Lemma AppCong (a0 a1 b0 b1 : PTm) : + Lemma AppCong n (a0 a1 b0 b1 : PTm n) : R a0 a1 -> R b0 b1 -> R (PApp a0 b0) (PApp a1 b1). Proof. hauto lq:on use:REReds.AppCong unfold:R. Qed. - Lemma PairCong (a0 a1 b0 b1 : PTm) : + Lemma PairCong n (a0 a1 b0 b1 : PTm n) : R a0 a1 -> R b0 b1 -> R (PPair a0 b0) (PPair a1 b1). Proof. hauto q:on use:REReds.PairCong. Qed. - Lemma ProjCong p (a0 a1 : PTm) : + Lemma ProjCong n p (a0 a1 : PTm n) : R a0 a1 -> R (PProj p a0) (PProj p a1). Proof. hauto q:on use:REReds.ProjCong. Qed. - Lemma BindCong p (A0 A1 : PTm) B0 B1 : - R A0 A1 -> - R B0 B1 -> - R (PBind p A0 B0) (PBind p A1 B1). - Proof. hauto q:on use:REReds.BindCong. Qed. - - Lemma IndCong P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : - R P0 P1 -> - R a0 a1 -> - R b0 b1 -> - R c0 c1 -> - R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). - Proof. hauto q:on use:REReds.IndCong. Qed. - - Lemma SucCong (a0 a1 : PTm) : - R a0 a1 -> - R (PSuc a0) (PSuc a1). - Proof. qauto l:on use:REReds.SucCong. Qed. - - Lemma FromRedSNs (a b : PTm) : - rtc TRedSN a b -> - R a b. - Proof. - move /RReds.FromRedSNs /REReds.FromRReds. - sfirstorder use:@rtc_refl unfold:R. - Qed. - - Lemma sne_nat_noconf (a b : PTm) : - R a b -> SNe a -> isnat b -> False. - Proof. - move => [c [? ?]] *. - have : SNe c /\ isnat c by sfirstorder use:REReds.sne_preservation, REReds.nat_preservation. - qauto l:on inv:SNe. - Qed. - - Lemma sne_bind_noconf (a b : PTm) : - R a b -> SNe a -> isbind b -> False. - Proof. - move => [c [? ?]] *. - have : SNe c /\ isbind c by sfirstorder use:REReds.sne_preservation, REReds.bind_preservation. - qauto l:on inv:SNe. - Qed. - - Lemma sne_univ_noconf (a b : PTm) : - R a b -> SNe a -> isuniv b -> False. - Proof. - hauto q:on use:REReds.sne_preservation, - REReds.univ_preservation inv:SNe. - Qed. - - Lemma bind_univ_noconf (a b : PTm) : - R a b -> isbind a -> isuniv b -> False. - Proof. - move => [c [h0 h1]] h2 h3. - have {h0 h1 h2 h3} : isbind c /\ isuniv c by - hauto l:on use:REReds.bind_preservation, - REReds.univ_preservation. - case : c => //=; sfirstorder b:on. - Qed. - - Lemma hne_univ_noconf (a b : PTm) : - R a b -> ishne a -> isuniv b -> False. - Proof. - move => [c [h0 h1]] h2 h3. - have {h0 h1 h2 h3} : ishne c /\ isuniv c by - hauto l:on use:REReds.hne_preservation, - REReds.univ_preservation. - move => []. - case : c => //=. - Qed. - - Lemma hne_bind_noconf (a b : PTm) : - R a b -> ishne a -> isbind b -> False. - Proof. - move => [c [h0 h1]] h2 h3. - have {h0 h1 h2 h3} : ishne c /\ isbind c by - hauto l:on use:REReds.hne_preservation, - REReds.bind_preservation. - move => []. - case : c => //=. - Qed. - - Lemma hne_nat_noconf (a b : PTm) : - R a b -> ishne a -> isnat b -> False. - Proof. - move => [c [h0 h1]] h2 h3. - have : ishne c /\ isnat c by sfirstorder use:REReds.hne_preservation, REReds.nat_preservation. - clear. case : c => //=; sfirstorder b:on. - Qed. - - Lemma bind_inj p0 p1 (A0 A1 : PTm) B0 B1 : - DJoin.R (PBind p0 A0 B0) (PBind p1 A1 B1) -> - p0 = p1 /\ DJoin.R A0 A1 /\ DJoin.R B0 B1. - Proof. - rewrite /R. - hauto lq:on rew:off use:REReds.bind_inv. - Qed. - - Lemma var_inj (i j : nat) : - R (VarPTm i) (VarPTm j) -> i = j. - Proof. sauto lq:on rew:off use:REReds.var_inv unfold:R. Qed. - - Lemma univ_inj i j : - @R (PUniv i) (PUniv j) -> i = j. - Proof. - sauto lq:on rew:off use:REReds.univ_inv. - Qed. - - Lemma suc_inj (A0 A1 : PTm) : - R (PSuc A0) (PSuc A1) -> - R A0 A1. - Proof. - hauto lq:on rew:off use:REReds.suc_inv. - Qed. - - Lemma hne_app_inj (a0 b0 a1 b1 : PTm) : - R (PApp a0 b0) (PApp a1 b1) -> - ishne a0 -> - ishne a1 -> - R a0 a1 /\ R b0 b1. - Proof. - hauto lq:on use:REReds.hne_app_inv. - Qed. - - Lemma hne_proj_inj p0 p1 (a0 a1 : PTm) : - R (PProj p0 a0) (PProj p1 a1) -> - ishne a0 -> - ishne a1 -> - p0 = p1 /\ R a0 a1. - Proof. - sauto lq:on use:REReds.hne_proj_inv. - Qed. - - Lemma FromRRed0 (a b : PTm) : - RRed.R a b -> R a b. - Proof. - hauto lq:on ctrs:rtc use:RERed.FromBeta unfold:R. - Qed. - - Lemma FromRRed1 (a b : PTm) : - RRed.R b a -> R a b. - Proof. - hauto lq:on ctrs:rtc use:RERed.FromBeta unfold:R. - Qed. - - Lemma FromRReds (a b : PTm) : - rtc RRed.R b a -> R a b. - Proof. - hauto lq:on ctrs:rtc use:REReds.FromRReds unfold:R. - Qed. - - Lemma FromBJoin (a b : PTm) : - BJoin.R a b -> R a b. - Proof. - hauto lq:on ctrs:rtc use:REReds.FromRReds unfold:R, BJoin.R. - Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. - hauto lq:on rew:off ctrs:rtc unfold:R use:REReds.substing. - Qed. - - Lemma renaming (a b : PTm) (ρ : nat -> nat) : - R a b -> R (ren_PTm ρ a) (ren_PTm ρ b). - Proof. substify. apply substing. Qed. - - Lemma weakening (a b : PTm) : - R a b -> R (ren_PTm shift a) (ren_PTm shift b). - Proof. apply renaming. Qed. - - Lemma cong (a : PTm) c d (ρ : nat -> PTm) : - R c d -> R (subst_PTm (scons c ρ) a) (subst_PTm (scons d ρ) a). - Proof. - rewrite /R. move => [cd [h0 h1]]. - exists (subst_PTm (scons cd ρ) a). - hauto q:on ctrs:rtc inv:nat use:REReds.cong. - Qed. - - Lemma cong' (a b : PTm) c d (ρ : nat -> PTm) : - R a b -> - R c d -> R (subst_PTm (scons c ρ) a) (subst_PTm (scons d ρ) b). - Proof. - rewrite /R. move => [ab [h2 h3]] [cd [h0 h1]]. - exists (subst_PTm (scons cd ρ) ab). - hauto q:on ctrs:rtc inv:nat use:REReds.cong'. - Qed. - - Lemma pair_inj (a0 a1 b0 b1 : PTm) : - SN (PPair a0 b0) -> - SN (PPair a1 b1) -> - R (PPair a0 b0) (PPair a1 b1) -> - R a0 a1 /\ R b0 b1. - Proof. - move => sn0 sn1. - have [? [? [? ?]]] : SN a0 /\ SN b0 /\ SN a1 /\ SN b1 by sfirstorder use:SN_NoForbid.P_PairInv. - have ? : SN (PProj PL (PPair a0 b0)) by hauto lq:on db:sn. - have ? : SN (PProj PR (PPair a0 b0)) by hauto lq:on db:sn. - have ? : SN (PProj PL (PPair a1 b1)) by hauto lq:on db:sn. - have ? : SN (PProj PR (PPair a1 b1)) by hauto lq:on db:sn. - have h0L : RRed.R (PProj PL (PPair a0 b0)) a0 by eauto with red. - have h0R : RRed.R (PProj PR (PPair a0 b0)) b0 by eauto with red. - have h1L : RRed.R (PProj PL (PPair a1 b1)) a1 by eauto with red. - have h1R : RRed.R (PProj PR (PPair a1 b1)) b1 by eauto with red. - move => h2. - move /ProjCong in h2. - have h2L := h2 PL. - have {h2}h2R := h2 PR. - move /FromRRed1 in h0L. - move /FromRRed0 in h1L. - move /FromRRed1 in h0R. - move /FromRRed0 in h1R. - split; eauto using transitive. - Qed. - - Lemma ejoin_pair_inj (a0 a1 b0 b1 : PTm) : - nf a0 -> nf b0 -> nf a1 -> nf b1 -> - EJoin.R (PPair a0 b0) (PPair a1 b1) -> - EJoin.R a0 a1 /\ EJoin.R b0 b1. - Proof. - move => h0 h1 h2 h3 /FromEJoin. - have [? ?] : SN (PPair a0 b0) /\ SN (PPair a1 b1) by sauto lqb:on rew:off use:ne_nf_embed. - move => ?. - have : R a0 a1 /\ R b0 b1 by hauto l:on use:pair_inj. - hauto l:on use:ToEJoin. - Qed. - - Lemma abs_inj (a0 a1 : PTm) : - SN a0 -> SN a1 -> - R (PAbs a0) (PAbs a1) -> - R a0 a1. - Proof. - move => sn0 sn1. - move /weakening => /=. - move /AppCong. move /(_ (VarPTm var_zero) (VarPTm var_zero)). - move => /(_ ltac:(sfirstorder use:refl)). - move => h. - have /FromRRed1 h0 : RRed.R (PApp (PAbs (ren_PTm (upRen_PTm_PTm shift) a0)) (VarPTm var_zero)) a0. apply RRed.AppAbs'; asimpl. by rewrite subst_scons_id. - have /FromRRed0 h1 : RRed.R (PApp (PAbs (ren_PTm (upRen_PTm_PTm shift) a1)) (VarPTm var_zero)) a1 by - apply RRed.AppAbs'; eauto; by asimpl; rewrite ?subst_scons_id. - have sn0' := sn0. - have sn1' := sn1. - eapply sn_renaming with (ξ := (upRen_PTm_PTm shift)) in sn0. - eapply sn_renaming with (ξ := (upRen_PTm_PTm shift)) in sn1. - apply : transitive; try apply h0. - apply : N_Exp. apply N_β. sauto. - asimpl. by rewrite subst_scons_id. - apply : transitive; try apply h1. - apply : N_Exp. apply N_β. sauto. - by asimpl; rewrite subst_scons_id. - eauto. - Qed. - - Lemma ejoin_abs_inj (a0 a1 : PTm) : - nf a0 -> nf a1 -> - EJoin.R (PAbs a0) (PAbs a1) -> - EJoin.R a0 a1. - Proof. - move => h0 h1. - have [? [? [? ?]]] : SN a0 /\ SN a1 /\ SN (PAbs a0) /\ SN (PAbs a1) by sauto lqb:on rew:off use:ne_nf_embed. - move /FromEJoin. - move /abs_inj. - hauto l:on use:ToEJoin. - Qed. - - Lemma standardization (a b : PTm) : - SN a -> SN b -> R a b -> - exists va vb, rtc RRed.R a va /\ rtc RRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb. - Proof. - move => h0 h1 [ab [hv0 hv1]]. - have hv : SN ab by sfirstorder use:REReds.sn_preservation. - have : exists v, rtc RRed.R ab v /\ nf v by sfirstorder use:LoReds.FromSN, LoReds.ToRReds. - move => [v [hv2 hv3]]. - have : rtc RERed.R a v by hauto q:on use:@relations.rtc_transitive, REReds.FromRReds. - have : rtc RERed.R b v by hauto q:on use:@relations.rtc_transitive, REReds.FromRReds. - move : h0 h1 hv3. clear. - move => h0 h1 hv hbv hav. - move : rered_standardization (h0) hav. repeat move/[apply]. - move => [a1 [ha0 ha1]]. - move : rered_standardization (h1) hbv. repeat move/[apply]. - move => [b1 [hb0 hb1]]. - have [*] : nf a1 /\ nf b1 by sfirstorder use:NeEPars.R_nonelim_nf. - hauto q:on use:NeEPars.ToEReds unfold:EJoin.R. - Qed. - - Lemma standardization_lo (a b : PTm) : - SN a -> SN b -> R a b -> - exists va vb, rtc LoRed.R a va /\ rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb. - Proof. - move => /[dup] sna + /[dup] snb. - move : standardization; repeat move/[apply]. - move => [va][vb][hva][hvb][nfva][nfvb]hj. - move /LoReds.FromSN : sna => [va' [hva' hva'0]]. - move /LoReds.FromSN : snb => [vb' [hvb' hvb'0]]. - exists va', vb'. - repeat split => //=. - have : va = va' /\ vb = vb' by sfirstorder use:red_uniquenf, LoReds.ToRReds. - case; congruence. - Qed. End DJoin. - - -Module Sub1. - Inductive R : PTm -> PTm -> Prop := - | Refl a : - R a a - | Univ i j : - i <= j -> - R (PUniv i) (PUniv j) - | PiCong A0 A1 B0 B1 : - R A1 A0 -> - R B0 B1 -> - R (PBind PPi A0 B0) (PBind PPi A1 B1) - | SigCong A0 A1 B0 B1 : - R A0 A1 -> - R B0 B1 -> - R (PBind PSig A0 B0) (PBind PSig A1 B1). - - Lemma transitive0 (A B C : PTm) : - R A B -> (R B C -> R A C) /\ (R C A -> R C B). - Proof. - move => h. move : C. - elim : A B /h; hauto lq:on ctrs:R inv:R solve+:lia. - Qed. - - Lemma transitive (A B C : PTm) : - R A B -> R B C -> R A C. - Proof. hauto q:on use:transitive0. Qed. - - Lemma refl (A : PTm) : R A A. - Proof. sfirstorder. Qed. - - Lemma commutativity0 (A B C : PTm) : - R A B -> - (RERed.R A C -> - exists D, RERed.R B D /\ R C D) /\ - (RERed.R B C -> - exists D, RERed.R A D /\ R D C). - Proof. - move => h. move : C. - elim : A B / h; hauto lq:on ctrs:RERed.R, R inv:RERed.R. - Qed. - - Lemma commutativity_Ls (A B C : PTm) : - R A B -> - rtc RERed.R A C -> - exists D, rtc RERed.R B D /\ R C D. - Proof. - move => + h. move : B. - induction h; ecrush use:commutativity0. - Qed. - - Lemma commutativity_Rs (A B C : PTm) : - R A B -> - rtc RERed.R B C -> - exists D, rtc RERed.R A D /\ R D C. - Proof. - move => + h. move : A. induction h; ecrush use:commutativity0. - Qed. - - Lemma sn_preservation : - (forall (a : PTm) (s : SNe a), forall b, R a b \/ R b a -> a = b) /\ - (forall (a : PTm) (s : SN a), forall b, R a b \/ R b a -> SN b) /\ - (forall (a b : PTm) (_ : TRedSN a b), forall c, R a c \/ R c a -> a = c). - Proof. - apply sn_mutual; hauto lq:on inv:R ctrs:SN. - Qed. - - Lemma bind_preservation (a b : PTm) : - R a b -> isbind a = isbind b. - Proof. hauto q:on inv:R. Qed. - - Lemma univ_preservation (a b : PTm) : - R a b -> isuniv a = isuniv b. - Proof. hauto q:on inv:R. Qed. - - Lemma sne_preservation (a b : PTm) : - R a b -> SNe a <-> SNe b. - Proof. hfcrush use:sn_preservation. Qed. - - Lemma renaming (a b : PTm) (ξ : nat -> nat) : - R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). - Proof. - move => h. move : ξ. - elim : a b /h; hauto lq:on ctrs:R. - Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. move => h. move : ρ. elim : a b /h; hauto lq:on ctrs:R. Qed. - - Lemma hne_refl (a b : PTm) : - ishne a \/ ishne b -> R a b -> a = b. - Proof. hauto q:on inv:R. Qed. - -End Sub1. - -Module ESub. - Definition R (a b : PTm) := exists c0 c1, rtc ERed.R a c0 /\ rtc ERed.R b c1 /\ Sub1.R c0 c1. - - Lemma pi_inj (A0 A1 : PTm) B0 B1 : - R (PBind PPi A0 B0) (PBind PPi A1 B1) -> - R A1 A0 /\ R B0 B1. - Proof. - move => [u0 [u1 [h0 [h1 h2]]]]. - move /EReds.bind_inv : h0 => [A2][B2][?][h3]h4. subst. - move /EReds.bind_inv : h1 => [A3][B3][?][h5]h6. subst. - sauto lq:on rew:off inv:Sub1.R. - Qed. - - Lemma sig_inj (A0 A1 : PTm) B0 B1 : - R (PBind PSig A0 B0) (PBind PSig A1 B1) -> - R A0 A1 /\ R B0 B1. - Proof. - move => [u0 [u1 [h0 [h1 h2]]]]. - move /EReds.bind_inv : h0 => [A2][B2][?][h3]h4. subst. - move /EReds.bind_inv : h1 => [A3][B3][?][h5]h6. subst. - sauto lq:on rew:off inv:Sub1.R. - Qed. - - Lemma suc_inj (a b : PTm) : - R (PSuc a) (PSuc b) -> - R a b. - Proof. - sauto lq:on use:EReds.suc_inv inv:Sub1.R. - Qed. - -End ESub. - -Module Sub. - Definition R (a b : PTm) := exists c d, rtc RERed.R a c /\ rtc RERed.R b d /\ Sub1.R c d. - - Lemma refl (a : PTm) : R a a. - Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - - Lemma ToJoin (a b : PTm) : - ishne a \/ ishne b -> - R a b -> - DJoin.R a b. - Proof. - move => h [c][d][h0][h1]h2. - have : ishne c \/ ishne d by hauto q:on use:REReds.hne_preservation. - hauto lq:on rew:off use:Sub1.hne_refl. - Qed. - - Lemma transitive (a b c : PTm) : SN b -> R a b -> R b c -> R a c. - Proof. - rewrite /R. - move => h [a0][b0][ha][hb]ha0b0 [b1][c0][hb'][hc]hb1c0. - move : hb hb'. - move : rered_confluence h. repeat move/[apply]. - move => [b'][hb0]hb1. - have [a' ?] : exists a', rtc RERed.R a0 a' /\ Sub1.R a' b' by hauto l:on use:Sub1.commutativity_Rs. - have [c' ?] : exists a', rtc RERed.R c0 a' /\ Sub1.R b' a' by hauto l:on use:Sub1.commutativity_Ls. - exists a',c'; hauto l:on use:Sub1.transitive, @relations.rtc_transitive. - Qed. - - Lemma FromJoin (a b : PTm) : DJoin.R a b -> R a b. - Proof. sfirstorder. Qed. - - Lemma PiCong (A0 A1 : PTm) B0 B1 : - R A1 A0 -> - R B0 B1 -> - R (PBind PPi A0 B0) (PBind PPi A1 B1). - Proof. - rewrite /R. - move => [A][A'][h0][h1]h2. - move => [B][B'][h3][h4]h5. - exists (PBind PPi A' B), (PBind PPi A B'). - repeat split; eauto using REReds.BindCong, Sub1.PiCong. - Qed. - - Lemma SigCong (A0 A1 : PTm) B0 B1 : - R A0 A1 -> - R B0 B1 -> - R (PBind PSig A0 B0) (PBind PSig A1 B1). - Proof. - rewrite /R. - move => [A][A'][h0][h1]h2. - move => [B][B'][h3][h4]h5. - exists (PBind PSig A B), (PBind PSig A' B'). - repeat split; eauto using REReds.BindCong, Sub1.SigCong. - Qed. - - Lemma UnivCong i j : - i <= j -> - @R (PUniv i) (PUniv j). - Proof. hauto lq:on ctrs:Sub1.R, rtc. Qed. - - Lemma sne_nat_noconf (a b : PTm) : - R a b -> SNe a -> isnat b -> False. - Proof. - move => [c [d [h0 [h1 h2]]]] *. - have : SNe c /\ isnat d by sfirstorder use:REReds.sne_preservation, REReds.nat_preservation, Sub1.sne_preservation. - move : h2. clear. hauto q:on inv:Sub1.R, SNe. - Qed. - - Lemma nat_sne_noconf (a b : PTm) : - R a b -> isnat a -> SNe b -> False. - Proof. - move => [c [d [h0 [h1 h2]]]] *. - have : SNe d /\ isnat c by sfirstorder use:REReds.sne_preservation, REReds.nat_preservation. - move : h2. clear. hauto q:on inv:Sub1.R, SNe. - Qed. - - Lemma sne_bind_noconf (a b : PTm) : - R a b -> SNe a -> isbind b -> False. - Proof. - rewrite /R. - move => [c[d] [? []]] *. - have : SNe c /\ isbind c by - hauto l:on use:REReds.sne_preservation, REReds.bind_preservation, Sub1.sne_preservation, Sub1.bind_preservation. - qauto l:on inv:SNe. - Qed. - - Lemma hne_bind_noconf (a b : PTm) : - R a b -> ishne a -> isbind b -> False. - Proof. - rewrite /R. - move => [c[d] [? []]] h0 h1 h2 h3. - have : ishne c by eauto using REReds.hne_preservation. - have : isbind d by eauto using REReds.bind_preservation. - move : h1. clear. inversion 1; subst => //=. - clear. case : d => //=. - Qed. - - Lemma bind_sne_noconf (a b : PTm) : - R a b -> SNe b -> isbind a -> False. - Proof. - rewrite /R. - move => [c[d] [? []]] *. - have : SNe c /\ isbind c by - hauto l:on use:REReds.sne_preservation, REReds.bind_preservation, Sub1.sne_preservation, Sub1.bind_preservation. - qauto l:on inv:SNe. - Qed. - - Lemma sne_univ_noconf (a b : PTm) : - R a b -> SNe a -> isuniv b -> False. - Proof. - hauto l:on use:REReds.sne_preservation, - REReds.univ_preservation, Sub1.sne_preservation, Sub1.univ_preservation inv:SNe. - Qed. - - Lemma univ_sne_noconf (a b : PTm) : - R a b -> SNe b -> isuniv a -> False. - Proof. - move => [c[d] [? []]] *. - have ? : SNe d by eauto using REReds.sne_preservation. - have : SNe c by sfirstorder use:Sub1.sne_preservation. - have : isuniv c by sfirstorder use:REReds.univ_preservation. - clear. case : c => //=. inversion 2. - Qed. - - Lemma univ_nat_noconf (a b : PTm) : - R a b -> isuniv b -> isnat a -> False. - Proof. - move => [c[d] [? []]] h0 h1 h2 h3. - have : isuniv d by eauto using REReds.univ_preservation. - have : isnat c by sfirstorder use:REReds.nat_preservation. - inversion h1; subst => //=. - clear. case : d => //=. - Qed. - - Lemma nat_univ_noconf (a b : PTm) : - R a b -> isnat b -> isuniv a -> False. - Proof. - move => [c[d] [? []]] h0 h1 h2 h3. - have : isuniv c by eauto using REReds.univ_preservation. - have : isnat d by sfirstorder use:REReds.nat_preservation. - inversion h1; subst => //=. - clear. case : d => //=. - Qed. - - Lemma bind_nat_noconf (a b : PTm) : - R a b -> isbind b -> isnat a -> False. - Proof. - move => [c[d] [? []]] h0 h1 h2 h3. - have : isbind d by eauto using REReds.bind_preservation. - have : isnat c by sfirstorder use:REReds.nat_preservation. - move : h1. clear. - inversion 1; subst => //=. - case : d h1 => //=. - Qed. - - Lemma nat_bind_noconf (a b : PTm) : - R a b -> isnat b -> isbind a -> False. - Proof. - move => [c[d] [? []]] h0 h1 h2 h3. - have : isbind c by eauto using REReds.bind_preservation. - have : isnat d by sfirstorder use:REReds.nat_preservation. - move : h1. clear. - inversion 1; subst => //=. - case : d h1 => //=. - Qed. - - Lemma bind_univ_noconf (a b : PTm) : - R a b -> isbind a -> isuniv b -> False. - Proof. - move => [c[d] [h0 [h1 h1']]] h2 h3. - have : isbind c /\ isuniv c by - hauto l:on use:REReds.bind_preservation, - REReds.univ_preservation, Sub1.bind_preservation, Sub1.univ_preservation. - move : h2 h3. clear. - case : c => //=; sfirstorder b:on. - Qed. - - Lemma univ_bind_noconf (a b : PTm) : - R a b -> isbind b -> isuniv a -> False. - Proof. - move => [c[d] [h0 [h1 h1']]] h2 h3. - have : isbind c /\ isuniv c by - hauto l:on use:REReds.bind_preservation, - REReds.univ_preservation, Sub1.bind_preservation, Sub1.univ_preservation. - move : h2 h3. clear. - case : c => //=; sfirstorder b:on. - Qed. - - Lemma bind_inj p0 p1 (A0 A1 : PTm) B0 B1 : - R (PBind p0 A0 B0) (PBind p1 A1 B1) -> - p0 = p1 /\ (if p0 is PPi then R A1 A0 else R A0 A1) /\ R B0 B1. - Proof. - rewrite /R. - move => [u][v][h0][h1]h. - move /REReds.bind_inv : h0 => [A2][B2][?][h00]h01. subst. - move /REReds.bind_inv : h1 => [A3][B3][?][h10]h11. subst. - inversion h; subst; sauto lq:on. - Qed. - - Lemma univ_inj i j : - @R (PUniv i) (PUniv j) -> i <= j. - Proof. - sauto lq:on rew:off use:REReds.univ_inv. - Qed. - - Lemma suc_inj (A0 A1 : PTm) : - R (PSuc A0) (PSuc A1) -> - R A0 A1. - Proof. - sauto q:on use:REReds.suc_inv. - Qed. - - - Lemma cong (a b : PTm) c d (ρ : nat -> PTm) : - R a b -> DJoin.R c d -> R (subst_PTm (scons c ρ) a) (subst_PTm (scons d ρ) b). - Proof. - rewrite /R. - move => [a0][b0][h0][h1]h2. - move => [cd][h3]h4. - exists (subst_PTm (scons cd ρ) a0), (subst_PTm (scons cd ρ) b0). - repeat split. - hauto l:on use:REReds.cong' inv:nat. - hauto l:on use:REReds.cong' inv:nat. - eauto using Sub1.substing. - Qed. - - Lemma substing (a b : PTm) (ρ : nat -> PTm) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). - Proof. - rewrite /R. - move => [a0][b0][h0][h1]h2. - hauto ctrs:rtc use:REReds.cong', Sub1.substing. - Qed. - - Lemma ToESub (a b : PTm) : nf a -> nf b -> R a b -> ESub.R a b. - Proof. hauto q:on use:REReds.ToEReds. Qed. - - Lemma standardization (a b : PTm) : - SN a -> SN b -> R a b -> - exists va vb, rtc RRed.R a va /\ rtc RRed.R b vb /\ nf va /\ nf vb /\ ESub.R va vb. - Proof. - move => h0 h1 hS. - have : exists v, rtc RRed.R a v /\ nf v by sfirstorder use:LoReds.FromSN, LoReds.ToRReds. - move => [v [hv2 hv3]]. - have : exists v, rtc RRed.R b v /\ nf v by sfirstorder use:LoReds.FromSN, LoReds.ToRReds. - move => [v' [hv2' hv3']]. - move : (hv2) (hv2') => *. - apply DJoin.FromRReds in hv2, hv2'. - move/DJoin.symmetric in hv2'. - apply FromJoin in hv2, hv2'. - have hv : R v v' by eauto using transitive. - have {}hv : ESub.R v v' by hauto l:on use:ToESub. - hauto lq:on. - Qed. - - Lemma standardization_lo (a b : PTm) : - SN a -> SN b -> R a b -> - exists va vb, rtc LoRed.R a va /\ rtc LoRed.R b vb /\ nf va /\ nf vb /\ ESub.R va vb. - Proof. - move => /[dup] sna + /[dup] snb. - move : standardization; repeat move/[apply]. - move => [va][vb][hva][hvb][nfva][nfvb]hj. - move /LoReds.FromSN : sna => [va' [hva' hva'0]]. - move /LoReds.FromSN : snb => [vb' [hvb' hvb'0]]. - exists va', vb'. - repeat split => //=. - have : va = va' /\ vb = vb' by sfirstorder use:red_uniquenf, LoReds.ToRReds. - case; congruence. - Qed. - -End Sub. diff --git a/theories/logrel.v b/theories/logrel.v deleted file mode 100644 index e11659e..0000000 --- a/theories/logrel.v +++ /dev/null @@ -1,1704 +0,0 @@ -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax. -Require Import common fp_red. -From Hammer Require Import Tactics. -From Equations Require Import Equations. -Require Import ssreflect ssrbool. -Require Import Logic.PropExtensionality (propositional_extensionality). -From stdpp Require Import relations (rtc(..), rtc_subrel). -Import Psatz. - - -Definition ProdSpace (PA : PTm -> Prop) - (PF : PTm -> (PTm -> Prop) -> Prop) b : Prop := - forall a PB, PA a -> PF a PB -> PB (PApp b a). - -Definition SumSpace (PA : PTm -> Prop) - (PF : PTm -> (PTm -> Prop) -> Prop) t : Prop := - (exists v, rtc TRedSN t v /\ SNe v) \/ exists a b, rtc TRedSN t (PPair a b) /\ PA a /\ (forall PB, PF a PB -> PB b). - -Definition BindSpace p := if p is PPi then ProdSpace else SumSpace. - -Reserved Notation "⟦ A ⟧ i ;; I ↘ S" (at level 70). - -Inductive InterpExt i (I : nat -> PTm -> Prop) : PTm -> (PTm -> Prop) -> Prop := -| InterpExt_Ne A : - SNe A -> - ⟦ A ⟧ i ;; I ↘ (fun a => exists v, rtc TRedSN a v /\ SNe v) - -| InterpExt_Bind p A B PA PF : - ⟦ A ⟧ i ;; I ↘ PA -> - (forall a, PA a -> exists PB, PF a PB) -> - (forall a PB, PF a PB -> ⟦ subst_PTm (scons a VarPTm) B ⟧ i ;; I ↘ PB) -> - ⟦ PBind p A B ⟧ i ;; I ↘ BindSpace p PA PF - -| InterpExt_Nat : - ⟦ PNat ⟧ i ;; I ↘ SNat - -| InterpExt_Univ j : - j < i -> - ⟦ PUniv j ⟧ i ;; I ↘ (I j) - -| InterpExt_Step A A0 PA : - TRedSN A A0 -> - ⟦ A0 ⟧ i ;; I ↘ PA -> - ⟦ A ⟧ i ;; I ↘ PA -where "⟦ A ⟧ i ;; I ↘ S" := (InterpExt i I A S). - -Lemma InterpExt_Univ' i I j (PF : PTm -> Prop) : - PF = I j -> - j < i -> - ⟦ PUniv j ⟧ i ;; I ↘ PF. -Proof. hauto lq:on ctrs:InterpExt. Qed. - -Infix " (PTm -> Prop) -> Prop by wf i lt := - InterpUnivN i := @InterpExt i - (fun j A => - match j exists PA, InterpUnivN j A PA - | right _ => False - end). - -Lemma InterpExt_lt_impl i I I' A (PA : PTm -> Prop) : - (forall j, j < i -> I j = I' j) -> - ⟦ A ⟧ i ;; I ↘ PA -> - ⟦ A ⟧ i ;; I' ↘ PA. -Proof. - move => hI h. - elim : A PA /h. - - hauto q:on ctrs:InterpExt. - - hauto lq:on rew:off ctrs:InterpExt. - - hauto q:on ctrs:InterpExt. - - hauto q:on ctrs:InterpExt. - - hauto lq:on ctrs:InterpExt. -Qed. - -Lemma InterpExt_lt_eq i I I' A (PA : PTm -> Prop) : - (forall j, j < i -> I j = I' j) -> - ⟦ A ⟧ i ;; I ↘ PA = - ⟦ A ⟧ i ;; I' ↘ PA. -Proof. - move => hI. apply propositional_extensionality. - have : forall j, j < i -> I' j = I j by sfirstorder. - firstorder using InterpExt_lt_impl. -Qed. - -Notation "⟦ A ⟧ i ↘ S" := (InterpUnivN i A S) (at level 70). - -Lemma InterpUnivN_nolt i : - @InterpUnivN i = @InterpExt i (fun j (A : PTm ) => exists PA, ⟦ A ⟧ j ↘ PA). -Proof. - simp InterpUnivN. - extensionality A. extensionality PA. - apply InterpExt_lt_eq. - hauto q:on. -Qed. - -#[export]Hint Rewrite @InterpUnivN_nolt : InterpUniv. - -Lemma InterpUniv_ind - : forall (P : nat -> PTm -> (PTm -> Prop) -> Prop), - (forall i (A : PTm), SNe A -> P i A (fun a : PTm => exists v : PTm , rtc TRedSN a v /\ SNe v)) -> - (forall i (p : BTag) (A : PTm ) (B : PTm ) (PA : PTm -> Prop) - (PF : PTm -> (PTm -> Prop) -> Prop), - ⟦ A ⟧ i ↘ PA -> - P i A PA -> - (forall a : PTm , PA a -> exists PB : PTm -> Prop, PF a PB) -> - (forall (a : PTm ) (PB : PTm -> Prop), PF a PB -> ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB) -> - (forall (a : PTm ) (PB : PTm -> Prop), PF a PB -> P i (subst_PTm (scons a VarPTm) B) PB) -> - P i (PBind p A B) (BindSpace p PA PF)) -> - (forall i, P i PNat SNat) -> - (forall i j : nat, j < i -> (forall A PA, ⟦ A ⟧ j ↘ PA -> P j A PA) -> P i (PUniv j) (fun A => exists PA, ⟦ A ⟧ j ↘ PA)) -> - (forall i (A A0 : PTm ) (PA : PTm -> Prop), TRedSN A A0 -> ⟦ A0 ⟧ i ↘ PA -> P i A0 PA -> P i A PA) -> - forall i (p : PTm ) (P0 : PTm -> Prop), ⟦ p ⟧ i ↘ P0 -> P i p P0. -Proof. - move => P hSN hBind hNat hUniv hRed. - elim /Wf_nat.lt_wf_ind => i ih . simp InterpUniv. - move => A PA. move => h. set I := fun _ => _ in h. - elim : A PA / h; rewrite -?InterpUnivN_nolt; eauto. -Qed. - -Derive Dependent Inversion iinv with (forall i I (A : PTm ) PA, InterpExt i I A PA) Sort Prop. - -Lemma InterpUniv_Ne i (A : PTm) : - SNe A -> - ⟦ A ⟧ i ↘ (fun a => exists v, rtc TRedSN a v /\ SNe v). -Proof. simp InterpUniv. apply InterpExt_Ne. Qed. - -Lemma InterpUniv_Bind i p A B PA PF : - ⟦ A ⟧ i ↘ PA -> - (forall a, PA a -> exists PB, PF a PB) -> - (forall a PB, PF a PB -> ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB) -> - ⟦ PBind p A B ⟧ i ↘ BindSpace p PA PF. -Proof. simp InterpUniv. apply InterpExt_Bind. Qed. - -Lemma InterpUniv_Univ i j : - j < i -> ⟦ PUniv j ⟧ i ↘ (fun A => exists PA, ⟦ A ⟧ j ↘ PA). -Proof. - simp InterpUniv. simpl. - apply InterpExt_Univ'. by simp InterpUniv. -Qed. - -Lemma InterpUniv_Step i A A0 PA : - TRedSN A A0 -> - ⟦ A0 ⟧ i ↘ PA -> - ⟦ A ⟧ i ↘ PA. -Proof. simp InterpUniv. apply InterpExt_Step. Qed. - -Lemma InterpUniv_Nat i : - ⟦ PNat ⟧ i ↘ SNat. -Proof. simp InterpUniv. apply InterpExt_Nat. Qed. - -#[export]Hint Resolve InterpUniv_Bind InterpUniv_Step InterpUniv_Ne InterpUniv_Univ : InterpUniv. - -Lemma InterpExt_cumulative i j I (A : PTm ) PA : - i <= j -> - ⟦ A ⟧ i ;; I ↘ PA -> - ⟦ A ⟧ j ;; I ↘ PA. -Proof. - move => h h0. - elim : A PA /h0; - hauto l:on ctrs:InterpExt solve+:(by lia). -Qed. - -Lemma InterpUniv_cumulative i (A : PTm) PA : - ⟦ A ⟧ i ↘ PA -> forall j, i <= j -> - ⟦ A ⟧ j ↘ PA. -Proof. - hauto l:on rew:db:InterpUniv use:InterpExt_cumulative. -Qed. - -Definition CR (P : PTm -> Prop) := - (forall a, P a -> SN a) /\ - (forall a, SNe a -> P a). - -Lemma N_Exps (a b : PTm) : - rtc TRedSN a b -> - SN b -> - SN a. -Proof. - induction 1; eauto using N_Exp. -Qed. - -Lemma CR_SNat : CR SNat. -Proof. - rewrite /CR. - split. - induction 1; hauto q:on ctrs:SN,SNe. - hauto lq:on ctrs:SNat. -Qed. - -Lemma adequacy : forall i A PA, - ⟦ A ⟧ i ↘ PA -> - CR PA /\ SN A. -Proof. - apply : InterpUniv_ind. - - hauto l:on use:N_Exps ctrs:SN,SNe. - - move => i p A B PA PF hPA [ihA0 ihA1] hTot hRes ihPF. - set PBot := (VarPTm var_zero). - have hb : PA PBot by hauto q:on ctrs:SNe. - have hb' : SN PBot by hauto q:on ctrs:SN, SNe. - rewrite /CR. - repeat split. - + case : p =>//=. - * rewrite /ProdSpace. - qauto use:SN_AppInv unfold:CR. - * hauto q:on unfold:SumSpace use:N_SNe, N_Pair,N_Exps. - + move => a ha. - case : p=>/=. - * rewrite /ProdSpace => a0 *. - suff : SNe (PApp a a0) by sfirstorder. - hauto q:on use:N_App. - * sfirstorder. - + apply N_Bind=>//=. - have : SN (PApp (PAbs B) PBot). - apply : N_Exp; eauto using N_β. - hauto lq:on. - qauto l:on use:SN_AppInv, SN_NoForbid.P_AbsInv. - - sfirstorder use:CR_SNat. - - hauto l:on ctrs:InterpExt rew:db:InterpUniv. - - hauto l:on ctrs:SN unfold:CR. -Qed. - -Lemma InterpUniv_Steps i A A0 PA : - rtc TRedSN A A0 -> - ⟦ A0 ⟧ i ↘ PA -> - ⟦ A ⟧ i ↘ PA. -Proof. induction 1; hauto l:on use:InterpUniv_Step. Qed. - -Lemma InterpUniv_back_clos i (A : PTm ) PA : - ⟦ A ⟧ i ↘ PA -> - forall a b, TRedSN a b -> - PA b -> PA a. -Proof. - move : i A PA . apply : InterpUniv_ind; eauto. - - hauto q:on ctrs:rtc. - - move => i p A B PA PF hPA ihPA hTot hRes ihPF a b hr. - case : p => //=. - + rewrite /ProdSpace. - move => hba a0 PB ha hPB. - suff : TRedSN (PApp a a0) (PApp b a0) by hauto lq:on. - apply N_AppL => //=. - hauto q:on use:adequacy. - + hauto lq:on ctrs:rtc unfold:SumSpace. - - hauto lq:on ctrs:SNat. - - hauto l:on use:InterpUniv_Step. -Qed. - -Lemma InterpUniv_back_closs i (A : PTm) PA : - ⟦ A ⟧ i ↘ PA -> - forall a b, rtc TRedSN a b -> - PA b -> PA a. -Proof. - induction 2; hauto lq:on ctrs:rtc use:InterpUniv_back_clos. -Qed. - -Lemma InterpUniv_case i (A : PTm) PA : - ⟦ A ⟧ i ↘ PA -> - exists H, rtc TRedSN A H /\ ⟦ H ⟧ i ↘ PA /\ (SNe H \/ isbind H \/ isuniv H \/ isnat H). -Proof. - move : i A PA. apply InterpUniv_ind => //=. - hauto lq:on ctrs:rtc use:InterpUniv_Ne. - hauto l:on use:InterpUniv_Bind. - hauto l:on use:InterpUniv_Nat. - hauto l:on use:InterpUniv_Univ. - hauto lq:on ctrs:rtc. -Qed. - -Lemma redsn_preservation_mutual : - (forall (a : PTm) (s : SNe a), forall b, TRedSN a b -> False) /\ - (forall (a : PTm) (s : SN a), forall b, TRedSN a b -> SN b) /\ - (forall (a b : PTm) (_ : TRedSN a b), forall c, TRedSN a c -> b = c). -Proof. - apply sn_mutual; sauto lq:on rew:off. -Qed. - -Lemma redsns_preservation : forall a b, SN a -> rtc TRedSN a b -> SN b. -Proof. induction 2; sfirstorder use:redsn_preservation_mutual ctrs:rtc. Qed. - -#[export]Hint Resolve Sub.sne_bind_noconf Sub.sne_univ_noconf Sub.bind_univ_noconf - Sub.bind_sne_noconf Sub.univ_sne_noconf Sub.univ_bind_noconf Sub.nat_bind_noconf Sub.bind_nat_noconf Sub.sne_nat_noconf Sub.nat_sne_noconf Sub.univ_nat_noconf Sub.nat_univ_noconf: noconf. - -Lemma InterpUniv_SNe_inv i (A : PTm) PA : - SNe A -> - ⟦ A ⟧ i ↘ PA -> - PA = (fun a => exists v, rtc TRedSN a v /\ SNe v). -Proof. - simp InterpUniv. - hauto lq:on rew:off inv:InterpExt,SNe use:redsn_preservation_mutual. -Qed. - -Lemma InterpUniv_Bind_inv i p A B S : - ⟦ PBind p A B ⟧ i ↘ S -> exists PA PF, - ⟦ A ⟧ i ↘ PA /\ - (forall a, PA a -> exists PB, PF a PB) /\ - (forall a PB, PF a PB -> ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB) /\ - S = BindSpace p PA PF. -Proof. simp InterpUniv. - inversion 1; try hauto inv:SNe q:on use:redsn_preservation_mutual. - rewrite -!InterpUnivN_nolt. - sauto lq:on. -Qed. - -Lemma InterpUniv_Nat_inv i S : - ⟦ PNat ⟧ i ↘ S -> S = SNat. -Proof. - simp InterpUniv. - inversion 1; try hauto inv:SNe q:on use:redsn_preservation_mutual. - sauto lq:on. -Qed. - -Lemma InterpUniv_Univ_inv i j S : - ⟦ PUniv j ⟧ i ↘ S -> - S = (fun A => exists PA, ⟦ A ⟧ j ↘ PA) /\ j < i. -Proof. - simp InterpUniv. inversion 1; - try hauto inv:SNe use:redsn_preservation_mutual. - rewrite -!InterpUnivN_nolt. sfirstorder. - subst. hauto lq:on inv:TRedSN. -Qed. - -Lemma bindspace_impl p (PA PA0 : PTm -> Prop) PF PF0 b : - (forall x, if p is PPi then (PA0 x -> PA x) else (PA x -> PA0 x)) -> - (forall (a : PTm ) (PB PB0 : PTm -> Prop), PA0 a -> PF a PB -> PF0 a PB0 -> (forall x, PB x -> PB0 x)) -> - (forall a, PA a -> exists PB, PF a PB) -> - (forall a, PA0 a -> exists PB0, PF0 a PB0) -> - (BindSpace p PA PF b -> BindSpace p PA0 PF0 b). -Proof. - rewrite /BindSpace => hSA h hPF hPF0. - case : p hSA => /= hSA. - - rewrite /ProdSpace. - move => h1 a PB ha hPF'. - have {}/hPF : PA a by sfirstorder. - specialize hPF0 with (1 := ha). - hauto lq:on. - - rewrite /SumSpace. - case. sfirstorder. - move => [a0][b0][h0][h1]h2. right. - hauto lq:on. -Qed. - -Lemma InterpUniv_Sub' i (A B : PTm) PA PB : - ⟦ A ⟧ i ↘ PA -> - ⟦ B ⟧ i ↘ PB -> - ((Sub.R A B -> forall x, PA x -> PB x) /\ - (Sub.R B A -> forall x, PB x -> PA x)). -Proof. - move => hA. - move : i A PA hA B PB. - apply : InterpUniv_ind. - - move => i A hA B PB hPB. split. - + move => hAB a ha. - have [? ?] : SN B /\ SN A by hauto l:on use:adequacy. - move /InterpUniv_case : hPB. - move => [H [/DJoin.FromRedSNs h [h1 h0]]]. - have {h}{}hAB : Sub.R A H by qauto l:on use:Sub.FromJoin, DJoin.symmetric, Sub.transitive. - have {}h0 : SNe H. - suff : ~ isbind H /\ ~ isuniv H /\ ~ isnat H by sfirstorder b:on. - move : hA hAB. clear. hauto lq:on db:noconf. - move : InterpUniv_SNe_inv h1 h0. repeat move/[apply]. move => ?. subst. - tauto. - + move => hAB a ha. - have [? ?] : SN B /\ SN A by hauto l:on use:adequacy. - move /InterpUniv_case : hPB. - move => [H [/DJoin.FromRedSNs h [h1 h0]]]. - have {h}{}hAB : Sub.R H A by qauto l:on use:Sub.FromJoin, DJoin.symmetric, Sub.transitive. - have {}h0 : SNe H. - suff : ~ isbind H /\ ~ isuniv H /\ ~ isnat H by sfirstorder b:on. - move : hAB hA h0. clear. hauto lq:on db:noconf. - move : InterpUniv_SNe_inv h1 h0. repeat move/[apply]. move => ?. subst. - tauto. - - move => i p A B PA PF hPA ihPA hTot hRes ihPF U PU hU. split. - + have hU' : SN U by hauto l:on use:adequacy. - move /InterpUniv_case : hU => [H [/DJoin.FromRedSNs h [h1 h0]]] hU. - have {hU} {}h : Sub.R (PBind p A B) H - by move : hU hU' h; clear; hauto q:on use:Sub.FromJoin, DJoin.symmetric, Sub.transitive. - have{h0} : isbind H. - suff : ~ SNe H /\ ~ isuniv H /\ ~ isnat H by sfirstorder b:on. - have : isbind (PBind p A B) by scongruence. - move : h. clear. hauto l:on db:noconf. - case : H h1 h => //=. - move => p0 A0 B0 h0 /Sub.bind_inj. - move => [? [hA hB]] _. subst. - move /InterpUniv_Bind_inv : h0. - move => [PA0][PF0][hPA0][hTot0][hRes0 ?]. subst. - move => x. apply bindspace_impl; eauto;[idtac|idtac]. hauto l:on. - move => a PB PB' ha hPB hPB'. - move : hRes0 hPB'. repeat move/[apply]. - move : ihPF hPB. repeat move/[apply]. - move => h. eapply h. - apply Sub.cong => //=; eauto using DJoin.refl. - + have hU' : SN U by hauto l:on use:adequacy. - move /InterpUniv_case : hU => [H [/DJoin.FromRedSNs h [h1 h0]]] hU. - have {hU} {}h : Sub.R H (PBind p A B) - by move : hU hU' h; clear; hauto q:on use:Sub.FromJoin, DJoin.symmetric, Sub.transitive. - have{h0} : isbind H. - suff : ~ SNe H /\ ~ isuniv H /\ ~ isnat H by sfirstorder b:on. - have : isbind (PBind p A B) by scongruence. - move : h. clear. move : (PBind p A B). hauto lq:on db:noconf. - case : H h1 h => //=. - move => p0 A0 B0 h0 /Sub.bind_inj. - move => [? [hA hB]] _. subst. - move /InterpUniv_Bind_inv : h0. - move => [PA0][PF0][hPA0][hTot0][hRes0 ?]. subst. - move => x. apply bindspace_impl; eauto;[idtac|idtac]. hauto l:on. - move => a PB PB' ha hPB hPB'. - eapply ihPF; eauto. - apply Sub.cong => //=; eauto using DJoin.refl. - - move => i B PB h. split. - + move => hAB a ha. - have ? : SN B by hauto l:on use:adequacy. - move /InterpUniv_case : h. - move => [H [/DJoin.FromRedSNs h [h1 h0]]]. - have {h}{}hAB : Sub.R PNat H by qauto l:on use:Sub.FromJoin, DJoin.symmetric, Sub.transitive. - have {}h0 : isnat H. - suff : ~ isbind H /\ ~ isuniv H /\ ~ SNe H by sfirstorder b:on. - have : @isnat PNat by simpl. - move : h0 hAB. clear. qauto l:on db:noconf. - case : H h1 hAB h0 => //=. - move /InterpUniv_Nat_inv. scongruence. - + move => hAB a ha. - have ? : SN B by hauto l:on use:adequacy. - move /InterpUniv_case : h. - move => [H [/DJoin.FromRedSNs h [h1 h0]]]. - have {h}{}hAB : Sub.R H PNat by qauto l:on use:Sub.FromJoin, DJoin.symmetric, Sub.transitive. - have {}h0 : isnat H. - suff : ~ isbind H /\ ~ isuniv H /\ ~ SNe H by sfirstorder b:on. - have : @isnat PNat by simpl. - move : h0 hAB. clear. qauto l:on db:noconf. - case : H h1 hAB h0 => //=. - move /InterpUniv_Nat_inv. scongruence. - - move => i j jlti ih B PB hPB. split. - + have ? : SN B by hauto l:on use:adequacy. - move /InterpUniv_case : hPB => [H [/DJoin.FromRedSNs h [h1 h0]]]. - move => hj. - have {hj}{}h : Sub.R (PUniv j) H by eauto using Sub.transitive, Sub.FromJoin. - have {h0} : isuniv H. - suff : ~ SNe H /\ ~ isbind H /\ ~ isnat H by tauto. move : h. clear. hauto lq:on db:noconf. - case : H h1 h => //=. - move => j' hPB h _. - have {}h : j <= j' by hauto lq:on use: Sub.univ_inj. subst. - move /InterpUniv_Univ_inv : hPB => [? ?]. subst. - have ? : j <= i by lia. - move => A. hauto l:on use:InterpUniv_cumulative. - + have ? : SN B by hauto l:on use:adequacy. - move /InterpUniv_case : hPB => [H [/DJoin.FromRedSNs h [h1 h0]]]. - move => hj. - have {hj}{}h : Sub.R H (PUniv j) by eauto using Sub.transitive, Sub.FromJoin, DJoin.symmetric. - have {h0} : isuniv H. - suff : ~ SNe H /\ ~ isbind H /\ ~ isnat H by tauto. move : h. clear. hauto lq:on db:noconf. - case : H h1 h => //=. - move => j' hPB h _. - have {}h : j' <= j by hauto lq:on use: Sub.univ_inj. - move /InterpUniv_Univ_inv : hPB => [? ?]. subst. - move => A. hauto l:on use:InterpUniv_cumulative. - - move => i A A0 PA hr hPA ihPA B PB hPB. - have ? : SN A by sauto lq:on use:adequacy. - split. - + move => ?. - have {}hr : Sub.R A0 A by hauto lq:on ctrs:rtc use:DJoin.FromRedSNs, DJoin.symmetric, Sub.FromJoin. - have : Sub.R A0 B by eauto using Sub.transitive. - qauto l:on. - + move => ?. - have {}hr : Sub.R A A0 by hauto lq:on ctrs:rtc use:DJoin.FromRedSNs, DJoin.symmetric, Sub.FromJoin. - have : Sub.R B A0 by eauto using Sub.transitive. - qauto l:on. -Qed. - -Lemma InterpUniv_Sub0 i (A B : PTm) PA PB : - ⟦ A ⟧ i ↘ PA -> - ⟦ B ⟧ i ↘ PB -> - Sub.R A B -> forall x, PA x -> PB x. -Proof. - move : InterpUniv_Sub'. repeat move/[apply]. - move => [+ _]. apply. -Qed. - -Lemma InterpUniv_Sub i j (A B : PTm) PA PB : - ⟦ A ⟧ i ↘ PA -> - ⟦ B ⟧ j ↘ PB -> - Sub.R A B -> forall x, PA x -> PB x. -Proof. - have [? ?] : i <= max i j /\ j <= max i j by lia. - move => hPA hPB. - have : ⟦ B ⟧ (max i j) ↘ PB by eauto using InterpUniv_cumulative. - have : ⟦ A ⟧ (max i j) ↘ PA by eauto using InterpUniv_cumulative. - move : InterpUniv_Sub0. repeat move/[apply]. - apply. -Qed. - -Lemma InterpUniv_Join i (A B : PTm) PA PB : - ⟦ A ⟧ i ↘ PA -> - ⟦ B ⟧ i ↘ PB -> - DJoin.R A B -> - PA = PB. -Proof. - move => + + /[dup] /Sub.FromJoin + /DJoin.symmetric /Sub.FromJoin. - move : InterpUniv_Sub'; repeat move/[apply]. move => h. - move => h1 h2. - extensionality x. - apply propositional_extensionality. - firstorder. -Qed. - -Lemma InterpUniv_Functional i (A : PTm) PA PB : - ⟦ A ⟧ i ↘ PA -> - ⟦ A ⟧ i ↘ PB -> - PA = PB. -Proof. hauto l:on use:InterpUniv_Join, DJoin.refl. Qed. - -Lemma InterpUniv_Join' i j (A B : PTm) PA PB : - ⟦ A ⟧ i ↘ PA -> - ⟦ B ⟧ j ↘ PB -> - DJoin.R A B -> - PA = PB. -Proof. - have [? ?] : i <= max i j /\ j <= max i j by lia. - move => hPA hPB. - have : ⟦ A ⟧ (max i j) ↘ PA by eauto using InterpUniv_cumulative. - have : ⟦ B ⟧ (max i j) ↘ PB by eauto using InterpUniv_cumulative. - eauto using InterpUniv_Join. -Qed. - -Lemma InterpUniv_Functional' i j A PA PB : - ⟦ A ⟧ i ↘ PA -> - ⟦ A ⟧ j ↘ PB -> - PA = PB. -Proof. - hauto l:on use:InterpUniv_Join', DJoin.refl. -Qed. - -Lemma InterpUniv_Bind_inv_nopf i p A B P (h : ⟦PBind p A B ⟧ i ↘ P) : - exists (PA : PTm -> Prop), - ⟦ A ⟧ i ↘ PA /\ - (forall a, PA a -> exists PB, ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB) /\ - P = BindSpace p PA (fun a PB => ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB). -Proof. - move /InterpUniv_Bind_inv : h. - move => [PA][PF][hPA][hPF][hPF']?. subst. - exists PA. repeat split => //. - - sfirstorder. - - extensionality b. - case : p => /=. - + extensionality a. - extensionality PB. - extensionality ha. - apply propositional_extensionality. - split. - * move => h hPB. apply h. - have {}/hPF := ha. - move => [PB0 hPB0]. - have {}/hPF' := hPB0 => ?. - have : PB = PB0 by hauto l:on use:InterpUniv_Functional. - congruence. - * sfirstorder. - + rewrite /SumSpace. apply propositional_extensionality. - split; hauto q:on use:InterpUniv_Functional. -Qed. - -Definition ρ_ok (Γ : list PTm) (ρ : nat -> PTm) := forall i k A PA, - lookup i Γ A -> - ⟦ subst_PTm ρ A ⟧ k ↘ PA -> PA (ρ i). - -Definition SemWt Γ (a A : PTm) := forall ρ, ρ_ok Γ ρ -> exists k PA, ⟦ subst_PTm ρ A ⟧ k ↘ PA /\ PA (subst_PTm ρ a). -Notation "Γ ⊨ a ∈ A" := (SemWt Γ a A) (at level 70). - -Definition SemEq Γ (a b A : PTm) := DJoin.R a b /\ forall ρ, ρ_ok Γ ρ -> exists k PA, ⟦ subst_PTm ρ A ⟧ k ↘ PA /\ PA (subst_PTm ρ a) /\ PA (subst_PTm ρ b). -Notation "Γ ⊨ a ≡ b ∈ A" := (SemEq Γ a b A) (at level 70). - -Definition SemLEq Γ (A B : PTm) := Sub.R A B /\ exists i, forall ρ, ρ_ok Γ ρ -> exists S0 S1, ⟦ subst_PTm ρ A ⟧ i ↘ S0 /\ ⟦ subst_PTm ρ B ⟧ i ↘ S1. -Notation "Γ ⊨ a ≲ b" := (SemLEq Γ a b) (at level 70). - -Lemma SemWt_Univ Γ (A : PTm) i : - Γ ⊨ A ∈ PUniv i <-> - forall ρ, ρ_ok Γ ρ -> exists S, ⟦ subst_PTm ρ A ⟧ i ↘ S. -Proof. - rewrite /SemWt. - split. - - hauto lq:on rew:off use:InterpUniv_Univ_inv. - - move => /[swap] ρ /[apply]. - move => [PA hPA]. - exists (S i). eexists. - split. - + simp InterpUniv. apply InterpExt_Univ. lia. - + simpl. eauto. -Qed. - -Lemma SemEq_SemWt Γ (a b A : PTm) : Γ ⊨ a ≡ b ∈ A -> Γ ⊨ a ∈ A /\ Γ ⊨ b ∈ A /\ DJoin.R a b. -Proof. hauto lq:on rew:off unfold:SemEq, SemWt. Qed. - -Lemma SemLEq_SemWt Γ (A B : PTm) : Γ ⊨ A ≲ B -> Sub.R A B /\ exists i, Γ ⊨ A ∈ PUniv i /\ Γ ⊨ B ∈ PUniv i. -Proof. hauto q:on use:SemWt_Univ. Qed. - -Lemma SemWt_SemEq Γ (a b A : PTm) : Γ ⊨ a ∈ A -> Γ ⊨ b ∈ A -> (DJoin.R a b) -> Γ ⊨ a ≡ b ∈ A. -Proof. - move => ha hb heq. split => //= ρ hρ. - have {}/ha := hρ. - have {}/hb := hρ. - move => [k][PA][hPA]hpb. - move => [k0][PA0][hPA0]hpa. - have : PA = PA0 by hauto l:on use:InterpUniv_Functional'. - hauto lq:on. -Qed. - -Lemma SemWt_SemLEq Γ (A B : PTm) i j : - Γ ⊨ A ∈ PUniv i -> Γ ⊨ B ∈ PUniv j -> Sub.R A B -> Γ ⊨ A ≲ B. -Proof. - move => ha hb heq. split => //. - exists (Nat.max i j). - have [? ?] : i <= Nat.max i j /\ j <= Nat.max i j by lia. - move => ρ hρ. - have {}/ha := hρ. - have {}/hb := hρ. - move => [k][PA][/= /InterpUniv_Univ_inv [? hPA]]hpb. - move => [k0][PA0][/= /InterpUniv_Univ_inv [? hPA0]]hpa. subst. - move : hpb => [PA]hPA'. - move : hpa => [PB]hPB'. - exists PB, PA. - split; apply : InterpUniv_cumulative; eauto. -Qed. - -Lemma ρ_ok_id Γ : - ρ_ok Γ VarPTm. -Proof. - rewrite /ρ_ok. - hauto q:on use:adequacy ctrs:SNe. -Qed. - -Lemma ρ_ok_cons i Γ ρ a PA A : - ⟦ subst_PTm ρ A ⟧ i ↘ PA -> PA a -> - ρ_ok Γ ρ -> - ρ_ok (cons A Γ) (scons a ρ). -Proof. - move => h0 h1 h2. - rewrite /ρ_ok. - case => [|j]; cycle 1. - - move => m PA0. asimpl => ?. - inversion 1; subst; asimpl. - hauto lq:on unfold:ρ_ok. - - move => m A0 PA0. - inversion 1; subst. asimpl => h. - have ? : PA0 = PA by eauto using InterpUniv_Functional'. - by subst. -Qed. - -Lemma ρ_ok_cons' i Γ ρ a PA A Δ : - Δ = (cons A Γ) -> - ⟦ subst_PTm ρ A ⟧ i ↘ PA -> PA a -> - ρ_ok Γ ρ -> - ρ_ok Δ (scons a ρ). -Proof. move => ->. apply ρ_ok_cons. Qed. - -Lemma ρ_ok_renaming (Γ : list PTm) ρ : - forall (Δ : list PTm) ξ, - renaming_ok Γ Δ ξ -> - ρ_ok Γ ρ -> - ρ_ok Δ (funcomp ρ ξ). -Proof. - move => Δ ξ hξ hρ. - rewrite /ρ_ok => i m' A PA. - rewrite /renaming_ok in hξ. - rewrite /ρ_ok in hρ. - move => PA0 h. - rewrite /funcomp. - eapply hρ with (k := m'); eauto. - move : h. by asimpl. -Qed. - -Lemma renaming_SemWt Γ a A : - Γ ⊨ a ∈ A -> - forall Δ (ξ : nat -> nat), - renaming_ok Δ Γ ξ -> - Δ ⊨ ren_PTm ξ a ∈ ren_PTm ξ A. -Proof. - rewrite /SemWt => h Δ ξ hξ ρ hρ. - have /h hρ' : (ρ_ok Γ (funcomp ρ ξ)) by eauto using ρ_ok_renaming. - hauto q:on solve+:(by asimpl). -Qed. - -Definition smorphing_ok Δ Γ ρ := - forall ξ, ρ_ok Δ ξ -> ρ_ok Γ (funcomp (subst_PTm ξ) ρ). - -Lemma smorphing_ok_refl Δ : smorphing_ok Δ Δ VarPTm. - rewrite /smorphing_ok => ξ. apply. -Qed. - -Lemma smorphing_ren Ξ Δ Γ - (ρ : nat -> PTm) (ξ : nat -> nat) : - renaming_ok Ξ Δ ξ -> smorphing_ok Δ Γ ρ -> - smorphing_ok Ξ Γ (funcomp (ren_PTm ξ) ρ). -Proof. - move => hξ hρ τ. - move /ρ_ok_renaming : hξ => /[apply]. - move => h. - rewrite /smorphing_ok in hρ. - asimpl. - Check (funcomp τ ξ). - set u := funcomp _ _. - have : u = funcomp (subst_PTm (funcomp τ ξ)) ρ. - subst u. extensionality i. by asimpl. - move => ->. by apply hρ. -Qed. - -Lemma smorphing_ext Δ Γ (ρ : nat -> PTm) (a : PTm) (A : PTm) : - smorphing_ok Δ Γ ρ -> - Δ ⊨ a ∈ subst_PTm ρ A -> - smorphing_ok - Δ (cons A Γ) (scons a ρ). -Proof. - move => h ha τ. move => /[dup] hτ. - move : ha => /[apply]. - move => [k][PA][h0]h1. - apply h in hτ. - case => [|i]; cycle 1. - - move => k0 A0 PA0. asimpl. rewrite {2}/funcomp. - asimpl. elim /lookup_inv => //= _. - move => i0 Γ0 A1 B + [?][? ?]?. subst. - asimpl. - move : hτ; by repeat move/[apply]. - - move => k0 A0 PA0. asimpl. rewrite {2}/funcomp. asimpl. - elim /lookup_inv => //=_ A1 Γ0 _ [? ?] ?. subst. asimpl. - move => *. suff : PA0 = PA by congruence. - move : h0. asimpl. - eauto using InterpUniv_Functional'. -Qed. - -Lemma morphing_SemWt : forall Γ (a A : PTm ), - Γ ⊨ a ∈ A -> forall Δ (ρ : nat -> PTm ), - smorphing_ok Δ Γ ρ -> Δ ⊨ subst_PTm ρ a ∈ subst_PTm ρ A. -Proof. - move => Γ a A ha Δ ρ hρ τ hτ. - have {}/hρ {}/ha := hτ. - asimpl. eauto. -Qed. - -Lemma morphing_SemWt_Univ : forall Γ (a : PTm) i, - Γ ⊨ a ∈ PUniv i -> forall Δ (ρ : nat -> PTm), - smorphing_ok Δ Γ ρ -> Δ ⊨ subst_PTm ρ a ∈ PUniv i. -Proof. - move => Γ a i ha Δ ρ. - have -> : PUniv i = subst_PTm ρ (PUniv i) by reflexivity. - by apply morphing_SemWt. -Qed. - -Lemma weakening_Sem Γ (a : PTm) A B i - (h0 : Γ ⊨ B ∈ PUniv i) - (h1 : Γ ⊨ a ∈ A) : - (cons B Γ) ⊨ ren_PTm shift a ∈ ren_PTm shift A. -Proof. - apply : renaming_SemWt; eauto. - hauto lq:on ctrs:lookup unfold:renaming_ok. -Qed. - -Lemma weakening_Sem_Univ Γ (a : PTm) B i j - (h0 : Γ ⊨ B ∈ PUniv i) - (h1 : Γ ⊨ a ∈ PUniv j) : - (cons B Γ) ⊨ ren_PTm shift a ∈ PUniv j. -Proof. - move : weakening_Sem h0 h1; repeat move/[apply]. done. -Qed. - -Reserved Notation "⊨ Γ" (at level 70). - -Inductive SemWff : list PTm -> Prop := -| SemWff_nil : - ⊨ nil -| SemWff_cons Γ A i : - ⊨ Γ -> - Γ ⊨ A ∈ PUniv i -> - (* -------------- *) - ⊨ (cons A Γ) -where "⊨ Γ" := (SemWff Γ). - -(* Semantic context wellformedness *) -Lemma SemWff_lookup Γ : - ⊨ Γ -> - forall (i : nat) A, lookup i Γ A -> exists j, Γ ⊨ A ∈ PUniv j. -Proof. - move => h. elim : Γ / h. - - by inversion 1. - - move => Γ A i hΓ ihΓ hA j B. - elim /lookup_inv => //=_. - + move => ? ? ? [*]. subst. - eauto using weakening_Sem_Univ. - + move => i0 Γ0 A0 B0 hl ? [*]. subst. - move : ihΓ hl => /[apply]. move => [j hA0]. - eauto using weakening_Sem_Univ. -Qed. - -Lemma SemWt_SN Γ (a : PTm) A : - Γ ⊨ a ∈ A -> - SN a /\ SN A. -Proof. - move => h. - have {}/h := ρ_ok_id Γ => h. - have : SN (subst_PTm VarPTm A) by hauto l:on use:adequacy. - have : SN (subst_PTm VarPTm a)by hauto l:on use:adequacy. - by asimpl. -Qed. - -Lemma SemEq_SN_Join Γ (a b A : PTm) : - Γ ⊨ a ≡ b ∈ A -> - SN a /\ SN b /\ SN A /\ DJoin.R a b. -Proof. hauto l:on use:SemEq_SemWt, SemWt_SN. Qed. - -Lemma SemLEq_SN_Sub Γ (a b : PTm) : - Γ ⊨ a ≲ b -> - SN a /\ SN b /\ Sub.R a b. -Proof. hauto l:on use:SemLEq_SemWt, SemWt_SN. Qed. - -(* Semantic typing rules *) -Lemma ST_Var' Γ (i : nat) A j : - lookup i Γ A -> - Γ ⊨ A ∈ PUniv j -> - Γ ⊨ VarPTm i ∈ A. -Proof. - move => hl /SemWt_Univ h. - rewrite /SemWt => ρ /[dup] hρ {}/h [S hS]. - exists j,S. - asimpl. hauto q:on unfold:ρ_ok. -Qed. - -Lemma ST_Var Γ (i : nat) A : - ⊨ Γ -> - lookup i Γ A -> - Γ ⊨ VarPTm i ∈ A. -Proof. hauto l:on use:ST_Var', SemWff_lookup. Qed. - -Lemma InterpUniv_Bind_nopf p i (A : PTm) B PA : - ⟦ A ⟧ i ↘ PA -> - (forall a, PA a -> exists PB, ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB) -> - ⟦ PBind p A B ⟧ i ↘ (BindSpace p PA (fun a PB => ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB)). -Proof. - move => h0 h1. apply InterpUniv_Bind => //=. -Qed. - - -Lemma ST_Bind' Γ i j p (A : PTm) (B : PTm) : - Γ ⊨ A ∈ PUniv i -> - (cons A Γ) ⊨ B ∈ PUniv j -> - Γ ⊨ PBind p A B ∈ PUniv (max i j). -Proof. - move => /SemWt_Univ h0 /SemWt_Univ h1. - apply SemWt_Univ => ρ hρ. - move /h0 : (hρ){h0} => [S hS]. - eexists => /=. - have ? : i <= Nat.max i j by lia. - apply InterpUniv_Bind_nopf; eauto. - - eauto using InterpUniv_cumulative. - - move => *. asimpl. hauto l:on use:InterpUniv_cumulative, ρ_ok_cons. -Qed. - -Lemma ST_Bind Γ i p (A : PTm) (B : PTm) : - Γ ⊨ A ∈ PUniv i -> - cons A Γ ⊨ B ∈ PUniv i -> - Γ ⊨ PBind p A B ∈ PUniv i. -Proof. - move => h0 h1. - replace i with (max i i) by lia. - move : h0 h1. - apply ST_Bind'. -Qed. - -Lemma ST_Abs Γ (a : PTm) A B i : - Γ ⊨ PBind PPi A B ∈ (PUniv i) -> - (cons A Γ) ⊨ a ∈ B -> - Γ ⊨ PAbs a ∈ PBind PPi A B. -Proof. - rename a into b. - move /SemWt_Univ => + hb ρ hρ. - move /(_ _ hρ) => [PPi hPPi]. - exists i, PPi. split => //. - simpl in hPPi. - move /InterpUniv_Bind_inv_nopf : hPPi. - move => [PA [hPA [hTot ?]]]. subst=>/=. - move => a PB ha. asimpl => hPB. - move : ρ_ok_cons (hPA) (hρ) (ha). repeat move/[apply]. - move /hb. - intros (m & PB0 & hPB0 & hPB0'). - replace PB0 with PB in * by hauto l:on use:InterpUniv_Functional'. - apply : InterpUniv_back_clos; eauto. - apply N_β'. by asimpl. - move : ha hPA. clear. hauto q:on use:adequacy. -Qed. - -Lemma ST_App Γ (b a : PTm) A B : - Γ ⊨ b ∈ PBind PPi A B -> - Γ ⊨ a ∈ A -> - Γ ⊨ PApp b a ∈ subst_PTm (scons a VarPTm) B. -Proof. - move => hf hb ρ hρ. - move /(_ ρ hρ) : hf; intros (i & PPi & hPi & hf). - move /(_ ρ hρ) : hb; intros (j & PA & hPA & hb). - simpl in hPi. - move /InterpUniv_Bind_inv_nopf : hPi. intros (PA0 & hPA0 & hTot & ?). subst. - have ? : PA0 = PA by eauto using InterpUniv_Functional'. subst. - move : hf (hb). move/[apply]. - move : hTot hb. move/[apply]. - asimpl. hauto lq:on. -Qed. - -Lemma ST_App' Γ (b a : PTm) A B U : - U = subst_PTm (scons a VarPTm) B -> - Γ ⊨ b ∈ PBind PPi A B -> - Γ ⊨ a ∈ A -> - Γ ⊨ PApp b a ∈ U. -Proof. move => ->. apply ST_App. Qed. - -Lemma ST_Pair Γ (a b : PTm) A B i : - Γ ⊨ PBind PSig A B ∈ (PUniv i) -> - Γ ⊨ a ∈ A -> - Γ ⊨ b ∈ subst_PTm (scons a VarPTm) B -> - Γ ⊨ PPair a b ∈ PBind PSig A B. -Proof. - move /SemWt_Univ => + ha hb ρ hρ. - move /(_ _ hρ) => [PPi hPPi]. - exists i, PPi. split => //. - simpl in hPPi. - move /InterpUniv_Bind_inv_nopf : hPPi. - move => [PA [hPA [hTot ?]]]. subst=>/=. - rewrite /SumSpace. right. - exists (subst_PTm ρ a), (subst_PTm ρ b). - split. - - apply rtc_refl. - - move /ha : (hρ){ha}. - move => [m][PA0][h0]h1. - move /hb : (hρ){hb}. - move => [k][PB][h2]h3. - have ? : PA0 = PA by eauto using InterpUniv_Functional'. subst. - split => // PB0. - move : h2. asimpl => *. - have ? : PB0 = PB by eauto using InterpUniv_Functional'. by subst. -Qed. - -Lemma N_Projs p (a b : PTm) : - rtc TRedSN a b -> - rtc TRedSN (PProj p a) (PProj p b). -Proof. induction 1; hauto lq:on ctrs:rtc, TRedSN. Qed. - -Lemma ST_Proj1 Γ (a : PTm) A B : - Γ ⊨ a ∈ PBind PSig A B -> - Γ ⊨ PProj PL a ∈ A. -Proof. - move => h ρ /[dup]hρ {}/h [m][PA][/= /InterpUniv_Bind_inv_nopf h0]h1. - move : h0 => [S][h2][h3]?. subst. - move : h1 => /=. - rewrite /SumSpace. - case. - - move => [v [h0 h1]]. - have {}h0 : rtc TRedSN (PProj PL (subst_PTm ρ a)) (PProj PL v) by hauto lq:on use:N_Projs. - have {}h1 : SNe (PProj PL v) by hauto lq:on ctrs:SNe. - hauto q:on use:InterpUniv_back_closs,adequacy. - - move => [a0 [b0 [h4 [h5 h6]]]]. - exists m, S. split => //=. - have {}h4 : rtc TRedSN (PProj PL (subst_PTm ρ a)) (PProj PL (PPair a0 b0)) by eauto using N_Projs. - have ? : rtc TRedSN (PProj PL (PPair a0 b0)) a0 by hauto q:on ctrs:rtc, TRedSN use:adequacy. - have : rtc TRedSN (PProj PL (subst_PTm ρ a)) a0 by hauto q:on ctrs:rtc use:@relations.rtc_r. - move => h. - apply : InterpUniv_back_closs; eauto. -Qed. - -Lemma ST_Proj2 Γ (a : PTm) A B : - Γ ⊨ a ∈ PBind PSig A B -> - Γ ⊨ PProj PR a ∈ subst_PTm (scons (PProj PL a) VarPTm) B. -Proof. - move => h ρ hρ. - move : (hρ) => {}/h [m][PA][/= /InterpUniv_Bind_inv_nopf h0]h1. - move : h0 => [S][h2][h3]?. subst. - move : h1 => /=. - rewrite /SumSpace. - case. - - move => h. - move : h => [v [h0 h1]]. - have hp : forall p, SNe (PProj p v) by hauto lq:on ctrs:SNe. - have hp' : forall p, rtc TRedSN (PProj p(subst_PTm ρ a)) (PProj p v) by eauto using N_Projs. - have hp0 := hp PL. have hp1 := hp PR => {hp}. - have hp0' := hp' PL. have hp1' := hp' PR => {hp'}. - have : S (PProj PL (subst_PTm ρ a)). apply : InterpUniv_back_closs; eauto. hauto q:on use:adequacy. - move /h3 => [PB]. asimpl => hPB. - do 2 eexists. split; eauto. - apply : InterpUniv_back_closs; eauto. hauto q:on use:adequacy. - - move => [a0 [b0 [h4 [h5 h6]]]]. - have h3_dup := h3. - specialize h3 with (1 := h5). - move : h3 => [PB hPB]. - have hr : forall p, rtc TRedSN (PProj p (subst_PTm ρ a)) (PProj p (PPair a0 b0)) by hauto l:on use: N_Projs. - have hSN : SN a0 by move : h5 h2; clear; hauto q:on use:adequacy. - have hSN' : SN b0 by hauto q:on use:adequacy. - have hrl : TRedSN (PProj PL (PPair a0 b0)) a0 by hauto lq:on ctrs:TRedSN. - have hrr : TRedSN (PProj PR (PPair a0 b0)) b0 by hauto lq:on ctrs:TRedSN. - exists m, PB. - asimpl. split. - + have hr' : rtc TRedSN (PProj PL (subst_PTm ρ a)) a0 by hauto l:on use:@relations.rtc_r. - have : S (PProj PL (subst_PTm ρ a)) by hauto lq:on use:InterpUniv_back_closs. - move => {}/h3_dup. - move => [PB0]. asimpl => hPB0. - suff : PB = PB0 by congruence. - move : hPB. asimpl => hPB. - suff : DJoin.R (subst_PTm (scons (PProj PL (subst_PTm ρ a)) ρ) B) (subst_PTm (scons a0 ρ) B). - move : InterpUniv_Join hPB0 hPB; repeat move/[apply]. done. - apply DJoin.cong. - apply DJoin.FromRedSNs. - hauto lq:on ctrs:rtc unfold:BJoin.R. - + hauto lq:on use:@relations.rtc_r, InterpUniv_back_closs. -Qed. - -Lemma ST_Conv' Γ (a : PTm) A B i : - Γ ⊨ a ∈ A -> - Γ ⊨ B ∈ PUniv i -> - Sub.R A B -> - Γ ⊨ a ∈ B. -Proof. - move => ha /SemWt_Univ h h0. - move => ρ hρ. - have {}h0 : Sub.R (subst_PTm ρ A) (subst_PTm ρ B) by - eauto using Sub.substing. - move /ha : (hρ){ha} => [m [PA [h1 h2]]]. - move /h : (hρ){h} => [S hS]. - have h3 : forall x, PA x -> S x. - move : InterpUniv_Sub h0 h1 hS; by repeat move/[apply]. - hauto lq:on. -Qed. - -Lemma ST_Conv_E Γ (a : PTm) A B i : - Γ ⊨ a ∈ A -> - Γ ⊨ B ∈ PUniv i -> - DJoin.R A B -> - Γ ⊨ a ∈ B. -Proof. - hauto l:on use:ST_Conv', Sub.FromJoin. -Qed. - -Lemma ST_Conv Γ (a : PTm) A B : - Γ ⊨ a ∈ A -> - Γ ⊨ A ≲ B -> - Γ ⊨ a ∈ B. -Proof. hauto l:on use:ST_Conv', SemLEq_SemWt. Qed. - -Lemma SE_Refl Γ (a : PTm) A : - Γ ⊨ a ∈ A -> - Γ ⊨ a ≡ a ∈ A. -Proof. hauto lq:on unfold:SemWt,SemEq use:DJoin.refl. Qed. - -Lemma SE_Symmetric Γ (a b : PTm) A : - Γ ⊨ a ≡ b ∈ A -> - Γ ⊨ b ≡ a ∈ A. -Proof. hauto q:on unfold:SemEq. Qed. - -Lemma SE_Transitive Γ (a b c : PTm) A : - Γ ⊨ a ≡ b ∈ A -> - Γ ⊨ b ≡ c ∈ A -> - Γ ⊨ a ≡ c ∈ A. -Proof. - move => ha hb. - apply SemEq_SemWt in ha, hb. - have ? : SN b by hauto l:on use:SemWt_SN. - apply SemWt_SemEq; try tauto. - hauto l:on use:DJoin.transitive. -Qed. - -Definition Γ_sub' Γ Δ := forall ρ, ρ_ok Δ ρ -> ρ_ok Γ ρ. - -Definition Γ_eq' Γ Δ := forall ρ, ρ_ok Δ ρ <-> ρ_ok Γ ρ. - -Lemma Γ_sub'_refl Γ : Γ_sub' Γ Γ. - rewrite /Γ_sub'. sfirstorder b:on. Qed. - -Lemma Γ_sub'_cons Γ Δ A B i j : - Sub.R B A -> - Γ_sub' Γ Δ -> - Γ ⊨ A ∈ PUniv i -> - Δ ⊨ B ∈ PUniv j -> - Γ_sub' (cons A Γ) (cons B Δ). -Proof. - move => hsub hsub' hA hB ρ hρ. - move => k k' A0 PA. - have hρ_inv : ρ_ok Δ (funcomp ρ shift). - move : hρ. clear. - move => hρ i. - (* specialize (hρ (shift i)). *) - move => k A PA. - move /there. move /(_ B). - rewrite /ρ_ok in hρ. - move /hρ. asimpl. by apply. - elim /lookup_inv => //=hl. - move => A1 Γ0 ? [? ?] ?. subst. - - asimpl. - move => h. - have {}/hsub' hρ' := hρ_inv. - move /SemWt_Univ : (hA) (hρ')=> /[apply]. - move => [S]hS. - move /SemWt_Univ : (hB) (hρ_inv)=>/[apply]. - move => [S1]hS1. - move /(_ var_zero j (ren_PTm shift B) S1) : hρ (hS1). asimpl. - move => /[apply]. - move /(_ ltac:(apply here)). - move => *. - suff : forall x, S1 x -> PA x by firstorder. - apply : InterpUniv_Sub; eauto. - by apply Sub.substing. - - rewrite /Γ_sub' in hsub'. - asimpl. - move => i0 Γ0 A1 B0 hi0 ? [? ?]?. subst. - move /(_ (funcomp ρ shift) hρ_inv) in hsub'. - move : hsub' hi0 => /[apply]. move => /[apply]. by asimpl. -Qed. - -Lemma Γ_sub'_SemWt Γ Δ a A : - Γ_sub' Γ Δ -> - Γ ⊨ a ∈ A -> - Δ ⊨ a ∈ A. -Proof. - move => hs ha ρ hρ. - have {}/hs hρ' := hρ. - hauto l:on. -Qed. - -Lemma Γ_eq_sub Γ Δ : Γ_eq' Γ Δ <-> Γ_sub' Γ Δ /\ Γ_sub' Δ Γ. -Proof. rewrite /Γ_eq' /Γ_sub'. hauto l:on. Qed. - -Lemma Γ_eq'_cons Γ Δ A B i j : - DJoin.R B A -> - Γ_eq' Γ Δ -> - Γ ⊨ A ∈ PUniv i -> - Δ ⊨ B ∈ PUniv j -> - Γ_eq' (cons A Γ) (cons B Δ). -Proof. - move => h. - have {h} [h0 h1] : Sub.R A B /\ Sub.R B A by hauto lq:on use:Sub.FromJoin, DJoin.symmetric. - repeat rewrite ->Γ_eq_sub. - hauto l:on use:Γ_sub'_cons. -Qed. - -Lemma Γ_eq'_refl Γ : Γ_eq' Γ Γ. -Proof. rewrite /Γ_eq'. firstorder. Qed. - -Lemma SE_Bind' Γ i j p (A0 A1 : PTm) B0 B1 : - Γ ⊨ A0 ≡ A1 ∈ PUniv i -> - cons A0 Γ ⊨ B0 ≡ B1 ∈ PUniv j -> - Γ ⊨ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv (max i j). -Proof. - move => hA hB. - apply SemEq_SemWt in hA, hB. - apply SemWt_SemEq; last by hauto l:on use:DJoin.BindCong. - hauto l:on use:ST_Bind'. - apply ST_Bind'; first by tauto. - move => ρ hρ. - suff : ρ_ok (cons A0 Γ) ρ by hauto l:on. - move : hρ. - suff : Γ_sub' (A0 :: Γ) (A1 :: Γ) by hauto l:on unfold:Γ_sub'. - apply : Γ_sub'_cons. - apply /Sub.FromJoin /DJoin.symmetric. tauto. - apply Γ_sub'_refl. hauto lq:on. - hauto lq:on. -Qed. - -Lemma SE_Bind Γ i p (A0 A1 : PTm) B0 B1 : - Γ ⊨ A0 ≡ A1 ∈ PUniv i -> - cons A0 Γ ⊨ B0 ≡ B1 ∈ PUniv i -> - Γ ⊨ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv i. -Proof. - move => *. replace i with (max i i) by lia. auto using SE_Bind'. -Qed. - -Lemma SE_Abs Γ (a b : PTm) A B i : - Γ ⊨ PBind PPi A B ∈ (PUniv i) -> - cons A Γ ⊨ a ≡ b ∈ B -> - Γ ⊨ PAbs a ≡ PAbs b ∈ PBind PPi A B. -Proof. - move => hPi /SemEq_SemWt [ha][hb]he. - apply SemWt_SemEq; eauto using DJoin.AbsCong, ST_Abs. -Qed. - -Lemma SBind_inv1 Γ i p (A : PTm) B : - Γ ⊨ PBind p A B ∈ PUniv i -> - Γ ⊨ A ∈ PUniv i. - move /SemWt_Univ => h. apply SemWt_Univ. - hauto lq:on rew:off use:InterpUniv_Bind_inv. -Qed. - -Lemma SE_AppEta Γ (b : PTm) A B i : - Γ ⊨ PBind PPi A B ∈ (PUniv i) -> - Γ ⊨ b ∈ PBind PPi A B -> - Γ ⊨ PAbs (PApp (ren_PTm shift b) (VarPTm var_zero)) ≡ b ∈ PBind PPi A B. -Proof. - move => h0 h1. apply SemWt_SemEq; eauto. - apply : ST_Abs; eauto. - have hA : Γ ⊨ A ∈ PUniv i by eauto using SBind_inv1. - eapply ST_App' with (A := ren_PTm shift A)(B:= ren_PTm (upRen_PTm_PTm shift) B). asimpl. by rewrite subst_scons_id. - 2 : { - apply : ST_Var'. - apply here. - apply : weakening_Sem_Univ; eauto. - } - change (PBind PPi (ren_PTm shift A) (ren_PTm (upRen_PTm_PTm shift) B)) with - (ren_PTm shift (PBind PPi A B)). - apply : weakening_Sem; eauto. - hauto q:on ctrs:rtc,RERed.R. -Qed. - -Lemma SE_AppAbs Γ (a : PTm) b A B i: - Γ ⊨ PBind PPi A B ∈ PUniv i -> - Γ ⊨ b ∈ A -> - (cons A Γ) ⊨ a ∈ B -> - Γ ⊨ PApp (PAbs a) b ≡ subst_PTm (scons b VarPTm) a ∈ subst_PTm (scons b VarPTm ) B. -Proof. - move => h h0 h1. apply SemWt_SemEq; eauto using ST_App, ST_Abs. - move => ρ hρ. - have {}/h0 := hρ. - move => [k][PA][hPA]hb. - move : ρ_ok_cons hPA hb (hρ); repeat move/[apply]. - move => {}/h1. - by asimpl. - apply DJoin.FromRRed0. - apply RRed.AppAbs. -Qed. - -Lemma SE_Conv' Γ (a b : PTm) A B i : - Γ ⊨ a ≡ b ∈ A -> - Γ ⊨ B ∈ PUniv i -> - Sub.R A B -> - Γ ⊨ a ≡ b ∈ B. -Proof. - move /SemEq_SemWt => [ha][hb]he hB hAB. - apply SemWt_SemEq; eauto using ST_Conv'. -Qed. - -Lemma SE_Conv Γ (a b : PTm) A B : - Γ ⊨ a ≡ b ∈ A -> - Γ ⊨ A ≲ B -> - Γ ⊨ a ≡ b ∈ B. -Proof. - move => h /SemLEq_SemWt [h0][h1][ha]hb. - eauto using SE_Conv'. -Qed. - -Lemma SBind_inst Γ p i (A : PTm) B (a : PTm) : - Γ ⊨ a ∈ A -> - Γ ⊨ PBind p A B ∈ PUniv i -> - Γ ⊨ subst_PTm (scons a VarPTm) B ∈ PUniv i. -Proof. - move => ha /SemWt_Univ hb. - apply SemWt_Univ. - move => ρ hρ. - have {}/hb := hρ. - asimpl. move => /= [S hS]. - move /InterpUniv_Bind_inv_nopf : hS. - move => [PA][hPA][hPF]?. subst. - have {}/ha := hρ. - move => [k][PA0][hPA0]ha. - have ? : PA0 = PA by hauto l:on use:InterpUniv_Functional'. subst. - have {}/hPF := ha. - move => [PB]. asimpl. - hauto lq:on. -Qed. - -Lemma SE_Pair Γ (a0 a1 b0 b1 : PTm) A B i : - Γ ⊨ PBind PSig A B ∈ (PUniv i) -> - Γ ⊨ a0 ≡ a1 ∈ A -> - Γ ⊨ b0 ≡ b1 ∈ subst_PTm (scons a0 VarPTm) B -> - Γ ⊨ PPair a0 b0 ≡ PPair a1 b1 ∈ PBind PSig A B. -Proof. - move => h /SemEq_SemWt [ha0][ha1]hae /SemEq_SemWt [hb0][hb1]hbe. - apply SemWt_SemEq; eauto using ST_Pair, DJoin.PairCong, SBind_inst, DJoin.cong, ST_Conv_E, ST_Pair. -Qed. - -Lemma SE_Proj1 Γ (a b : PTm) A B : - Γ ⊨ a ≡ b ∈ PBind PSig A B -> - Γ ⊨ PProj PL a ≡ PProj PL b ∈ A. -Proof. - move => /SemEq_SemWt [ha][hb]he. - apply SemWt_SemEq; eauto using DJoin.ProjCong, ST_Proj1. -Qed. - -Lemma SE_Proj2 Γ i (a b : PTm ) A B : - Γ ⊨ PBind PSig A B ∈ (PUniv i) -> - Γ ⊨ a ≡ b ∈ PBind PSig A B -> - Γ ⊨ PProj PR a ≡ PProj PR b ∈ subst_PTm (scons (PProj PL a) VarPTm) B. -Proof. - move => hS. - move => /SemEq_SemWt [ha][hb]he. - apply SemWt_SemEq; eauto using DJoin.ProjCong, ST_Proj2. - have h : Γ ⊨ PProj PR b ∈ subst_PTm (scons (PProj PL b) VarPTm) B by eauto using ST_Proj2. - apply : ST_Conv_E. apply h. - apply : SBind_inst. eauto using ST_Proj1. - eauto. - hauto lq:on use: DJoin.cong, DJoin.ProjCong. -Qed. - - -Lemma ST_Nat Γ i : - Γ ⊨ PNat ∈ PUniv i. -Proof. - move => ?. apply SemWt_Univ. move => ρ hρ. - eexists. by apply InterpUniv_Nat. -Qed. - -Lemma ST_Zero Γ : - Γ ⊨ PZero ∈ PNat. -Proof. - move => ρ hρ. exists 0, SNat. simpl. split. - apply InterpUniv_Nat. - apply S_Zero. -Qed. - -Lemma ST_Suc Γ (a : PTm) : - Γ ⊨ a ∈ PNat -> - Γ ⊨ PSuc a ∈ PNat. -Proof. - move => ha ρ. - move : ha => /[apply] /=. - move => [k][PA][h0 h1]. - move /InterpUniv_Nat_inv : h0 => ?. subst. - exists 0, SNat. split. apply InterpUniv_Nat. - eauto using S_Suc. -Qed. - - -Lemma sn_unmorphing' : (forall (a : PTm) (s : SN a), forall (ρ : nat -> PTm) b, a = subst_PTm ρ b -> SN b). -Proof. hauto l:on use:sn_unmorphing. Qed. - -Lemma sn_bot_up (a : PTm) i (ρ : nat -> PTm) : - SN (subst_PTm (scons (VarPTm i) ρ) a) -> SN (subst_PTm (up_PTm_PTm ρ) a). - rewrite /up_PTm_PTm. - move => h. eapply sn_unmorphing' with (ρ := (scons (VarPTm i) VarPTm)); eauto. - by asimpl. -Qed. - -Lemma sn_bot_up2 (a : PTm) j i (ρ : nat -> PTm) : - SN ((subst_PTm (scons (VarPTm j) (scons (VarPTm i) ρ)) a)) -> SN (subst_PTm (up_PTm_PTm (up_PTm_PTm ρ)) a). - rewrite /up_PTm_PTm. - move => h. eapply sn_unmorphing' with (ρ := (scons (VarPTm j) (scons (VarPTm i) VarPTm))); eauto. - by asimpl. -Qed. - -Lemma SNat_SN (a : PTm) : SNat a -> SN a. - induction 1; hauto lq:on ctrs:SN. Qed. - -Lemma ST_Ind Γ P (a : PTm) b c i : - (cons PNat Γ) ⊨ P ∈ PUniv i -> - Γ ⊨ a ∈ PNat -> - Γ ⊨ b ∈ subst_PTm (scons PZero VarPTm) P -> - (cons P (cons PNat Γ)) ⊨ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊨ PInd P a b c ∈ subst_PTm (scons a VarPTm) P. -Proof. - move => hA hc ha hb ρ hρ. - move /(_ ρ hρ) : ha => [m][PA][ha0]ha1. - move /(_ ρ hρ) : hc => [n][PA0][/InterpUniv_Nat_inv ->]. - simpl. - (* Use localiaztion to block asimpl from simplifying pind *) - set x := PInd _ _ _ _. asimpl. subst x. move : {a} (subst_PTm ρ a) . - move : (subst_PTm ρ b) ha1 => {}b ha1. - move => u hu. - have hρb : ρ_ok (cons PNat Γ) (scons (VarPTm var_zero) ρ) by apply : ρ_ok_cons; hauto lq:on ctrs:SNat, SNe use:(@InterpUniv_Nat 0). - have hρbb : ρ_ok (cons P (cons PNat Γ)) (scons (VarPTm var_zero) (scons (VarPTm var_zero) ρ)). - move /SemWt_Univ /(_ _ hρb) : hA => [S ?]. - apply : ρ_ok_cons; eauto. sauto lq:on use:adequacy. - - (* have snP : SN P by hauto l:on use:SemWt_SN. *) - have snb : SN b by hauto q:on use:adequacy. - have snP : SN (subst_PTm (up_PTm_PTm ρ) P) - by eapply sn_bot_up; move : hA hρb => /[apply]; hauto lq:on use:adequacy. - have snc : SN (subst_PTm (up_PTm_PTm (up_PTm_PTm ρ)) c) - by apply: sn_bot_up2; move : hb hρbb => /[apply]; hauto lq:on use:adequacy. - - elim : u /hu. - + exists m, PA. split. - * move : ha0. by asimpl. - * apply : InterpUniv_back_clos; eauto. - apply N_IndZero; eauto. - + move => a snea. - have hρ' : ρ_ok (cons PNat Γ) (scons a ρ)by - apply : ρ_ok_cons; eauto using (InterpUniv_Nat 0); hauto ctrs:SNat. - move /SemWt_Univ : (hA) hρ' => /[apply]. - move => [S0 hS0]. - exists i, S0. split=>//. - eapply adequacy; eauto. - apply N_Ind; eauto. - + move => a ha [j][S][h0]h1. - have hρ' : ρ_ok (cons PNat Γ) (scons (PSuc a) ρ)by - apply : ρ_ok_cons; eauto using (InterpUniv_Nat 0); hauto ctrs:SNat. - move /SemWt_Univ : (hA) (hρ') => /[apply]. - move => [S0 hS0]. - exists i, S0. split => //. - apply : InterpUniv_back_clos; eauto. - apply N_IndSuc; eauto using SNat_SN. - move : (PInd (subst_PTm (up_PTm_PTm ρ) P) a b - (subst_PTm (up_PTm_PTm (up_PTm_PTm ρ)) c)) h1. - move => r hr. - have hρ'' : ρ_ok - (cons P (cons PNat Γ)) (scons r (scons a ρ)) by - eauto using ρ_ok_cons, (InterpUniv_Nat 0). - move : hb hρ'' => /[apply]. - move => [k][PA1][h2]h3. - move : h2. asimpl => ?. - have ? : PA1 = S0 by eauto using InterpUniv_Functional'. - by subst. - + move => a a' hr ha' [k][PA1][h0]h1. - have : ρ_ok (cons PNat Γ) (scons a ρ) - by apply : ρ_ok_cons; hauto l:on use:S_Red,(InterpUniv_Nat 0). - move /SemWt_Univ : hA => /[apply]. move => [PA2]h2. - exists i, PA2. split => //. - apply : InterpUniv_back_clos; eauto. - apply N_IndCong; eauto. - suff : PA1 = PA2 by congruence. - move : h0 h2. move : InterpUniv_Join'; repeat move/[apply]. apply. - apply DJoin.FromRReds. - apply RReds.FromRPar. - apply RPar.morphing; last by apply RPar.refl. - eapply LoReds.FromSN_mutual in hr. - move /LoRed.ToRRed /RPar.FromRRed in hr. - hauto lq:on inv:nat use:RPar.refl. -Qed. - -Lemma SE_SucCong Γ (a b : PTm) : - Γ ⊨ a ≡ b ∈ PNat -> - Γ ⊨ PSuc a ≡ PSuc b ∈ PNat. -Proof. - move /SemEq_SemWt => [ha][hb]he. - apply SemWt_SemEq; eauto using ST_Suc. - hauto q:on use:REReds.suc_inv, REReds.SucCong. -Qed. - -Lemma SE_IndCong Γ P0 P1 (a0 a1 : PTm ) b0 b1 c0 c1 i : - cons PNat Γ ⊨ P0 ≡ P1 ∈ PUniv i -> - Γ ⊨ a0 ≡ a1 ∈ PNat -> - Γ ⊨ b0 ≡ b1 ∈ subst_PTm (scons PZero VarPTm) P0 -> - cons P0 (cons PNat Γ) ⊨ c0 ≡ c1 ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P0) -> - Γ ⊨ PInd P0 a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P0. -Proof. - move /SemEq_SemWt=>[hP0][hP1]hPe. - move /SemEq_SemWt=>[ha0][ha1]hae. - move /SemEq_SemWt=>[hb0][hb1]hbe. - move /SemEq_SemWt=>[hc0][hc1]hce. - apply SemWt_SemEq; eauto using ST_Ind, DJoin.IndCong. - apply ST_Conv_E with (A := subst_PTm (scons a1 VarPTm) P1) (i := i); - last by eauto using DJoin.cong', DJoin.symmetric. - apply : ST_Ind; eauto. eapply ST_Conv_E with (i := i); eauto. - apply : morphing_SemWt_Univ; eauto. - apply smorphing_ext. rewrite /smorphing_ok. - move => ξ. rewrite /funcomp. by asimpl. - by apply ST_Zero. - by apply DJoin.substing. - eapply ST_Conv_E with (i := i); eauto. - apply : Γ_sub'_SemWt; eauto. - apply : Γ_sub'_cons; eauto using DJoin.symmetric, Sub.FromJoin. - apply : Γ_sub'_cons; eauto using Sub.refl, Γ_sub'_refl, (@ST_Nat _ 0). - apply : weakening_Sem_Univ; eauto. move : hP1. - move /morphing_SemWt. apply. apply smorphing_ext. - have -> : (funcomp VarPTm shift) = funcomp (ren_PTm shift) (VarPTm) by asimpl. - apply : smorphing_ren; eauto using smorphing_ok_refl. hauto l:on inv:option. - apply ST_Suc. apply ST_Var' with (j := 0). apply here. - apply ST_Nat. - apply DJoin.renaming. by apply DJoin.substing. - apply : morphing_SemWt_Univ; eauto. - apply smorphing_ext; eauto using smorphing_ok_refl. -Qed. - -Lemma SE_IndZero Γ P i (b : PTm) c : - (cons PNat Γ) ⊨ P ∈ PUniv i -> - Γ ⊨ b ∈ subst_PTm (scons PZero VarPTm) P -> - (cons P (cons PNat Γ)) ⊨ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊨ PInd P PZero b c ≡ b ∈ subst_PTm (scons PZero VarPTm) P. -Proof. - move => hP hb hc. - apply SemWt_SemEq; eauto using ST_Zero, ST_Ind. - apply DJoin.FromRRed0. apply RRed.IndZero. -Qed. - -Lemma SE_IndSuc Γ P (a : PTm) b c i : - (cons PNat Γ) ⊨ P ∈ PUniv i -> - Γ ⊨ a ∈ PNat -> - Γ ⊨ b ∈ subst_PTm (scons PZero VarPTm) P -> - (cons P (cons PNat Γ)) ⊨ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊨ PInd P (PSuc a) b c ≡ (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) ∈ subst_PTm (scons (PSuc a) VarPTm) P. -Proof. - move => hP ha hb hc. - apply SemWt_SemEq; eauto using ST_Suc, ST_Ind. - set Δ := (X in X ⊨ _ ∈ _) in hc. - have : smorphing_ok Γ Δ (scons (PInd P a b c) (scons a VarPTm)). - apply smorphing_ext. apply smorphing_ext. apply smorphing_ok_refl. - done. eauto using ST_Ind. - move : morphing_SemWt hc; repeat move/[apply]. - by asimpl. - apply DJoin.FromRRed0. - apply RRed.IndSuc. -Qed. - -Lemma SE_ProjPair1 Γ (a b : PTm) A B i : - Γ ⊨ PBind PSig A B ∈ (PUniv i) -> - Γ ⊨ a ∈ A -> - Γ ⊨ b ∈ subst_PTm (scons a VarPTm) B -> - Γ ⊨ PProj PL (PPair a b) ≡ a ∈ A. -Proof. - move => h0 h1 h2. - apply SemWt_SemEq; eauto using ST_Proj1, ST_Pair. - apply DJoin.FromRRed0. apply RRed.ProjPair. -Qed. - -Lemma SE_ProjPair2 Γ (a b : PTm) A B i : - Γ ⊨ PBind PSig A B ∈ (PUniv i) -> - Γ ⊨ a ∈ A -> - Γ ⊨ b ∈ subst_PTm (scons a VarPTm) B -> - Γ ⊨ PProj PR (PPair a b) ≡ b ∈ subst_PTm (scons a VarPTm) B. -Proof. - move => h0 h1 h2. - apply SemWt_SemEq; eauto using ST_Proj2, ST_Pair. - apply : ST_Conv_E. apply : ST_Proj2; eauto. apply : ST_Pair; eauto. - hauto l:on use:SBind_inst. - apply DJoin.cong. apply DJoin.FromRRed0. apply RRed.ProjPair. - apply DJoin.FromRRed0. apply RRed.ProjPair. -Qed. - -Lemma SE_PairEta Γ (a : PTm) A B i : - Γ ⊨ PBind PSig A B ∈ (PUniv i) -> - Γ ⊨ a ∈ PBind PSig A B -> - Γ ⊨ a ≡ PPair (PProj PL a) (PProj PR a) ∈ PBind PSig A B. -Proof. - move => h0 h. apply SemWt_SemEq; eauto. - apply : ST_Pair; eauto using ST_Proj1, ST_Proj2. - rewrite /DJoin.R. hauto lq:on ctrs:rtc,RERed.R. -Qed. - -Lemma SE_PairExt Γ (a b : PTm) A B i : - Γ ⊨ PBind PSig A B ∈ PUniv i -> - Γ ⊨ a ∈ PBind PSig A B -> - Γ ⊨ b ∈ PBind PSig A B -> - Γ ⊨ PProj PL a ≡ PProj PL b ∈ A -> - Γ ⊨ PProj PR a ≡ PProj PR b ∈ subst_PTm (scons (PProj PL a) VarPTm) B -> - Γ ⊨ a ≡ b ∈ PBind PSig A B. -Proof. - move => h0 ha hb h1 h2. - suff h : Γ ⊨ a ≡ PPair (PProj PL a) (PProj PR a) ∈ PBind PSig A B /\ - Γ ⊨ PPair (PProj PL b) (PProj PR b) ≡ b ∈ PBind PSig A B /\ - Γ ⊨ PPair (PProj PL a) (PProj PR a) ≡ PPair (PProj PL b) (PProj PR b) ∈ PBind PSig A B - by decompose [and] h; eauto using SE_Transitive, SE_Symmetric. - eauto 20 using SE_PairEta, SE_Symmetric, SE_Pair. -Qed. - -Lemma SE_FunExt Γ (a b : PTm) A B i : - Γ ⊨ PBind PPi A B ∈ PUniv i -> - Γ ⊨ a ∈ PBind PPi A B -> - Γ ⊨ b ∈ PBind PPi A B -> - A :: Γ ⊨ PApp (ren_PTm shift a) (VarPTm var_zero) ≡ PApp (ren_PTm shift b) (VarPTm var_zero) ∈ B -> - Γ ⊨ a ≡ b ∈ PBind PPi A B. -Proof. - move => hpi ha hb he. - move : SE_Abs (hpi) he. repeat move/[apply]. move => he. - have /SE_Symmetric : Γ ⊨ PAbs (PApp (ren_PTm shift a) (VarPTm var_zero)) ≡ a ∈ PBind PPi A B by eauto using SE_AppEta. - have : Γ ⊨ PAbs (PApp (ren_PTm shift b) (VarPTm var_zero)) ≡ b ∈ PBind PPi A B by eauto using SE_AppEta. - eauto using SE_Transitive. -Qed. - -Lemma SE_Nat Γ (a b : PTm) : - Γ ⊨ a ≡ b ∈ PNat -> - Γ ⊨ PSuc a ≡ PSuc b ∈ PNat. -Proof. - move /SemEq_SemWt => [ha][hb]hE. - apply SemWt_SemEq; eauto using ST_Suc. - eauto using DJoin.SucCong. -Qed. - -Lemma SE_App Γ i (b0 b1 a0 a1 : PTm) A B : - Γ ⊨ PBind PPi A B ∈ (PUniv i) -> - Γ ⊨ b0 ≡ b1 ∈ PBind PPi A B -> - Γ ⊨ a0 ≡ a1 ∈ A -> - Γ ⊨ PApp b0 a0 ≡ PApp b1 a1 ∈ subst_PTm (scons a0 VarPTm) B. -Proof. - move => hPi. - move => /SemEq_SemWt [hb0][hb1]hb /SemEq_SemWt [ha0][ha1]ha. - apply SemWt_SemEq; eauto using DJoin.AppCong, ST_App. - apply : ST_Conv_E; eauto using ST_App, DJoin.cong, DJoin.symmetric, SBind_inst. -Qed. - -Lemma SSu_Eq Γ (A B : PTm) i : - Γ ⊨ A ≡ B ∈ PUniv i -> - Γ ⊨ A ≲ B. -Proof. move /SemEq_SemWt => h. - qauto l:on use:SemWt_SemLEq, Sub.FromJoin. -Qed. - -Lemma SSu_Transitive Γ (A B C : PTm) : - Γ ⊨ A ≲ B -> - Γ ⊨ B ≲ C -> - Γ ⊨ A ≲ C. -Proof. - move => ha hb. - apply SemLEq_SemWt in ha, hb. - have ? : SN B by hauto l:on use:SemWt_SN. - move : ha => [ha0 [i [ha1 ha2]]]. move : hb => [hb0 [j [hb1 hb2]]]. - qauto l:on use:SemWt_SemLEq, Sub.transitive. -Qed. - -Lemma ST_Univ' Γ i j : - i < j -> - Γ ⊨ PUniv i ∈ PUniv j. -Proof. - move => ?. - apply SemWt_Univ. move => ρ hρ. eexists. by apply InterpUniv_Univ. -Qed. - -Lemma ST_Univ Γ i : - Γ ⊨ PUniv i ∈ PUniv (S i). -Proof. - apply ST_Univ'. lia. -Qed. - -Lemma SSu_Univ Γ i j : - i <= j -> - Γ ⊨ PUniv i ≲ PUniv j. -Proof. - move => h. apply : SemWt_SemLEq; eauto using ST_Univ. - sauto lq:on. -Qed. - -Lemma SSu_Pi Γ (A0 A1 : PTm ) B0 B1 : - Γ ⊨ A1 ≲ A0 -> - cons A0 Γ ⊨ B0 ≲ B1 -> - Γ ⊨ PBind PPi A0 B0 ≲ PBind PPi A1 B1. -Proof. - move => hA hB. - have ? : SN A0 /\ SN A1 /\ SN B0 /\ SN B1 - by hauto l:on use:SemLEq_SN_Sub. - apply SemLEq_SemWt in hA, hB. - move : hA => [hA0][i][hA1]hA2. - move : hB => [hB0][j][hB1]hB2. - apply : SemWt_SemLEq; last by hauto l:on use:Sub.PiCong. - hauto l:on use:ST_Bind'. - apply ST_Bind'; eauto. - move => ρ hρ. - suff : ρ_ok (cons A0 Γ) ρ by hauto l:on. - move : hρ. suff : Γ_sub' (A0 :: Γ) (A1 :: Γ) - by hauto l:on unfold:Γ_sub'. - apply : Γ_sub'_cons; eauto. apply Γ_sub'_refl. -Qed. - -Lemma SSu_Sig Γ (A0 A1 : PTm) B0 B1 : - Γ ⊨ A0 ≲ A1 -> - cons A1 Γ ⊨ B0 ≲ B1 -> - Γ ⊨ PBind PSig A0 B0 ≲ PBind PSig A1 B1. -Proof. - move => hA hB. - have ? : SN A0 /\ SN A1 /\ SN B0 /\ SN B1 - by hauto l:on use:SemLEq_SN_Sub. - apply SemLEq_SemWt in hA, hB. - move : hA => [hA0][i][hA1]hA2. - move : hB => [hB0][j][hB1]hB2. - apply : SemWt_SemLEq; last by hauto l:on use:Sub.SigCong. - 2 : { hauto l:on use:ST_Bind'. } - apply ST_Bind'; eauto. - move => ρ hρ. - suff : ρ_ok (cons A1 Γ) ρ by hauto l:on. - move : hρ. suff : Γ_sub' (A1 :: Γ) (A0 :: Γ) by hauto l:on. - apply : Γ_sub'_cons; eauto. - apply Γ_sub'_refl. -Qed. - -Lemma SSu_Pi_Proj1 Γ (A0 A1 : PTm) B0 B1 : - Γ ⊨ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> - Γ ⊨ A1 ≲ A0. -Proof. - move /SemLEq_SemWt => [h0][h1][h2]he. - apply : SemWt_SemLEq; eauto using SBind_inv1. - hauto lq:on rew:off use:Sub.bind_inj. -Qed. - -Lemma SSu_Sig_Proj1 Γ (A0 A1 : PTm) B0 B1 : - Γ ⊨ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> - Γ ⊨ A0 ≲ A1. -Proof. - move /SemLEq_SemWt => [h0][h1][h2]he. - apply : SemWt_SemLEq; eauto using SBind_inv1. - hauto lq:on rew:off use:Sub.bind_inj. -Qed. - -Lemma SSu_Pi_Proj2 Γ (a0 a1 A0 A1 : PTm) B0 B1 : - Γ ⊨ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> - Γ ⊨ a0 ≡ a1 ∈ A1 -> - Γ ⊨ subst_PTm (scons a0 VarPTm) B0 ≲ subst_PTm (scons a1 VarPTm) B1. -Proof. - move /SemLEq_SemWt => [/Sub.bind_inj [_ [h1 h2]]]. - move => [i][hP0]hP1 /SemEq_SemWt [ha0][ha1]ha. - apply : SemWt_SemLEq; eauto using SBind_inst; - last by hauto l:on use:Sub.cong. - apply SBind_inst with (p := PPi) (A := A0); eauto. - apply : ST_Conv'; eauto. hauto l:on use:SBind_inv1. -Qed. - -Lemma SSu_Sig_Proj2 Γ (a0 a1 A0 A1 : PTm) B0 B1 : - Γ ⊨ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> - Γ ⊨ a0 ≡ a1 ∈ A0 -> - Γ ⊨ subst_PTm (scons a0 VarPTm) B0 ≲ subst_PTm (scons a1 VarPTm) B1. -Proof. - move /SemLEq_SemWt => [/Sub.bind_inj [_ [h1 h2]]]. - move => [i][hP0]hP1 /SemEq_SemWt [ha0][ha1]ha. - apply : SemWt_SemLEq; eauto using SBind_inst; - last by hauto l:on use:Sub.cong. - apply SBind_inst with (p := PSig) (A := A1); eauto. - apply : ST_Conv'; eauto. hauto l:on use:SBind_inv1. -Qed. - -#[export]Hint Resolve ST_Var ST_Bind ST_Abs ST_App ST_Pair ST_Proj1 ST_Proj2 ST_Univ ST_Conv - SE_Refl SE_Symmetric SE_Transitive SE_Bind SE_Abs SE_App SE_Proj1 SE_Proj2 - SE_Conv SSu_Pi_Proj1 SSu_Pi_Proj2 SSu_Sig_Proj1 SSu_Sig_Proj2 SSu_Eq SSu_Transitive SSu_Pi SSu_Sig SemWff_nil SemWff_cons SSu_Univ SE_AppAbs SE_ProjPair1 SE_ProjPair2 SE_AppEta SE_PairEta ST_Nat ST_Ind ST_Suc ST_Zero SE_IndCong SE_SucCong SE_IndZero SE_IndSuc SE_SucCong SE_PairExt SE_FunExt : sem. diff --git a/theories/preservation.v b/theories/preservation.v deleted file mode 100644 index 301553e..0000000 --- a/theories/preservation.v +++ /dev/null @@ -1,172 +0,0 @@ -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common typing structural fp_red admissible. -From Hammer Require Import Tactics. -Require Import ssreflect. -Require Import Psatz. -Require Import Coq.Logic.FunctionalExtensionality. - - -Lemma Ind_Inv Γ P (a : PTm) b c U : - Γ ⊢ PInd P a b c ∈ U -> - exists i, (cons PNat Γ) ⊢ P ∈ PUniv i /\ - Γ ⊢ a ∈ PNat /\ - Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P /\ - (cons P (cons PNat Γ)) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) /\ - Γ ⊢ subst_PTm (scons a VarPTm) P ≲ U. -Proof. - move E : (PInd P a b c)=> u hu. - move : P a b c E. elim : Γ u U / hu => //=. - - move => Γ P a b c i hP _ ha _ hb _ hc _ P0 a0 b0 c0 [*]. subst. - exists i. repeat split => //=. - have : Γ ⊢ subst_PTm (scons a VarPTm) P ∈ subst_PTm (scons a VarPTm) (PUniv i) by hauto l:on use:substing_wt. - eauto using E_Refl, Su_Eq. - - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma E_Abs Γ a b A B : - A :: Γ ⊢ a ≡ b ∈ B -> - Γ ⊢ PAbs a ≡ PAbs b ∈ PBind PPi A B. -Proof. - move => h. - have [i hA] : exists i, Γ ⊢ A ∈ PUniv i by hauto l:on use:wff_mutual inv:Wff. - have [j hB] : exists j, A :: Γ ⊢ B ∈ PUniv j by hauto l:on use:regularity. - have hΓ : ⊢ Γ by sfirstorder use:wff_mutual. - have hΓ' : ⊢ A::Γ by eauto with wt. - set k := max i j. - have [? ?] : i <= k /\ j <= k by lia. - have {}hA : Γ ⊢ A ∈ PUniv k by hauto l:on use:T_Conv, Su_Univ. - have {}hB : A :: Γ ⊢ B ∈ PUniv k by hauto lq:on use:T_Conv, Su_Univ. - have hPi : Γ ⊢ PBind PPi A B ∈ PUniv k by eauto with wt. - apply : E_FunExt; eauto with wt. - hauto lq:on rew:off use:regularity, T_Abs. - hauto lq:on rew:off use:regularity, T_Abs. - apply : E_Transitive => /=. apply E_AppAbs. - hauto lq:on use:T_Eta, regularity. - apply /E_Symmetric /E_Transitive. apply E_AppAbs. - hauto lq:on use:T_Eta, regularity. - asimpl. rewrite !subst_scons_id. by apply E_Symmetric. -Qed. - -Lemma E_Pair Γ a0 b0 a1 b1 A B i : - Γ ⊢ PBind PSig A B ∈ PUniv i -> - Γ ⊢ a0 ≡ a1 ∈ A -> - Γ ⊢ b0 ≡ b1 ∈ subst_PTm (scons a0 VarPTm) B -> - Γ ⊢ PPair a0 b0 ≡ PPair a1 b1 ∈ PBind PSig A B. -Proof. - move => hSig ha hb. - have [ha0 ha1] : Γ ⊢ a0 ∈ A /\ Γ ⊢ a1 ∈ A by hauto l:on use:regularity. - have [hb0 hb1] : Γ ⊢ b0 ∈ subst_PTm (scons a0 VarPTm) B /\ - Γ ⊢ b1 ∈ subst_PTm (scons a0 VarPTm) B by hauto l:on use:regularity. - have hp : Γ ⊢ PPair a0 b0 ∈ PBind PSig A B by eauto with wt. - have hp' : Γ ⊢ PPair a1 b1 ∈ PBind PSig A B. econstructor; eauto with wt; [idtac]. - apply : T_Conv; eauto. apply : Su_Sig_Proj2; by eauto using Su_Eq, E_Refl. - have ea : Γ ⊢ PProj PL (PPair a0 b0) ≡ a0 ∈ A by eauto with wt. - have : Γ ⊢ PProj PR (PPair a0 b0) ≡ b0 ∈ subst_PTm (scons a0 VarPTm) B by eauto with wt. - have : Γ ⊢ PProj PL (PPair a1 b1) ≡ a1 ∈ A by eauto using E_ProjPair1 with wt. - have : Γ ⊢ PProj PR (PPair a1 b1) ≡ b1 ∈ subst_PTm (scons a0 VarPTm) B. - apply : E_Conv; eauto using E_ProjPair2 with wt. - apply : Su_Sig_Proj2. apply /Su_Eq /E_Refl. eassumption. - apply : E_Transitive. apply E_ProjPair1. by eauto with wt. - by eauto using E_Symmetric. - move => *. - apply : E_PairExt; eauto using E_Symmetric, E_Transitive. - apply : E_Conv. by eauto using E_Symmetric, E_Transitive. - apply : Su_Sig_Proj2. apply /Su_Eq /E_Refl. eassumption. - apply : E_Transitive. by eauto. apply /E_Symmetric /E_Transitive. - by eauto using E_ProjPair1. - eauto. -Qed. - -Lemma Suc_Inv Γ (a : PTm) A : - Γ ⊢ PSuc a ∈ A -> Γ ⊢ a ∈ PNat /\ Γ ⊢ PNat ≲ A. -Proof. - move E : (PSuc a) => u hu. - move : a E. - elim : Γ u A /hu => //=. - - move => Γ a ha iha a0 [*]. subst. - split => //=. eapply wff_mutual in ha. - apply : Su_Eq. - apply E_Refl. by apply T_Nat'. - - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma RRed_Eq Γ (a b : PTm) A : - Γ ⊢ a ∈ A -> - RRed.R a b -> - Γ ⊢ a ≡ b ∈ A. -Proof. - move => + h. move : Γ A. elim : a b /h. - - apply E_AppAbs. - - move => p a b Γ A. - case : p => //=. - + apply E_ProjPair1. - + move /Proj2_Inv. move => [A0][B0][hab]hA0. - move /Pair_Inv : hab => [A1][B1][ha][hb]hS. - have [i ?] : exists i, Γ ⊢ PBind PSig A1 B1 ∈ PUniv i by sfirstorder use:regularity_sub0. - have : Γ ⊢ PPair a b ∈ PBind PSig A1 B1 by hauto lq:on ctrs:Wt. - move /T_Proj1. - move /E_ProjPair1 /E_Symmetric => h. - have /Su_Sig_Proj1 hSA := hS. - have : Γ ⊢ subst_PTm (scons a VarPTm) B1 ≲ subst_PTm (scons (PProj PL (PPair a b)) VarPTm) B0 by - apply : Su_Sig_Proj2; eauto. - move : hA0 => /[swap]. move : Su_Transitive. repeat move/[apply]. - move {hS}. - move => ?. apply : E_Conv; eauto. apply : typing.E_ProjPair2; eauto. - - hauto lq:on use:Ind_Inv, E_Conv, E_IndZero. - - move => P a b c Γ A. - move /Ind_Inv. - move => [i][hP][ha][hb][hc]hSu. - apply : E_Conv; eauto. - apply : E_IndSuc'; eauto. - hauto l:on use:Suc_Inv. - - qauto l:on use:Abs_Inv, E_Conv, regularity_sub0, E_Abs. - - move => a0 a1 b ha iha Γ A /App_Inv [A0][B0][ih0][ih1]hU. - have {}/iha iha := ih0. - have [i hP] : exists i, Γ ⊢ PBind PPi A0 B0 ∈ PUniv i by sfirstorder use:regularity. - apply : E_Conv; eauto. - apply : E_App; eauto using E_Refl. - - move => a0 b0 b1 ha iha Γ A /App_Inv [A0][B0][ih0][ih1]hU. - have {}/iha iha := ih1. - have [i hP] : exists i, Γ ⊢ PBind PPi A0 B0 ∈ PUniv i by sfirstorder use:regularity. - apply : E_Conv; eauto. - apply : E_App; eauto. - sfirstorder use:E_Refl. - - move => a0 a1 b ha iha Γ A /Pair_Inv. - move => [A0][B0][h0][h1]hU. - have [i hP] : exists i, Γ ⊢ PBind PSig A0 B0 ∈ PUniv i by eauto using regularity_sub0. - have {}/iha iha := h0. - apply : E_Conv; eauto. - apply : E_Pair; eauto using E_Refl. - - move => a b0 b1 ha iha Γ A /Pair_Inv. - move => [A0][B0][h0][h1]hU. - have [i hP] : exists i, Γ ⊢ PBind PSig A0 B0 ∈ PUniv i by eauto using regularity_sub0. - have {}/iha iha := h1. - apply : E_Conv; eauto. - apply : E_Pair; eauto using E_Refl. - - case. - + move => a0 a1 ha iha Γ A /Proj1_Inv [A0][B0][h0]hU. - apply : E_Conv; eauto. - qauto l:on ctrs:Eq,Wt. - + move => a0 a1 ha iha Γ A /Proj2_Inv [A0][B0][h0]hU. - have [i hP] : exists i, Γ ⊢ PBind PSig A0 B0 ∈ PUniv i by sfirstorder use:regularity. - apply : E_Conv; eauto. - apply : E_Proj2; eauto. - - move => p A0 A1 B hA ihA Γ U /Bind_Inv [i][h0][h1]hU. - have {}/ihA ihA := h0. - apply : E_Conv; eauto. - apply E_Bind'; eauto using E_Refl. - - move => p A0 A1 B hA ihA Γ U /Bind_Inv [i][h0][h1]hU. - have {}/ihA ihA := h1. - apply : E_Conv; eauto. - apply E_Bind'; eauto using E_Refl. - - hauto lq:on rew:off use:Ind_Inv, E_Conv, E_IndCong db:wt. - - hauto lq:on rew:off use:Ind_Inv, E_Conv, E_IndCong db:wt. - - hauto lq:on rew:off use:Ind_Inv, E_Conv, E_IndCong db:wt. - - hauto lq:on rew:off use:Ind_Inv, E_Conv, E_IndCong db:wt. - - hauto lq:on use:Suc_Inv, E_Conv, E_SucCong. -Qed. - -Theorem subject_reduction Γ (a b A : PTm) : - Γ ⊢ a ∈ A -> - RRed.R a b -> - Γ ⊢ b ∈ A. -Proof. hauto lq:on use:RRed_Eq, regularity. Qed. diff --git a/theories/soundness.v b/theories/soundness.v deleted file mode 100644 index 877e3fb..0000000 --- a/theories/soundness.v +++ /dev/null @@ -1,15 +0,0 @@ -Require Import Autosubst2.unscoped Autosubst2.syntax. -Require Import fp_red logrel typing. -From Hammer Require Import Tactics. - -Theorem fundamental_theorem : - (forall Γ, ⊢ Γ -> ⊨ Γ) /\ - (forall Γ a A, Γ ⊢ a ∈ A -> Γ ⊨ a ∈ A) /\ - (forall Γ a b A, Γ ⊢ a ≡ b ∈ A -> Γ ⊨ a ≡ b ∈ A) /\ - (forall Γ a b, Γ ⊢ a ≲ b -> Γ ⊨ a ≲ b). - apply wt_mutual; eauto with sem. - Unshelve. all : exact 0. -Qed. - -Lemma synsub_to_usub : forall Γ (a b : PTm), Γ ⊢ a ≲ b -> SN a /\ SN b /\ Sub.R a b. -Proof. hauto lq:on rew:off use:fundamental_theorem, SemLEq_SN_Sub. Qed. diff --git a/theories/structural.v b/theories/structural.v deleted file mode 100644 index 207447d..0000000 --- a/theories/structural.v +++ /dev/null @@ -1,845 +0,0 @@ -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common typing. -From Hammer Require Import Tactics. -Require Import ssreflect. -Require Import Psatz. - -Lemma wff_mutual : - (forall Γ, ⊢ Γ -> True) /\ - (forall Γ (a A : PTm), Γ ⊢ a ∈ A -> ⊢ Γ) /\ - (forall Γ (a b A : PTm), Γ ⊢ a ≡ b ∈ A -> ⊢ Γ) /\ - (forall Γ (A B : PTm), Γ ⊢ A ≲ B -> ⊢ Γ). -Proof. apply wt_mutual; eauto. Qed. - -#[export]Hint Constructors Wt Wff Eq : wt. - -Lemma T_Nat' Γ : - ⊢ Γ -> - Γ ⊢ PNat ∈ PUniv 0. -Proof. apply T_Nat. Qed. - -Lemma renaming_up (ξ : nat -> nat) Δ Γ A : - renaming_ok Δ Γ ξ -> - renaming_ok (cons (ren_PTm ξ A) Δ) (cons A Γ) (upRen_PTm_PTm ξ) . -Proof. - move => h i A0. - elim /lookup_inv => //=_. - - move => A1 Γ0 ? [*]. subst. apply here'. by asimpl. - - move => i0 Γ0 A1 B h' ? [*]. subst. - apply : there'; eauto. by asimpl. -Qed. - -Lemma Su_Wt Γ a i : - Γ ⊢ a ∈ PUniv i -> - Γ ⊢ a ≲ a. -Proof. hauto lq:on ctrs:LEq, Eq. Qed. - -Lemma Wt_Univ Γ a A i - (h : Γ ⊢ a ∈ A) : - Γ ⊢ @PUniv i ∈ PUniv (S i). -Proof. - hauto lq:on ctrs:Wt use:wff_mutual. -Qed. - -Lemma Bind_Inv Γ p (A : PTm) B U : - Γ ⊢ PBind p A B ∈ U -> - exists i, Γ ⊢ A ∈ PUniv i /\ - (cons A Γ) ⊢ B ∈ PUniv i /\ - Γ ⊢ PUniv i ≲ U. -Proof. - move E :(PBind p A B) => T h. - move : p A B E. - elim : Γ T U / h => //=. - - move => Γ i p A B hA _ hB _ p0 A0 B0 [*]. subst. - exists i. repeat split => //=. - eapply wff_mutual in hA. - apply Su_Univ; eauto. - - hauto lq:on rew:off ctrs:LEq. -Qed. - -Lemma T_App' Γ (b a : PTm) A B U : - U = subst_PTm (scons a VarPTm) B -> - Γ ⊢ b ∈ PBind PPi A B -> - Γ ⊢ a ∈ A -> - Γ ⊢ PApp b a ∈ U. -Proof. move => ->. apply T_App. Qed. - -Lemma T_Pair' Γ (a b : PTm ) A B i U : - U = subst_PTm (scons a VarPTm) B -> - Γ ⊢ a ∈ A -> - Γ ⊢ b ∈ U -> - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> - Γ ⊢ PPair a b ∈ PBind PSig A B. -Proof. - move => ->. eauto using T_Pair. -Qed. - -Lemma E_IndCong' Γ P0 P1 (a0 a1 : PTm ) b0 b1 c0 c1 i U : - U = subst_PTm (scons a0 VarPTm) P0 -> - (cons PNat Γ) ⊢ P0 ∈ PUniv i -> - (cons PNat Γ) ⊢ P0 ≡ P1 ∈ PUniv i -> - Γ ⊢ a0 ≡ a1 ∈ PNat -> - Γ ⊢ b0 ≡ b1 ∈ subst_PTm (scons PZero VarPTm) P0 -> - (cons P0 (cons PNat Γ)) ⊢ c0 ≡ c1 ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P0) -> - Γ ⊢ PInd P0 a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ U. -Proof. move => ->. apply E_IndCong. Qed. - -Lemma T_Ind' Γ P (a : PTm) b c i U : - U = subst_PTm (scons a VarPTm) P -> - cons PNat Γ ⊢ P ∈ PUniv i -> - Γ ⊢ a ∈ PNat -> - Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - cons P (cons PNat Γ) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊢ PInd P a b c ∈ U. -Proof. move =>->. apply T_Ind. Qed. - -Lemma T_Proj2' Γ (a : PTm) A B U : - U = subst_PTm (scons (PProj PL a) VarPTm) B -> - Γ ⊢ a ∈ PBind PSig A B -> - Γ ⊢ PProj PR a ∈ U. -Proof. move => ->. apply T_Proj2. Qed. - -Lemma E_Proj2' Γ i (a b : PTm) A B U : - U = subst_PTm (scons (PProj PL a) VarPTm) B -> - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> - Γ ⊢ a ≡ b ∈ PBind PSig A B -> - Γ ⊢ PProj PR a ≡ PProj PR b ∈ U. -Proof. move => ->. apply E_Proj2. Qed. - -Lemma E_Bind' Γ i p (A0 A1 : PTm) B0 B1 : - Γ ⊢ A0 ∈ PUniv i -> - Γ ⊢ A0 ≡ A1 ∈ PUniv i -> - cons A0 Γ ⊢ B0 ≡ B1 ∈ PUniv i -> - Γ ⊢ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv i. -Proof. hauto lq:on use:E_Bind, wff_mutual. Qed. - -Lemma E_App' Γ i (b0 b1 a0 a1 : PTm) A B U : - U = subst_PTm (scons a0 VarPTm) B -> - Γ ⊢ PBind PPi A B ∈ (PUniv i) -> - Γ ⊢ b0 ≡ b1 ∈ PBind PPi A B -> - Γ ⊢ a0 ≡ a1 ∈ A -> - Γ ⊢ PApp b0 a0 ≡ PApp b1 a1 ∈ U. -Proof. move => ->. apply E_App. Qed. - -Lemma E_AppAbs' Γ (a : PTm) b A B i u U : - u = subst_PTm (scons b VarPTm) a -> - U = subst_PTm (scons b VarPTm ) B -> - Γ ⊢ PBind PPi A B ∈ PUniv i -> - Γ ⊢ b ∈ A -> - cons A Γ ⊢ a ∈ B -> - Γ ⊢ PApp (PAbs a) b ≡ u ∈ U. - move => -> ->. apply E_AppAbs. Qed. - -Lemma E_ProjPair2' Γ (a b : PTm) A B i U : - U = subst_PTm (scons a VarPTm) B -> - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> - Γ ⊢ a ∈ A -> - Γ ⊢ b ∈ subst_PTm (scons a VarPTm) B -> - Γ ⊢ PProj PR (PPair a b) ≡ b ∈ U. -Proof. move => ->. apply E_ProjPair2. Qed. - -(* Lemma E_AppEta' Γ (b : PTm ) A B i u : *) -(* u = (PApp (ren_PTm shift b) (VarPTm var_zero)) -> *) -(* Γ ⊢ PBind PPi A B ∈ (PUniv i) -> *) -(* Γ ⊢ b ∈ PBind PPi A B -> *) -(* Γ ⊢ PAbs u ≡ b ∈ PBind PPi A B. *) -(* Proof. qauto l:on use:wff_mutual, E_AppEta. Qed. *) - -Lemma Su_Pi_Proj2' Γ (a0 a1 A0 A1 : PTm ) B0 B1 U T : - U = subst_PTm (scons a0 VarPTm) B0 -> - T = subst_PTm (scons a1 VarPTm) B1 -> - Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> - Γ ⊢ a0 ≡ a1 ∈ A1 -> - Γ ⊢ U ≲ T. -Proof. move => -> ->. apply Su_Pi_Proj2. Qed. - -Lemma Su_Sig_Proj2' Γ (a0 a1 A0 A1 : PTm) B0 B1 U T : - U = subst_PTm (scons a0 VarPTm) B0 -> - T = subst_PTm (scons a1 VarPTm) B1 -> - Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> - Γ ⊢ a0 ≡ a1 ∈ A0 -> - Γ ⊢ U ≲ T. -Proof. move => -> ->. apply Su_Sig_Proj2. Qed. - -Lemma E_IndZero' Γ P i (b : PTm) c U : - U = subst_PTm (scons PZero VarPTm) P -> - cons PNat Γ ⊢ P ∈ PUniv i -> - Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - cons P (cons PNat Γ) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊢ PInd P PZero b c ≡ b ∈ U. -Proof. move => ->. apply E_IndZero. Qed. - -Lemma Wff_Cons' Γ (A : PTm) i : - Γ ⊢ A ∈ PUniv i -> - (* -------------------------------- *) - ⊢ cons A Γ. -Proof. hauto lq:on rew:off use:Wff_Cons, wff_mutual. Qed. - -Lemma E_IndSuc' Γ P (a : PTm) b c i u U : - u = subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c -> - U = subst_PTm (scons (PSuc a) VarPTm) P -> - cons PNat Γ ⊢ P ∈ PUniv i -> - Γ ⊢ a ∈ PNat -> - Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - (cons P (cons PNat Γ)) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊢ PInd P (PSuc a) b c ≡ u ∈ U. -Proof. move => ->->. apply E_IndSuc. Qed. - -Lemma renaming : - (forall Γ, ⊢ Γ -> True) /\ - (forall Γ (a A : PTm), Γ ⊢ a ∈ A -> forall Δ (ξ : nat -> nat), ⊢ Δ -> renaming_ok Δ Γ ξ -> - Δ ⊢ ren_PTm ξ a ∈ ren_PTm ξ A) /\ - (forall Γ (a b A : PTm), Γ ⊢ a ≡ b ∈ A -> forall Δ (ξ : nat -> nat), ⊢ Δ -> renaming_ok Δ Γ ξ -> - Δ ⊢ ren_PTm ξ a ≡ ren_PTm ξ b ∈ ren_PTm ξ A) /\ - (forall Γ (A B : PTm), Γ ⊢ A ≲ B -> forall Δ (ξ : nat -> nat), ⊢ Δ -> renaming_ok Δ Γ ξ -> - Δ ⊢ ren_PTm ξ A ≲ ren_PTm ξ B). -Proof. - apply wt_mutual => //=; eauto 3 with wt. - - hauto lq:on rew:off ctrs:Wt, Wff use:renaming_up. - - move => Γ a A B i hP ihP ha iha Δ ξ hΔ hξ. - apply : T_Abs; eauto. - move : ihP(hΔ) (hξ); repeat move/[apply]. move/Bind_Inv. - hauto lq:on rew:off ctrs:Wff,Wt use:renaming_up. - - move => *. apply : T_App'; eauto. by asimpl. - - move => Γ a A b B i hA ihA hB ihB hS ihS Δ ξ hξ hΔ. - eapply T_Pair' with (U := ren_PTm ξ (subst_PTm (scons a VarPTm) B));eauto. by asimpl. - - move => Γ a A B ha iha Δ ξ hΔ hξ. apply : T_Proj2'; eauto. by asimpl. - - move => Γ P a b c i hP ihP ha iha hb ihb hc ihc Δ ξ hΔ hξ. - move => [:hP]. - apply : T_Ind'; eauto. by asimpl. - abstract :hP. apply ihP. by eauto using Wff_Cons', T_Nat'. - hauto l:on use:renaming_up. - set x := subst_PTm _ _. have -> : x = ren_PTm ξ (subst_PTm (scons PZero VarPTm) P) by subst x; asimpl. - by subst x; eauto. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ. subst Ξ. - apply : Wff_Cons'; eauto. apply hP. - move /(_ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. - set Ξ' := (cons _ _) . - have : renaming_ok Ξ Ξ' (upRen_PTm_PTm (upRen_PTm_PTm ξ)). - by do 2 apply renaming_up. - move /[swap] /[apply]. - by asimpl. - - hauto lq:on ctrs:Wt,LEq. - - hauto lq:on ctrs:Eq. - - hauto lq:on rew:off use:E_Bind', Wff_Cons, renaming_up. - - move => *. apply : E_App'; eauto. by asimpl. - - move => *. apply : E_Proj2'; eauto. by asimpl. - - move => Γ P0 P1 a0 a1 b0 b1 c0 c1 i hP0 ihP0 hP ihP ha iha hb ihb hc ihc. - move => Δ ξ hΔ hξ [:hP' hren]. - apply E_IndCong' with (i := i); eauto with wt. - by asimpl. - apply ihP0. - abstract : hP'. - qauto l:on use:renaming_up, Wff_Cons', T_Nat'. - abstract : hren. - qauto l:on use:renaming_up, Wff_Cons', T_Nat'. - apply ihP; eauto with wt. - move : ihb (hΔ) (hξ); do! move/[apply]. by asimpl. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ. - subst Ξ. apply :Wff_Cons'; eauto. - move /(_ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. - move /(_ ltac:(qauto l:on use:renaming_up)). - suff : ren_PTm (upRen_PTm_PTm (upRen_PTm_PTm ξ)) - (ren_PTm shift - (subst_PTm - (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift)) P0)) = ren_PTm shift - (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift)) - (ren_PTm (upRen_PTm_PTm ξ) P0)) by scongruence. - by asimpl. - - qauto l:on ctrs:Eq, LEq. - - move => Γ a b A B i hP ihP hb ihb ha iha Δ ξ hΔ hξ. - move : ihP (hξ) (hΔ). repeat move/[apply]. - move /Bind_Inv. - move => [j][h0][h1]h2. - have ? : Δ ⊢ PBind PPi (ren_PTm ξ A) (ren_PTm (upRen_PTm_PTm ξ) B) ∈ PUniv j by qauto l:on ctrs:Wt. - apply : E_AppAbs'; eauto. by asimpl. by asimpl. - hauto lq:on ctrs:Wff use:renaming_up. - - move => Γ a b A B i hP ihP ha iha hb ihb Δ ξ hΔ hξ. - move : {hP} ihP (hξ) (hΔ). repeat move/[apply]. - move /Bind_Inv => [i0][h0][h1]h2. - have ? : Δ ⊢ PBind PSig (ren_PTm ξ A) (ren_PTm (upRen_PTm_PTm ξ) B) ∈ PUniv i0 by qauto l:on ctrs:Wt. - apply : E_ProjPair1; eauto. - move : ihb hξ hΔ. repeat move/[apply]. by asimpl. - - move => Γ a b A B i hP ihP ha iha hb ihb Δ ξ hΔ hξ. - apply : E_ProjPair2'; eauto. by asimpl. - move : ihb hξ hΔ; repeat move/[apply]. by asimpl. - - move => Γ P i b c hP ihP hb ihb hc ihc Δ ξ hΔ hξ. - apply E_IndZero' with (i := i); eauto. by asimpl. - sauto lq:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ Δ ξ hΔ) : ihb. - asimpl. by apply. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ by sauto lq:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. - set p := renaming_ok _ _ _. - have : p. by do 2 apply renaming_up. - move => /[swap]/[apply]. - suff : ren_PTm (upRen_PTm_PTm (upRen_PTm_PTm ξ)) - (ren_PTm shift - (subst_PTm - (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift)) P))= ren_PTm shift - (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift)) - (ren_PTm (upRen_PTm_PTm ξ) P)) by scongruence. - by asimpl. - - move => Γ P a b c i hP ihP ha iha hb ihb hc ihc Δ ξ hΔ hξ. - apply E_IndSuc' with (i := i). by asimpl. by asimpl. - sauto lq:on use:Wff_Cons', T_Nat', renaming_up. - by eauto with wt. - move /(_ Δ ξ hΔ) : ihb. asimpl. by apply. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ by sauto lq:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. - move /(_ ltac:(by eauto using renaming_up)). - by asimpl. - - move => Γ a b A B i hPi ihPi ha iha hb ihb he0 ihe1 Δ ξ hΔ hξ. - apply : E_FunExt; eauto. move : ihe1. asimpl. apply. - hfcrush use:Bind_Inv. - by apply renaming_up. - - move => Γ a b A B i hPi ihPi ha iha hb ihb hL ihL hR ihR Δ ξ hΔ hξ. - apply : E_PairExt; eauto. move : ihR. asimpl. by apply. - - hauto lq:on ctrs:LEq. - - qauto l:on ctrs:LEq. - - hauto lq:on ctrs:Wff use:renaming_up, Su_Pi. - - hauto lq:on ctrs:Wff use:Su_Sig, renaming_up. - - hauto q:on ctrs:LEq. - - hauto lq:on ctrs:LEq. - - qauto l:on ctrs:LEq. - - move => *; apply : Su_Pi_Proj2'; eauto; by asimpl. - - move => *. apply : Su_Sig_Proj2'; eauto; by asimpl. -Qed. - -Definition morphing_ok Δ Γ (ρ : nat -> PTm) := - forall i A, lookup i Γ A -> Δ ⊢ ρ i ∈ subst_PTm ρ A. - -Lemma morphing_ren Ξ Δ Γ - (ρ : nat -> PTm) (ξ : nat -> nat) : - ⊢ Ξ -> - renaming_ok Ξ Δ ξ -> morphing_ok Δ Γ ρ -> - morphing_ok Ξ Γ (funcomp (ren_PTm ξ) ρ). -Proof. - move => hΞ hξ hρ i A. - rewrite {1}/funcomp. - have -> : - subst_PTm (funcomp (ren_PTm ξ) ρ) A = - ren_PTm ξ (subst_PTm ρ A) by asimpl. - move => ?. eapply renaming; eauto. -Qed. - -Lemma morphing_ext Δ Γ (ρ : nat -> PTm) (a : PTm) (A : PTm) : - morphing_ok Δ Γ ρ -> - Δ ⊢ a ∈ subst_PTm ρ A -> - morphing_ok - Δ (cons A Γ) (scons a ρ). -Proof. - move => h ha i B. - elim /lookup_inv => //=_. - - move => A0 Γ0 ? [*]. subst. - by asimpl. - - move => i0 Γ0 A0 B0 h0 ? [*]. subst. - asimpl. by apply h. -Qed. - -Lemma renaming_wt : forall Γ (a A : PTm), Γ ⊢ a ∈ A -> forall Δ (ξ : nat -> nat), ⊢ Δ -> renaming_ok Δ Γ ξ -> Δ ⊢ ren_PTm ξ a ∈ ren_PTm ξ A. -Proof. sfirstorder use:renaming. Qed. - -Lemma renaming_wt' : forall Δ Γ a A (ξ : nat -> nat) u U, - u = ren_PTm ξ a -> U = ren_PTm ξ A -> - Γ ⊢ a ∈ A -> ⊢ Δ -> - renaming_ok Δ Γ ξ -> Δ ⊢ u ∈ U. -Proof. hauto use:renaming_wt. Qed. - -Lemma morphing_up Γ Δ (ρ : nat -> PTm) (A : PTm) k : - morphing_ok Γ Δ ρ -> - Γ ⊢ subst_PTm ρ A ∈ PUniv k -> - morphing_ok (cons (subst_PTm ρ A) Γ) (cons A Δ) (up_PTm_PTm ρ). -Proof. - move => h h1 [:hp]. apply morphing_ext. - rewrite /morphing_ok. - move => i A0 hA0. - apply : renaming_wt'; last by apply renaming_shift. - rewrite /funcomp. reflexivity. - 2 : { eauto. } - by asimpl. - abstract : hp. qauto l:on ctrs:Wff use:wff_mutual. - apply : T_Var;eauto. apply here'. by asimpl. -Qed. - -Lemma weakening_wt : forall Γ (a A B : PTm) i, - Γ ⊢ B ∈ PUniv i -> - Γ ⊢ a ∈ A -> - cons B Γ ⊢ ren_PTm shift a ∈ ren_PTm shift A. -Proof. - move => Γ a A B i hB ha. - apply : renaming_wt'; eauto. - apply : Wff_Cons'; eauto. - apply : renaming_shift; eauto. -Qed. - -Lemma weakening_wt' : forall Γ (a A B : PTm) i U u, - u = ren_PTm shift a -> - U = ren_PTm shift A -> - Γ ⊢ B ∈ PUniv i -> - Γ ⊢ a ∈ A -> - cons B Γ ⊢ u ∈ U. -Proof. move => > -> ->. apply weakening_wt. Qed. - -Lemma morphing : - (forall Γ, ⊢ Γ -> True) /\ - (forall Γ a A, Γ ⊢ a ∈ A -> forall Δ ρ, ⊢ Δ -> morphing_ok Δ Γ ρ -> - Δ ⊢ subst_PTm ρ a ∈ subst_PTm ρ A) /\ - (forall Γ a b A, Γ ⊢ a ≡ b ∈ A -> forall Δ ρ, ⊢ Δ -> morphing_ok Δ Γ ρ -> - Δ ⊢ subst_PTm ρ a ≡ subst_PTm ρ b ∈ subst_PTm ρ A) /\ - (forall Γ A B, Γ ⊢ A ≲ B -> forall Δ ρ, ⊢ Δ -> morphing_ok Δ Γ ρ -> - Δ ⊢ subst_PTm ρ A ≲ subst_PTm ρ B). -Proof. - apply wt_mutual => //=. - - hauto l:on unfold:morphing_ok. - - hauto lq:on use:morphing_up, Wff_Cons', T_Bind. - - move => Γ a A B i hP ihP ha iha Δ ρ hΔ hρ. - move : ihP (hΔ) (hρ); repeat move/[apply]. - move /Bind_Inv => [j][h0][h1]h2. move {hP}. - have ? : Δ ⊢ PBind PPi (subst_PTm ρ A) (subst_PTm (up_PTm_PTm ρ) B) ∈ PUniv i by hauto lq:on ctrs:Wt. - apply : T_Abs; eauto. - apply : iha. - hauto lq:on use:Wff_Cons', Bind_Inv. - apply : morphing_up; eauto. - - move => *; apply : T_App'; eauto; by asimpl. - - move => Γ a A b B i hA ihA hB ihB hS ihS Δ ρ hρ hΔ. - eapply T_Pair' with (U := subst_PTm ρ (subst_PTm (scons a VarPTm) B));eauto. by asimpl. - - hauto lq:on use:T_Proj1. - - move => *. apply : T_Proj2'; eauto. by asimpl. - - hauto lq:on ctrs:Wt,LEq. - - qauto l:on ctrs:Wt. - - qauto l:on ctrs:Wt. - - qauto l:on ctrs:Wt. - - move => Γ P a b c i hP ihP ha iha hb ihb hc ihc Δ ξ hΔ hξ. - have hξ' : morphing_ok (cons PNat Δ) (cons PNat Γ) (up_PTm_PTm ξ). - move /morphing_up : hξ. move /(_ PNat 0). - apply. by apply T_Nat. - move => [:hP]. - apply : T_Ind'; eauto. by asimpl. - abstract :hP. apply ihP. by eauto using Wff_Cons', T_Nat'. - move /morphing_up : hξ. move /(_ PNat 0). - apply. by apply T_Nat. - move : ihb hξ hΔ; do!move/[apply]. by asimpl. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ. subst Ξ. - apply : Wff_Cons'; eauto. apply hP. - move /(_ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. - set Ξ' := (cons _ _) . - have : morphing_ok Ξ Ξ' (up_PTm_PTm (up_PTm_PTm ξ)). - eapply morphing_up; eauto. apply hP. - move /[swap]/[apply]. - set x := (x in _ ⊢ _ ∈ x). - set y := (y in _ -> _ ⊢ _ ∈ y). - suff : x = y by scongruence. - subst x y. asimpl. substify. by asimpl. - - qauto l:on ctrs:Wt. - - hauto lq:on ctrs:Eq. - - hauto lq:on ctrs:Eq. - - hauto lq:on ctrs:Eq. - - hauto lq:on rew:off use:E_Bind', Wff_Cons, morphing_up. - - move => *. apply : E_App'; eauto. by asimpl. - - hauto q:on ctrs:Eq. - - move => *. apply : E_Proj2'; eauto. by asimpl. - - move => Γ P0 P1 a0 a1 b0 b1 c0 c1 i hP0 ihP0 hP ihP ha iha hb ihb hc ihc. - move => Δ ξ hΔ hξ. - have hξ' : morphing_ok (cons PNat Δ) - (cons PNat Γ) (up_PTm_PTm ξ). - move /morphing_up : hξ. move /(_ PNat 0). - apply. by apply T_Nat. - move => [:hP']. - apply E_IndCong' with (i := i). - by asimpl. - abstract : hP'. - qauto l:on use:morphing_up, Wff_Cons', T_Nat'. - qauto l:on use:renaming_up, Wff_Cons', T_Nat'. - by eauto with wt. - move : ihb (hΔ) (hξ); do! move/[apply]. by asimpl. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ. - subst Ξ. apply :Wff_Cons'; eauto. apply hP'. - move /(_ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. - move /(_ ltac:(qauto l:on use:morphing_up)). - asimpl. substify. by asimpl. - - eauto with wt. - - qauto l:on ctrs:Eq, LEq. - - move => Γ a b A B i hP ihP hb ihb ha iha Δ ρ hΔ hρ. - move : ihP (hρ) (hΔ). repeat move/[apply]. - move /Bind_Inv. - move => [j][h0][h1]h2. - have ? : Δ ⊢ PBind PPi (subst_PTm ρ A) (subst_PTm (up_PTm_PTm ρ) B) ∈ PUniv j by qauto l:on ctrs:Wt. - apply : E_AppAbs'; eauto. by asimpl. by asimpl. - hauto lq:on ctrs:Wff use:morphing_up. - - move => Γ a b A B i hP ihP ha iha hb ihb Δ ρ hΔ hρ. - move : {hP} ihP (hρ) (hΔ). repeat move/[apply]. - move /Bind_Inv => [i0][h0][h1]h2. - have ? : Δ ⊢ PBind PSig (subst_PTm ρ A) (subst_PTm (up_PTm_PTm ρ) B) ∈ PUniv i0 by qauto l:on ctrs:Wt. - apply : E_ProjPair1; eauto. - move : ihb hρ hΔ. repeat move/[apply]. by asimpl. - - move => Γ a b A B i hP ihP ha iha hb ihb Δ ρ hΔ hρ. - apply : E_ProjPair2'; eauto. by asimpl. - move : ihb hρ hΔ; repeat move/[apply]. by asimpl. - - move => Γ P i b c hP ihP hb ihb hc ihc Δ ξ hΔ hξ. - have hξ' : morphing_ok (cons PNat Δ)(cons PNat Γ) (up_PTm_PTm ξ). - move /morphing_up : hξ. move /(_ PNat 0). - apply. by apply T_Nat. - apply E_IndZero' with (i := i); eauto. by asimpl. - qauto l:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ Δ ξ hΔ) : ihb. - asimpl. by apply. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ by qauto l:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. - move /(_ ltac:(sauto lq:on use:morphing_up)). - asimpl. substify. by asimpl. - - move => Γ P a b c i hP ihP ha iha hb ihb hc ihc Δ ξ hΔ hξ. - have hξ' : morphing_ok (cons PNat Δ) (cons PNat Γ) (up_PTm_PTm ξ). - move /morphing_up : hξ. move /(_ PNat 0). - apply. by apply T_Nat'. - apply E_IndSuc' with (i := i). by asimpl. by asimpl. - qauto l:on use:Wff_Cons', T_Nat', renaming_up. - by eauto with wt. - move /(_ Δ ξ hΔ) : ihb. asimpl. by apply. - set Ξ := cons _ _. - have hΞ : ⊢ Ξ by qauto l:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. - move /(_ ltac:(sauto l:on use:morphing_up)). - asimpl. substify. by asimpl. - - move => Γ a b A B i hPi ihPi ha iha hb ihb he0 ihe1 Δ ξ hΔ hξ. - move : ihPi (hΔ) (hξ); repeat move/[apply]. move /[dup] /Bind_Inv => ihPi ?. - decompose [and ex] ihPi. - apply : E_FunExt; eauto. move : ihe1. asimpl. apply. - by eauto with wt. - by eauto using morphing_up with wt. - - move => Γ a b A B i hPi ihPi ha iha hb ihb hL ihL hR ihR Δ ξ hΔ hξ. - apply : E_PairExt; eauto. move : ihR. asimpl. by apply. - - hauto lq:on ctrs:LEq. - - qauto l:on ctrs:LEq. - - hauto lq:on ctrs:Wff use:morphing_up, Su_Pi. - - hauto lq:on ctrs:Wff use:Su_Sig, morphing_up. - - hauto q:on ctrs:LEq. - - hauto lq:on ctrs:LEq. - - qauto l:on ctrs:LEq. - - move => *; apply : Su_Pi_Proj2'; eauto; by asimpl. - - move => *. apply : Su_Sig_Proj2'; eauto; by asimpl. -Qed. - -Lemma morphing_wt : forall Γ (a A : PTm ), Γ ⊢ a ∈ A -> forall Δ (ρ : nat -> PTm), ⊢ Δ -> morphing_ok Δ Γ ρ -> Δ ⊢ subst_PTm ρ a ∈ subst_PTm ρ A. -Proof. sfirstorder use:morphing. Qed. - -Lemma morphing_wt' : forall Δ Γ a A (ρ : nat -> PTm) u U, - u = subst_PTm ρ a -> U = subst_PTm ρ A -> - Γ ⊢ a ∈ A -> ⊢ Δ -> - morphing_ok Δ Γ ρ -> Δ ⊢ u ∈ U. -Proof. hauto use:morphing_wt. Qed. - -Lemma morphing_id : forall Γ, ⊢ Γ -> morphing_ok Γ Γ VarPTm. -Proof. - rewrite /morphing_ok => Γ hΓ i. asimpl. - eauto using T_Var. -Qed. - -Lemma substing_wt : forall Γ (a : PTm) (b A : PTm) B, - (cons A Γ) ⊢ a ∈ B -> - Γ ⊢ b ∈ A -> - Γ ⊢ subst_PTm (scons b VarPTm) a ∈ subst_PTm (scons b VarPTm) B. -Proof. - move => Γ a b A B ha hb [:hΓ]. apply : morphing_wt; eauto. - abstract : hΓ. sfirstorder use:wff_mutual. - apply morphing_ext; last by asimpl. - by apply morphing_id. -Qed. - -(* Could generalize to all equal contexts *) -Lemma ctx_eq_subst_one (A0 A1 : PTm) i j Γ a A : - (cons A0 Γ) ⊢ a ∈ A -> - Γ ⊢ A0 ∈ PUniv i -> - Γ ⊢ A1 ∈ PUniv j -> - Γ ⊢ A1 ≲ A0 -> - (cons A1 Γ) ⊢ a ∈ A. -Proof. - move => h0 h1 h2 h3. - replace a with (subst_PTm VarPTm a); last by asimpl. - replace A with (subst_PTm VarPTm A); last by asimpl. - have ? : ⊢ Γ by sfirstorder use:wff_mutual. - apply : morphing_wt; eauto. - apply : Wff_Cons'; eauto. - move => k A2. elim/lookup_inv => //=_; cycle 1. - - move => i0 Γ0 A3 B hi ? [*]. subst. - asimpl. - eapply weakening_wt' with (a := VarPTm i0);eauto using T_Var. - by substify. - - move => A3 Γ0 ? [*]. subst. - move => [:hΓ']. - apply : T_Conv. - apply T_Var. - abstract : hΓ'. - eauto using Wff_Cons'. apply here. - asimpl. renamify. - eapply renaming; eauto. - apply : renaming_shift; eauto. -Qed. - -Lemma bind_inst Γ p (A : PTm) B i a0 a1 : - Γ ⊢ PBind p A B ∈ PUniv i -> - Γ ⊢ a0 ≡ a1 ∈ A -> - Γ ⊢ subst_PTm (scons a0 VarPTm) B ≲ subst_PTm (scons a1 VarPTm) B. -Proof. - move => h h0. - have {}h : Γ ⊢ PBind p A B ≲ PBind p A B by eauto using E_Refl, Su_Eq. - case : p h => //=; hauto l:on use:Su_Pi_Proj2, Su_Sig_Proj2. -Qed. - -Lemma Cumulativity Γ (a : PTm ) i j : - i <= j -> - Γ ⊢ a ∈ PUniv i -> - Γ ⊢ a ∈ PUniv j. -Proof. - move => h0 h1. apply : T_Conv; eauto. - apply Su_Univ => //=. - sfirstorder use:wff_mutual. -Qed. - -Lemma T_Bind' Γ i j p (A : PTm ) (B : PTm) : - Γ ⊢ A ∈ PUniv i -> - (cons A Γ) ⊢ B ∈ PUniv j -> - Γ ⊢ PBind p A B ∈ PUniv (max i j). -Proof. - move => h0 h1. - have [*] : i <= max i j /\ j <= max i j by lia. - qauto l:on ctrs:Wt use:Cumulativity. -Qed. - -Hint Resolve T_Bind' : wt. - -Lemma regularity : - (forall Γ, ⊢ Γ -> forall i A, lookup i Γ A -> exists j, Γ ⊢ A ∈ PUniv j) /\ - (forall Γ a A, Γ ⊢ a ∈ A -> exists i, Γ ⊢ A ∈ PUniv i) /\ - (forall Γ a b A, Γ ⊢ a ≡ b ∈ A -> Γ ⊢ a ∈ A /\ Γ ⊢ b ∈ A /\ exists i, Γ ⊢ A ∈ PUniv i) /\ - (forall Γ A B, Γ ⊢ A ≲ B -> exists i, Γ ⊢ A ∈ PUniv i /\ Γ ⊢ B ∈ PUniv i). -Proof. - apply wt_mutual => //=; eauto with wt. - - move => i A. elim/lookup_inv => //=_. - - move => Γ A i hΓ ihΓ hA _ j A0. - elim /lookup_inv => //=_; cycle 1. - + move => i0 Γ0 A1 B + ? [*]. subst. - move : ihΓ => /[apply]. move => [j hA1]. - exists j. apply : renaming_wt' => //=; eauto using renaming_shift. done. - apply : Wff_Cons'; eauto. - + move => A1 Γ0 ? [*]. subst. - exists i. apply : renaming_wt'; eauto. reflexivity. - econstructor; eauto. - apply : renaming_shift; eauto. - - move => Γ b a A B hb [i ihb] ha [j iha]. - move /Bind_Inv : ihb => [k][h0][h1]h2. - move : substing_wt ha h1; repeat move/[apply]. - move => h. exists k. - move : h. by asimpl. - - hauto lq:on use:Bind_Inv. - - move => Γ a A B ha [i /Bind_Inv[j][h0][h1]h2]. - exists j. have : Γ ⊢ PProj PL a ∈ A by qauto use:T_Proj1. - move : substing_wt h1; repeat move/[apply]. - by asimpl. - - move => Γ P a b c i + ? + *. clear. move => h ha. exists i. - hauto lq:on use:substing_wt. - - sfirstorder. - - sfirstorder. - - sfirstorder. - - move => Γ i p A0 A1 B0 B1 hΓ ihΓ hA0 - [i0 ihA0] hA [ihA [ihA' [i1 ihA'']]]. - repeat split => //=. - qauto use:T_Bind. - apply T_Bind; eauto. - sfirstorder. - apply : ctx_eq_subst_one; eauto using Su_Eq, E_Symmetric. - hauto lq:on. - - move => n i b0 b1 a0 a1 A B hP _ hb [ihb0 [ihb1 [i0 ihb2]]] - ha [iha0 [iha1 [i1 iha2]]]. - repeat split. - qauto use:T_App. - apply : T_Conv; eauto. - qauto use:T_App. - move /E_Symmetric in ha. - by eauto using bind_inst. - hauto lq:on ctrs:Wt,Eq,LEq lq:on use:Bind_Inv, substing_wt. - - hauto lq:on use:Bind_Inv db:wt. - - move => Γ i a b A B hS _ hab [iha][ihb][j]ihs. - repeat split => //=; eauto with wt. - apply : T_Conv; eauto with wt. - move /E_Symmetric /E_Proj1 in hab. - eauto using bind_inst. - move /T_Proj1 in iha. - hauto lq:on ctrs:Wt,Eq,LEq use:Bind_Inv, substing_wt. - - move => Γ P0 P1 a0 a1 b0 b1 c0 c1 i _ _ hPE [hP0 [hP1 _]] hae [ha0 [ha1 _]] _ [hb0 [hb1 hb2]] _ [hc0 [hc1 [j hc2]]]. - have wfΓ : ⊢ Γ by hauto use:wff_mutual. - have wfΓ' : ⊢ (PNat :: Γ) by qauto use:Wff_Cons', T_Nat'. - repeat split. by eauto using T_Ind. - apply : T_Conv. apply : T_Ind; eauto. - apply : T_Conv; eauto. - eapply morphing; by eauto using Su_Eq, morphing_ext, morphing_id with wt. - apply : T_Conv. apply : ctx_eq_subst_one; eauto. - by eauto using Su_Eq, E_Symmetric. - eapply renaming; eauto. - eapply morphing. apply : Su_Eq. apply hPE. apply wfΓ'. - apply morphing_ext. - replace (funcomp VarPTm shift) with (funcomp (@ren_PTm shift) VarPTm); last by asimpl. - apply : morphing_ren; eauto using morphing_id, renaming_shift. - apply T_Suc. apply T_Var=>//. apply here. apply : Wff_Cons'; eauto using T_Nat'. - apply renaming_shift. - have /E_Symmetric /Su_Eq : Γ ⊢ PBind PSig PNat P0 ≡ PBind PSig PNat P1 ∈ PUniv i by eauto with wt. - move /E_Symmetric in hae. - by eauto using Su_Sig_Proj2. - sauto lq:on use:substing_wt. - - hauto lq:on ctrs:Wt. - - hauto lq:on ctrs:Wt. - - hauto q:on use:substing_wt db:wt. - - hauto l:on use:bind_inst db:wt. - - move => Γ P i b c hP _ hb _ hc _. - have ? : ⊢ Γ by hauto use:wff_mutual. - repeat split=>//. - by eauto with wt. - sauto lq:on use:substing_wt. - - move => Γ P a b c i hP _ ha _ hb _ hc _. - have ? : ⊢ Γ by hauto use:wff_mutual. - repeat split=>//. - apply : T_Ind; eauto with wt. - set Ξ := (X in X ⊢ _ ∈ _) in hc. - have : morphing_ok Γ Ξ (scons (PInd P a b c) (scons a VarPTm)). - apply morphing_ext. apply morphing_ext. by apply morphing_id. - by eauto. by eauto with wt. - subst Ξ. - move : morphing_wt hc; repeat move/[apply]. asimpl. by apply. - sauto lq:on use:substing_wt. - - move => Γ A B C hA [i [ihA0 ihA1]] hC [j [ihC0 ihC1]]. - have ? : ⊢ Γ by sfirstorder use:wff_mutual. - exists (max i j). - have [? ?] : i <= Nat.max i j /\ j <= Nat.max i j by lia. - qauto l:on use:T_Conv, Su_Univ. - - move => Γ i j hΓ *. exists (S (max i j)). - have [? ?] : S i <= S (Nat.max i j) /\ S j <= S (Nat.max i j) by lia. - hauto lq:on ctrs:Wt,LEq. - - move => Γ A0 A1 B0 B1 i hA0 _ hA1 [i0][ih0]ih1 hB[j0][ihB0]ihB1. - exists (max i0 j0). - split; eauto with wt. - apply T_Bind'; eauto. - sfirstorder use:ctx_eq_subst_one. - - move => n A0 A1 B0 B1 i hA1 _ hA0 [i0][ihA0]ihA1 hB[i1][ihB0]ihB1. - exists (max i0 i1). repeat split; eauto with wt. - apply T_Bind'; eauto. - sfirstorder use:ctx_eq_subst_one. - - sfirstorder. - - move => Γ A0 A1 B0 B1 _ [i][ih0 ih1]. - move /Bind_Inv : ih0 => [i0][h _]. - move /Bind_Inv : ih1 => [i1][h' _]. - exists (max i0 i1). - have [? ?] : i0 <= Nat.max i0 i1 /\ i1 <= Nat.max i0 i1 by lia. - eauto using Cumulativity. - - move => Γ A0 A1 B0 B1 _ [i][ih0 ih1]. - move /Bind_Inv : ih0 => [i0][h _]. - move /Bind_Inv : ih1 => [i1][h' _]. - exists (max i0 i1). - have [? ?] : i0 <= Nat.max i0 i1 /\ i1 <= Nat.max i0 i1 by lia. - eauto using Cumulativity. - - move => Γ a0 a1 A0 A1 B0 B1 /Su_Pi_Proj1 hA1. - move => [i][ihP0]ihP1. - move => ha [iha0][iha1][j]ihA1. - move /Bind_Inv :ihP0 => [i0][ih0][ih0' _]. - move /Bind_Inv :ihP1 => [i1][ih1][ih1' _]. - have [*] : i0 <= max i0 i1 /\ i1 <= max i0 i1 by lia. - exists (max i0 i1). - split. - + apply Cumulativity with (i := i0); eauto. - have : Γ ⊢ a0 ∈ A0 by eauto using T_Conv. - move : substing_wt ih0';repeat move/[apply]. by asimpl. - + apply Cumulativity with (i := i1); eauto. - move : substing_wt ih1' iha1;repeat move/[apply]. by asimpl. - - move => Γ a0 a1 A0 A1 B0 B1 /Su_Sig_Proj1 hA1. - move => [i][ihP0]ihP1. - move => ha [iha0][iha1][j]ihA1. - move /Bind_Inv :ihP0 => [i0][ih0][ih0' _]. - move /Bind_Inv :ihP1 => [i1][ih1][ih1' _]. - have [*] : i0 <= max i0 i1 /\ i1 <= max i0 i1 by lia. - exists (max i0 i1). - split. - + apply Cumulativity with (i := i0); eauto. - move : substing_wt iha0 ih0';repeat move/[apply]. by asimpl. - + apply Cumulativity with (i := i1); eauto. - have : Γ ⊢ a1 ∈ A1 by eauto using T_Conv. - move : substing_wt ih1';repeat move/[apply]. by asimpl. - Unshelve. all: exact 0. -Qed. - -Lemma Var_Inv Γ (i : nat) A : - Γ ⊢ VarPTm i ∈ A -> - ⊢ Γ /\ exists B, lookup i Γ B /\ Γ ⊢ B ≲ A. -Proof. - move E : (VarPTm i) => u hu. - move : i E. - elim : Γ u A / hu=>//=. - - move => i Γ A hΓ hi i0 [*]. subst. - split => //. - exists A. split => //. - have h : Γ ⊢ VarPTm i ∈ A by eauto using T_Var. - eapply regularity in h. - move : h => [i0]?. - apply : Su_Eq. apply E_Refl; eassumption. - - sfirstorder use:Su_Transitive. -Qed. - -Lemma renaming_su' : forall Δ Γ ξ (A B : PTm) u U , - u = ren_PTm ξ A -> - U = ren_PTm ξ B -> - Γ ⊢ A ≲ B -> - ⊢ Δ -> renaming_ok Δ Γ ξ -> - Δ ⊢ u ≲ U. -Proof. move => > -> ->. hauto l:on use:renaming. Qed. - -Lemma weakening_su : forall Γ (A0 A1 B : PTm) i, - Γ ⊢ B ∈ PUniv i -> - Γ ⊢ A0 ≲ A1 -> - (cons B Γ) ⊢ ren_PTm shift A0 ≲ ren_PTm shift A1. -Proof. - move => Γ A0 A1 B i hB hlt. - apply : renaming_su'; eauto. - apply : Wff_Cons'; eauto. - apply : renaming_shift; eauto. -Qed. - -Lemma regularity_sub0 : forall Γ (A B : PTm), Γ ⊢ A ≲ B -> exists i, Γ ⊢ A ∈ PUniv i. -Proof. hauto lq:on use:regularity. Qed. - -Lemma Su_Pi_Proj2_Var Γ (A0 A1 : PTm) B0 B1 : - Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> - cons A1 Γ ⊢ B0 ≲ B1. -Proof. - move => h. - have /Su_Pi_Proj1 h1 := h. - have /regularity_sub0 [i h2] := h1. - move /weakening_su : (h) h2. move => /[apply]. - move => h2. - apply : Su_Pi_Proj2'; try eassumption; rewrite -?/ren_PTm; cycle 2. - apply E_Refl. apply T_Var with (i := var_zero); eauto. - sfirstorder use:wff_mutual. - apply here. - by asimpl; rewrite subst_scons_id. - by asimpl; rewrite subst_scons_id. -Qed. - -Lemma Su_Sig_Proj2_Var Γ (A0 A1 : PTm) B0 B1 : - Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> - (cons A0 Γ) ⊢ B0 ≲ B1. -Proof. - move => h. - have /Su_Sig_Proj1 h1 := h. - have /regularity_sub0 [i h2] := h1. - move /weakening_su : (h) h2. move => /[apply]. - move => h2. - apply : Su_Sig_Proj2'; try eassumption; rewrite -?/ren_PTm; cycle 2. - apply E_Refl. apply T_Var with (i := var_zero); eauto. - sfirstorder use:wff_mutual. - apply here. - by asimpl; rewrite subst_scons_id. - by asimpl; rewrite subst_scons_id. -Qed. diff --git a/theories/termination.v b/theories/termination.v deleted file mode 100644 index c5bc37e..0000000 --- a/theories/termination.v +++ /dev/null @@ -1,5 +0,0 @@ -Require Import common Autosubst2.core Autosubst2.unscoped Autosubst2.syntax algorithmic fp_red executable. -From Hammer Require Import Tactics. -Require Import ssreflect ssrbool. -From stdpp Require Import relations (nsteps (..), rtc(..)). -Import Psatz. diff --git a/theories/typing.v b/theories/typing.v deleted file mode 100644 index e911d51..0000000 --- a/theories/typing.v +++ /dev/null @@ -1,237 +0,0 @@ -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. - -Reserved Notation "Γ ⊢ a ∈ A" (at level 70). -Reserved Notation "Γ ⊢ a ≡ b ∈ A" (at level 70). -Reserved Notation "Γ ⊢ A ≲ B" (at level 70). -Reserved Notation "⊢ Γ" (at level 70). -Inductive Wt : list PTm -> PTm -> PTm -> Prop := -| T_Var i Γ A : - ⊢ Γ -> - lookup i Γ A -> - Γ ⊢ VarPTm i ∈ A - -| T_Bind Γ i p (A : PTm) (B : PTm) : - Γ ⊢ A ∈ PUniv i -> - cons A Γ ⊢ B ∈ PUniv i -> - Γ ⊢ PBind p A B ∈ PUniv i - -| T_Abs Γ (a : PTm) A B i : - Γ ⊢ PBind PPi A B ∈ (PUniv i) -> - (cons A Γ) ⊢ a ∈ B -> - Γ ⊢ PAbs a ∈ PBind PPi A B - -| T_App Γ (b a : PTm) A B : - Γ ⊢ b ∈ PBind PPi A B -> - Γ ⊢ a ∈ A -> - Γ ⊢ PApp b a ∈ subst_PTm (scons a VarPTm) B - -| T_Pair Γ (a b : PTm) A B i : - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> - Γ ⊢ a ∈ A -> - Γ ⊢ b ∈ subst_PTm (scons a VarPTm) B -> - Γ ⊢ PPair a b ∈ PBind PSig A B - -| T_Proj1 Γ (a : PTm) A B : - Γ ⊢ a ∈ PBind PSig A B -> - Γ ⊢ PProj PL a ∈ A - -| T_Proj2 Γ (a : PTm) A B : - Γ ⊢ a ∈ PBind PSig A B -> - Γ ⊢ PProj PR a ∈ subst_PTm (scons (PProj PL a) VarPTm) B - -| T_Univ Γ i : - ⊢ Γ -> - Γ ⊢ PUniv i ∈ PUniv (S i) - -| T_Nat Γ i : - ⊢ Γ -> - Γ ⊢ PNat ∈ PUniv i - -| T_Zero Γ : - ⊢ Γ -> - Γ ⊢ PZero ∈ PNat - -| T_Suc Γ (a : PTm) : - Γ ⊢ a ∈ PNat -> - Γ ⊢ PSuc a ∈ PNat - -| T_Ind Γ P (a : PTm) b c i : - cons PNat Γ ⊢ P ∈ PUniv i -> - Γ ⊢ a ∈ PNat -> - Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - (cons P (cons PNat Γ)) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊢ PInd P a b c ∈ subst_PTm (scons a VarPTm) P - -| T_Conv Γ (a : PTm) A B : - Γ ⊢ a ∈ A -> - Γ ⊢ A ≲ B -> - Γ ⊢ a ∈ B - -with Eq : list PTm -> PTm -> PTm -> PTm -> Prop := -(* Structural *) -| E_Refl Γ (a : PTm ) A : - Γ ⊢ a ∈ A -> - Γ ⊢ a ≡ a ∈ A - -| E_Symmetric Γ (a b : PTm) A : - Γ ⊢ a ≡ b ∈ A -> - Γ ⊢ b ≡ a ∈ A - -| E_Transitive Γ (a b c : PTm) A : - Γ ⊢ a ≡ b ∈ A -> - Γ ⊢ b ≡ c ∈ A -> - Γ ⊢ a ≡ c ∈ A - -(* Congruence *) -| E_Bind Γ i p (A0 A1 : PTm) B0 B1 : - Γ ⊢ A0 ∈ PUniv i -> - Γ ⊢ A0 ≡ A1 ∈ PUniv i -> - (cons A0 Γ) ⊢ B0 ≡ B1 ∈ PUniv i -> - Γ ⊢ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv i - -| E_App Γ i (b0 b1 a0 a1 : PTm) A B : - Γ ⊢ PBind PPi A B ∈ (PUniv i) -> - Γ ⊢ b0 ≡ b1 ∈ PBind PPi A B -> - Γ ⊢ a0 ≡ a1 ∈ A -> - Γ ⊢ PApp b0 a0 ≡ PApp b1 a1 ∈ subst_PTm (scons a0 VarPTm) B - -| E_Proj1 Γ (a b : PTm) A B : - Γ ⊢ a ≡ b ∈ PBind PSig A B -> - Γ ⊢ PProj PL a ≡ PProj PL b ∈ A - -| E_Proj2 Γ i (a b : PTm) A B : - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> - Γ ⊢ a ≡ b ∈ PBind PSig A B -> - Γ ⊢ PProj PR a ≡ PProj PR b ∈ subst_PTm (scons (PProj PL a) VarPTm) B - -| E_IndCong Γ P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 i : - (cons PNat Γ) ⊢ P0 ∈ PUniv i -> - (cons PNat Γ) ⊢ P0 ≡ P1 ∈ PUniv i -> - Γ ⊢ a0 ≡ a1 ∈ PNat -> - Γ ⊢ b0 ≡ b1 ∈ subst_PTm (scons PZero VarPTm) P0 -> - (cons P0 ((cons PNat Γ))) ⊢ c0 ≡ c1 ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P0) -> - Γ ⊢ PInd P0 a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P0 - -| E_SucCong Γ (a b : PTm) : - Γ ⊢ a ≡ b ∈ PNat -> - Γ ⊢ PSuc a ≡ PSuc b ∈ PNat - -| E_Conv Γ (a b : PTm) A B : - Γ ⊢ a ≡ b ∈ A -> - Γ ⊢ A ≲ B -> - Γ ⊢ a ≡ b ∈ B - -(* Beta *) -| E_AppAbs Γ (a : PTm) b A B i: - Γ ⊢ PBind PPi A B ∈ PUniv i -> - Γ ⊢ b ∈ A -> - (cons A Γ) ⊢ a ∈ B -> - Γ ⊢ PApp (PAbs a) b ≡ subst_PTm (scons b VarPTm) a ∈ subst_PTm (scons b VarPTm ) B - -| E_ProjPair1 Γ (a b : PTm) A B i : - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> - Γ ⊢ a ∈ A -> - Γ ⊢ b ∈ subst_PTm (scons a VarPTm) B -> - Γ ⊢ PProj PL (PPair a b) ≡ a ∈ A - -| E_ProjPair2 Γ (a b : PTm) A B i : - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> - Γ ⊢ a ∈ A -> - Γ ⊢ b ∈ subst_PTm (scons a VarPTm) B -> - Γ ⊢ PProj PR (PPair a b) ≡ b ∈ subst_PTm (scons a VarPTm) B - -| E_IndZero Γ P i (b : PTm) c : - (cons PNat Γ) ⊢ P ∈ PUniv i -> - Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - (cons P (cons PNat Γ)) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊢ PInd P PZero b c ≡ b ∈ subst_PTm (scons PZero VarPTm) P - -| E_IndSuc Γ P (a : PTm) b c i : - (cons PNat Γ) ⊢ P ∈ PUniv i -> - Γ ⊢ a ∈ PNat -> - Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - (cons P (cons PNat Γ)) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) P) -> - Γ ⊢ PInd P (PSuc a) b c ≡ (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) ∈ subst_PTm (scons (PSuc a) VarPTm) P - -| E_FunExt Γ (a b : PTm) A B i : - Γ ⊢ PBind PPi A B ∈ PUniv i -> - Γ ⊢ a ∈ PBind PPi A B -> - Γ ⊢ b ∈ PBind PPi A B -> - A :: Γ ⊢ PApp (ren_PTm shift a) (VarPTm var_zero) ≡ PApp (ren_PTm shift b) (VarPTm var_zero) ∈ B -> - Γ ⊢ a ≡ b ∈ PBind PPi A B - -| E_PairExt Γ (a b : PTm) A B i : - Γ ⊢ PBind PSig A B ∈ PUniv i -> - Γ ⊢ a ∈ PBind PSig A B -> - Γ ⊢ b ∈ PBind PSig A B -> - Γ ⊢ PProj PL a ≡ PProj PL b ∈ A -> - Γ ⊢ PProj PR a ≡ PProj PR b ∈ subst_PTm (scons (PProj PL a) VarPTm) B -> - Γ ⊢ a ≡ b ∈ PBind PSig A B - -with LEq : list PTm -> PTm -> PTm -> Prop := -(* Structural *) -| Su_Transitive Γ (A B C : PTm) : - Γ ⊢ A ≲ B -> - Γ ⊢ B ≲ C -> - Γ ⊢ A ≲ C - -(* Congruence *) -| Su_Univ Γ i j : - ⊢ Γ -> - i <= j -> - Γ ⊢ PUniv i ≲ PUniv j - -| Su_Pi Γ (A0 A1 : PTm) B0 B1 i : - Γ ⊢ A0 ∈ PUniv i -> - Γ ⊢ A1 ≲ A0 -> - (cons A0 Γ) ⊢ B0 ≲ B1 -> - Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 - -| Su_Sig Γ (A0 A1 : PTm) B0 B1 i : - Γ ⊢ A1 ∈ PUniv i -> - Γ ⊢ A0 ≲ A1 -> - (cons A1 Γ) ⊢ B0 ≲ B1 -> - Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 - -(* Injecting from equalities *) -| Su_Eq Γ (A : PTm) B i : - Γ ⊢ A ≡ B ∈ PUniv i -> - Γ ⊢ A ≲ B - -(* Projection axioms *) -| Su_Pi_Proj1 Γ (A0 A1 : PTm) B0 B1 : - Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> - Γ ⊢ A1 ≲ A0 - -| Su_Sig_Proj1 Γ (A0 A1 : PTm) B0 B1 : - Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> - Γ ⊢ A0 ≲ A1 - -| Su_Pi_Proj2 Γ (a0 a1 A0 A1 : PTm ) B0 B1 : - Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> - Γ ⊢ a0 ≡ a1 ∈ A1 -> - Γ ⊢ subst_PTm (scons a0 VarPTm) B0 ≲ subst_PTm (scons a1 VarPTm) B1 - -| Su_Sig_Proj2 Γ (a0 a1 A0 A1 : PTm) B0 B1 : - Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> - Γ ⊢ a0 ≡ a1 ∈ A0 -> - Γ ⊢ subst_PTm (scons a0 VarPTm) B0 ≲ subst_PTm (scons a1 VarPTm) B1 - -with Wff : list PTm -> Prop := -| Wff_Nil : - ⊢ nil -| Wff_Cons Γ (A : PTm) i : - ⊢ Γ -> - Γ ⊢ A ∈ PUniv i -> - (* -------------------------------- *) - ⊢ (cons A Γ) - -where -"Γ ⊢ a ∈ A" := (Wt Γ a A) and "⊢ Γ" := (Wff Γ) and "Γ ⊢ a ≡ b ∈ A" := (Eq Γ a b A) and "Γ ⊢ A ≲ B" := (LEq Γ A B). - -Scheme wf_ind := Induction for Wff Sort Prop - with wt_ind := Induction for Wt Sort Prop - with eq_ind := Induction for Eq Sort Prop - with le_ind := Induction for LEq Sort Prop. - -Combined Scheme wt_mutual from wf_ind, wt_ind, eq_ind, le_ind.