diff --git a/Makefile b/Makefile index ef5b76f..79b3720 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 coq -o theories/Autosubst2/syntax.v syntax.sig + autosubst -f -v ge813 -s ucoq -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/fintype.v + rm -f theories/Autosubst2/syntax.v theories/Autosubst2/core.v theories/Autosubst2/unscoped.v FORCE: diff --git a/syntax.sig b/syntax.sig index 6b7e4df..24931eb 100644 --- a/syntax.sig +++ b/syntax.sig @@ -16,4 +16,7 @@ PPair : PTm -> PTm -> PTm PProj : PTag -> PTm -> PTm PBind : BTag -> PTm -> (bind PTm in PTm) -> PTm PUniv : nat -> PTm -PBot : PTm \ No newline at end of file +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 diff --git a/theories/Autosubst2/fintype.v b/theories/Autosubst2/fintype.v deleted file mode 100644 index 99508b6..0000000 --- a/theories/Autosubst2/fintype.v +++ /dev/null @@ -1,419 +0,0 @@ -(** * 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 ff9ec18..ee8b076 100644 --- a/theories/Autosubst2/syntax.v +++ b/theories/Autosubst2/syntax.v @@ -1,4 +1,4 @@ -Require Import core fintype. +Require Import core unscoped. Require Import Setoid Morphisms Relation_Definitions. @@ -33,369 +33,372 @@ Proof. exact (eq_refl). Qed. -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. +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. -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. +Lemma congr_PAbs {s0 : PTm} {t0 : PTm} (H0 : s0 = t0) : PAbs s0 = PAbs t0. Proof. -exact (eq_trans eq_refl (ap (fun x => PAbs m_PTm x) H0)). +exact (eq_trans eq_refl (ap (fun x => PAbs x) H0)). Qed. -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. +Lemma congr_PApp {s0 : PTm} {s1 : PTm} {t0 : PTm} {t1 : PTm} (H0 : s0 = t0) + (H1 : s1 = t1) : PApp s0 s1 = PApp t0 t1. Proof. -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)). +exact (eq_trans (eq_trans eq_refl (ap (fun x => PApp x s1) H0)) + (ap (fun x => PApp t0 x) H1)). Qed. -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. +Lemma congr_PPair {s0 : PTm} {s1 : PTm} {t0 : PTm} {t1 : PTm} (H0 : s0 = t0) + (H1 : s1 = t1) : PPair s0 s1 = PPair t0 t1. Proof. -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)). +exact (eq_trans (eq_trans eq_refl (ap (fun x => PPair x s1) H0)) + (ap (fun x => PPair t0 x) H1)). Qed. -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. +Lemma congr_PProj {s0 : PTag} {s1 : PTm} {t0 : PTag} {t1 : PTm} + (H0 : s0 = t0) (H1 : s1 = t1) : PProj s0 s1 = PProj t0 t1. Proof. -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)). +exact (eq_trans (eq_trans eq_refl (ap (fun x => PProj x s1) H0)) + (ap (fun x => PProj t0 x) H1)). Qed. -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. +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. Proof. exact (eq_trans - (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)). + (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)). Qed. -Lemma congr_PUniv {m_PTm : nat} {s0 : nat} {t0 : nat} (H0 : s0 = t0) : - PUniv m_PTm s0 = PUniv m_PTm t0. +Lemma congr_PUniv {s0 : nat} {t0 : nat} (H0 : s0 = t0) : PUniv s0 = PUniv t0. Proof. -exact (eq_trans eq_refl (ap (fun x => PUniv m_PTm x) H0)). +exact (eq_trans eq_refl (ap (fun x => PUniv x) H0)). Qed. -Lemma congr_PBot {m_PTm : nat} : PBot m_PTm = PBot m_PTm. +Lemma congr_PNat : PNat = PNat. Proof. exact (eq_refl). Qed. -Lemma upRen_PTm_PTm {m : nat} {n : nat} (xi : fin m -> fin n) : - fin (S m) -> fin (S n). +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. Proof. exact (up_ren xi). Defined. -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 (upRen_p p xi). -Defined. - -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 := +Fixpoint ren_PTm (xi_PTm : nat -> nat) (s : PTm) {struct s} : PTm := match s with - | 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 + | 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 {m : nat} {n_PTm : nat} (sigma : fin m -> PTm n_PTm) : - fin (S m) -> PTm (S n_PTm). +Lemma up_PTm_PTm (sigma : nat -> PTm) : nat -> PTm. Proof. -exact (scons (VarPTm (S n_PTm) var_zero) (funcomp (ren_PTm shift) sigma)). +exact (scons (VarPTm 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 -:= +Fixpoint subst_PTm (sigma_PTm : nat -> PTm) (s : PTm) {struct s} : 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 + | 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) 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. +Lemma upId_PTm_PTm (sigma : nat -> PTm) (Eq : forall x, sigma x = VarPTm x) : + forall x, up_PTm_PTm sigma x = VarPTm x. Proof. exact (fun n => match n with - | Some fin_n => ap (ren_PTm shift) (Eq fin_n) - | None => eq_refl + | S n' => ap (ren_PTm shift) (Eq n') + | O => eq_refl end). Qed. -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 => - scons_p_eta (VarPTm (plus p m_PTm)) - (fun n => ap (ren_PTm (shift_p p)) (Eq n)) (fun n => eq_refl)). -Qed. - -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 := +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 => + | 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 => + | PApp s0 s1 => congr_PApp (idSubst_PTm sigma_PTm Eq_PTm s0) (idSubst_PTm sigma_PTm Eq_PTm s1) - | PPair _ s0 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 => + | 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 + | 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 {m : nat} {n : nat} (xi : fin m -> fin n) - (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) : +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. Proof. -exact (fun n => - match n with - | Some fin_n => ap shift (Eq fin_n) - | None => eq_refl - end). +exact (fun n => match n with + | S n' => ap shift (Eq n') + | O => 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} : +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} : ren_PTm xi_PTm s = ren_PTm zeta_PTm s := match s with - | VarPTm _ s0 => ap (VarPTm n_PTm) (Eq_PTm s0) - | PAbs _ s0 => + | VarPTm s0 => ap (VarPTm) (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) - | PBot _ => congr_PBot + | 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) end. -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) : +Lemma upExt_PTm_PTm (sigma : nat -> PTm) (tau : nat -> 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 - | Some fin_n => ap (ren_PTm shift) (Eq fin_n) - | None => eq_refl + | S n' => ap (ren_PTm shift) (Eq n') + | O => eq_refl end). Qed. -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} : +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} : 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) - | PBot _ => congr_PBot + | 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) end. -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) : +Lemma up_ren_ren_PTm_PTm (xi : nat -> nat) (zeta : nat -> nat) + (rho : nat -> nat) (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. -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 := +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 := match s with - | VarPTm _ s0 => ap (VarPTm l_PTm) (Eq_PTm s0) - | PAbs _ s0 => + | VarPTm s0 => ap (VarPTm) (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) - | PBot _ => congr_PBot + | 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) end. -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) : +Lemma up_ren_subst_PTm_PTm (xi : nat -> nat) (tau : nat -> PTm) + (theta : nat -> 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 - | Some fin_n => ap (ren_PTm shift) (Eq fin_n) - | None => eq_refl + | S n' => ap (ren_PTm shift) (Eq n') + | O => eq_refl end). Qed. -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 := +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 := 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) - | PBot _ => congr_PBot + | 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) end. -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) +Lemma up_subst_ren_PTm_PTm (sigma : nat -> PTm) (zeta_PTm : nat -> nat) + (theta : nat -> 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 = @@ -403,76 +406,64 @@ Lemma up_subst_ren_PTm_PTm {k : nat} {l_PTm : nat} {m_PTm : nat} Proof. exact (fun n => match n with - | Some fin_n => + | S n' => eq_trans (compRenRen_PTm shift (upRen_PTm_PTm zeta_PTm) - (funcomp shift zeta_PTm) (fun x => eq_refl) (sigma fin_n)) + (funcomp shift zeta_PTm) (fun x => eq_refl) (sigma n')) (eq_trans (eq_sym (compRenRen_PTm zeta_PTm shift (funcomp shift zeta_PTm) - (fun x => eq_refl) (sigma fin_n))) - (ap (ren_PTm shift) (Eq fin_n))) - | None => eq_refl + (fun x => eq_refl) (sigma n'))) + (ap (ren_PTm shift) (Eq n'))) + | O => eq_refl end). Qed. -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) +Fixpoint compSubstRen_PTm (sigma_PTm : nat -> PTm) (zeta_PTm : nat -> nat) +(theta_PTm : nat -> PTm) (Eq_PTm : forall x, funcomp (ren_PTm zeta_PTm) sigma_PTm x = theta_PTm x) -(s : PTm m_PTm) {struct s} : +(s : 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) - | PBot _ => congr_PBot + | 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) end. -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) +Lemma up_subst_subst_PTm_PTm (sigma : nat -> PTm) (tau_PTm : nat -> PTm) + (theta : nat -> 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 = @@ -480,258 +471,223 @@ Lemma up_subst_subst_PTm_PTm {k : nat} {l_PTm : nat} {m_PTm : nat} Proof. exact (fun n => match n with - | Some fin_n => + | S n' => eq_trans (compRenSubst_PTm shift (up_PTm_PTm tau_PTm) (funcomp (up_PTm_PTm tau_PTm) shift) (fun x => eq_refl) - (sigma fin_n)) + (sigma n')) (eq_trans (eq_sym (compSubstRen_PTm tau_PTm shift (funcomp (ren_PTm shift) tau_PTm) (fun x => eq_refl) - (sigma fin_n))) (ap (ren_PTm shift) (Eq fin_n))) - | None => eq_refl + (sigma n'))) (ap (ren_PTm shift) (Eq n'))) + | O => eq_refl end). Qed. -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) +Fixpoint compSubstSubst_PTm (sigma_PTm : nat -> PTm) (tau_PTm : nat -> PTm) +(theta_PTm : nat -> PTm) (Eq_PTm : forall x, funcomp (subst_PTm tau_PTm) sigma_PTm x = theta_PTm x) -(s : PTm m_PTm) {struct s} : +(s : 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) - | PBot _ => congr_PBot + | 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) end. -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) : +Lemma renRen_PTm (xi_PTm : nat -> nat) (zeta_PTm : nat -> nat) (s : 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 {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) : +Lemma renRen'_PTm_pointwise (xi_PTm : nat -> nat) (zeta_PTm : nat -> nat) : 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 {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) : +Lemma renSubst_PTm (xi_PTm : nat -> nat) (tau_PTm : nat -> PTm) (s : 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 {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) : +Lemma renSubst_PTm_pointwise (xi_PTm : nat -> nat) (tau_PTm : nat -> 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 {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) : +Lemma substRen_PTm (sigma_PTm : nat -> PTm) (zeta_PTm : nat -> nat) (s : 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 {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) : +Lemma substRen_PTm_pointwise (sigma_PTm : nat -> PTm) (zeta_PTm : nat -> nat) + : 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 {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) : +Lemma substSubst_PTm (sigma_PTm : nat -> PTm) (tau_PTm : nat -> PTm) + (s : 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 {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) : +Lemma substSubst_PTm_pointwise (sigma_PTm : nat -> PTm) + (tau_PTm : nat -> 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 {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. +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. Proof. exact (fun n => match n with - | Some fin_n => ap (ren_PTm shift) (Eq fin_n) - | None => eq_refl + | S n' => ap (ren_PTm shift) (Eq n') + | O => eq_refl end). Qed. -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 := +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 := 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) - | PBot _ => congr_PBot + | 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) end. -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. +Lemma rinstInst'_PTm (xi_PTm : nat -> nat) (s : PTm) : + ren_PTm xi_PTm s = subst_PTm (funcomp (VarPTm) xi_PTm) s. Proof. exact (rinst_inst_PTm xi_PTm _ (fun n => eq_refl) s). Qed. -Lemma rinstInst'_PTm_pointwise {m_PTm : nat} {n_PTm : nat} - (xi_PTm : fin m_PTm -> fin n_PTm) : +Lemma rinstInst'_PTm_pointwise (xi_PTm : nat -> nat) : pointwise_relation _ eq (ren_PTm xi_PTm) - (subst_PTm (funcomp (VarPTm n_PTm) xi_PTm)). + (subst_PTm (funcomp (VarPTm) xi_PTm)). Proof. exact (fun s => rinst_inst_PTm xi_PTm _ (fun n => eq_refl) s). Qed. -Lemma instId'_PTm {m_PTm : nat} (s : PTm m_PTm) : - subst_PTm (VarPTm m_PTm) s = s. +Lemma instId'_PTm (s : PTm) : subst_PTm (VarPTm) s = s. Proof. -exact (idSubst_PTm (VarPTm m_PTm) (fun n => eq_refl) s). +exact (idSubst_PTm (VarPTm) (fun n => eq_refl) s). Qed. -Lemma instId'_PTm_pointwise {m_PTm : nat} : - pointwise_relation _ eq (subst_PTm (VarPTm m_PTm)) id. +Lemma instId'_PTm_pointwise : pointwise_relation _ eq (subst_PTm (VarPTm)) id. Proof. -exact (fun s => idSubst_PTm (VarPTm m_PTm) (fun n => eq_refl) s). +exact (fun s => idSubst_PTm (VarPTm) (fun n => eq_refl) s). Qed. -Lemma rinstId'_PTm {m_PTm : nat} (s : PTm m_PTm) : ren_PTm id s = s. +Lemma rinstId'_PTm (s : 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 {m_PTm : nat} : - pointwise_relation _ eq (@ren_PTm m_PTm m_PTm id) id. +Lemma rinstId'_PTm_pointwise : pointwise_relation _ eq (@ren_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 {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. +Lemma varL'_PTm (sigma_PTm : nat -> PTm) (x : nat) : + subst_PTm sigma_PTm (VarPTm x) = sigma_PTm x. Proof. exact (eq_refl). Qed. -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. +Lemma varL'_PTm_pointwise (sigma_PTm : nat -> PTm) : + pointwise_relation _ eq (funcomp (subst_PTm sigma_PTm) (VarPTm)) sigma_PTm. Proof. exact (fun x => eq_refl). Qed. -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). +Lemma varLRen'_PTm (xi_PTm : nat -> nat) (x : nat) : + ren_PTm xi_PTm (VarPTm x) = VarPTm (xi_PTm x). Proof. exact (eq_refl). Qed. -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). +Lemma varLRen'_PTm_pointwise (xi_PTm : nat -> nat) : + pointwise_relation _ eq (funcomp (ren_PTm xi_PTm) (VarPTm)) + (funcomp (VarPTm) xi_PTm). Proof. exact (fun x => eq_refl). Qed. @@ -739,18 +695,14 @@ Qed. Class Up_PTm X Y := up_PTm : X -> Y. -#[global] -Instance Subst_PTm {m_PTm n_PTm : nat}: (Subst1 _ _ _) := - (@subst_PTm m_PTm n_PTm). +#[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 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). +Instance VarInstance_PTm : (Var _ _) := @VarPTm. Notation "[ sigma_PTm ]" := (subst_PTm sigma_PTm) ( at level 1, left associativity, only printing) : fscope. @@ -777,9 +729,9 @@ Notation "x '__PTm'" := (VarPTm x) ( at level 5, format "x __PTm") : subst_scope. #[global] -Instance subst_PTm_morphism {m_PTm : nat} {n_PTm : nat}: +Instance subst_PTm_morphism : (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) - (@subst_PTm m_PTm n_PTm)). + (@subst_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') @@ -787,17 +739,16 @@ exact (fun f_PTm g_PTm Eq_PTm s t Eq_st => Qed. #[global] -Instance subst_PTm_morphism2 {m_PTm : nat} {n_PTm : nat}: +Instance subst_PTm_morphism2 : (Proper (respectful (pointwise_relation _ eq) (pointwise_relation _ eq)) - (@subst_PTm m_PTm n_PTm)). + (@subst_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 {m_PTm : nat} {n_PTm : nat}: - (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) - (@ren_PTm m_PTm n_PTm)). +Instance ren_PTm_morphism : + (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) (@ren_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') @@ -805,9 +756,9 @@ exact (fun f_PTm g_PTm Eq_PTm s t Eq_st => Qed. #[global] -Instance ren_PTm_morphism2 {m_PTm : nat} {n_PTm : nat}: +Instance ren_PTm_morphism2 : (Proper (respectful (pointwise_relation _ eq) (pointwise_relation _ eq)) - (@ren_PTm m_PTm n_PTm)). + (@ren_PTm)). Proof. exact (fun f_PTm g_PTm Eq_PTm s => extRen_PTm f_PTm g_PTm Eq_PTm s). Qed. @@ -839,9 +790,7 @@ Ltac asimpl' := repeat (first | progress setoid_rewrite rinstId'_PTm | progress setoid_rewrite instId'_PTm_pointwise | progress setoid_rewrite instId'_PTm - | progress - unfold up_list_PTm_PTm, up_PTm_PTm, upRen_list_PTm_PTm, - upRen_PTm_PTm, up_ren + | progress unfold up_PTm_PTm, upRen_PTm_PTm, up_ren | progress cbn[subst_PTm ren_PTm] | progress fsimpl ]). @@ -866,24 +815,7 @@ End Core. Module Extra. -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}. +Import Core. #[global] Hint Opaque subst_PTm: rewrite. diff --git a/theories/Autosubst2/unscoped.v b/theories/Autosubst2/unscoped.v new file mode 100644 index 0000000..55f8172 --- /dev/null +++ b/theories/Autosubst2/unscoped.v @@ -0,0 +1,213 @@ +(** * 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 new file mode 100644 index 0000000..3e48d49 --- /dev/null +++ b/theories/admissible.v @@ -0,0 +1,264 @@ +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 new file mode 100644 index 0000000..4e4e6fd --- /dev/null +++ b/theories/algorithmic.v @@ -0,0 +1,1893 @@ +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 new file mode 100644 index 0000000..35267fc --- /dev/null +++ b/theories/common.v @@ -0,0 +1,601 @@ +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 new file mode 100644 index 0000000..558aa75 --- /dev/null +++ b/theories/executable.v @@ -0,0 +1,350 @@ +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 new file mode 100644 index 0000000..40debce --- /dev/null +++ b/theories/executable_correct.v @@ -0,0 +1,259 @@ +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 ac5ec3d..382f25b 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.fintype Autosubst2.syntax. +Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. 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:(spec_refl ()). +Ltac spec_refl := ltac2:(Control.enter spec_refl). Module EPar. - Inductive R {n} : PTm n -> PTm n -> Prop := + Inductive R : PTm -> PTm -> Prop := (****************** Eta ***********************) | AppEta a0 a1 : R a0 a1 -> @@ -54,62 +54,80 @@ Module EPar. R A0 A1 -> R B0 B1 -> R (PBind p A0 B0) (PBind p A1 B1) - | BotCong : - R PBot PBot. + | 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). - Lemma refl n (a : PTm n) : R a a. + Lemma refl (a : PTm) : R a a. Proof. - elim : n / a; hauto lq:on ctrs:R. + elim : a; hauto lq:on ctrs:R. Qed. - Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. + Derive Dependent Inversion inv with (forall (a b : PTm), R a b) Sort Prop. - Lemma AppEta' n a0 a1 (u : PTm n) : + Lemma AppEta' a0 a1 (u : PTm) : u = (PAbs (PApp (ren_PTm shift a0) (VarPTm var_zero))) -> R a0 a1 -> R u a1. Proof. move => ->. apply AppEta. Qed. - Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : + Lemma renaming (a b : PTm) (ξ : nat -> nat) : R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : m ξ. - elim : n a b /h. + move => h. move : ξ. + elim : a b /h. - move => n a0 a1 ha iha m ξ /=. + all : try qauto ctrs:R. + + move => a0 a1 ha iha ξ /=. eapply AppEta'; eauto. by asimpl. - all : qauto ctrs:R. Qed. - Lemma morphing_ren n m p (ρ0 ρ1 : fin n -> PTm m) (ξ : fin m -> fin p) : + Lemma morphing_ren (ρ0 ρ1 : nat -> PTm) (ξ : nat -> nat) : (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 n m (ρ0 ρ1 : fin n -> PTm m) a b : + Lemma morphing_ext (ρ0 ρ1 : nat -> PTm) 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:option. Qed. + Proof. hauto q:on inv:nat. Qed. - Lemma morphing_up n m (ρ0 ρ1 : fin n -> PTm m) : + Lemma morphing_up (ρ0 ρ1 : nat -> PTm) : (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 n m (a b : PTm n) (ρ0 ρ1 : fin n -> PTm m) : + Lemma morphing (a b : PTm) (ρ0 ρ1 : nat -> PTm) : (forall i, R (ρ0 i) (ρ1 i)) -> R a b -> R (subst_PTm ρ0 a) (subst_PTm ρ1 b). Proof. - move => + h. move : m ρ0 ρ1. elim : n a b / h => n. - move => a0 a1 ha iha m ρ0 ρ1 hρ /=. + move => + h. move : ρ0 ρ1. elim : a b / h. + move => a0 a1 ha iha ρ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 {n} : PTm n -> Prop := +Inductive SNe : PTm -> Prop := | N_Var i : SNe (VarPTm i) | N_App a b : @@ -119,9 +137,13 @@ Inductive SNe {n} : PTm n -> Prop := | N_Proj p a : SNe a -> SNe (PProj p a) -| N_Bot : - SNe PBot -with SN {n} : PTm n -> Prop := +| 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_Pair a b : SN a -> SN b -> @@ -142,7 +164,14 @@ with SN {n} : PTm n -> Prop := SN (PBind p A B) | N_Univ i : SN (PUniv i) -with TRedSN {n} : PTm n -> PTm n -> Prop := +| N_Nat : + SN PNat +| N_Zero : + SN PZero +| N_Suc a : + SN a -> + SN (PSuc a) +with TRedSN : PTm -> PTm -> Prop := | N_β a b : SN b -> TRedSN (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -158,103 +187,93 @@ with TRedSN {n} : PTm n -> PTm n -> Prop := TRedSN (PProj PR (PPair a b)) b | N_ProjCong p a b : TRedSN a b -> - TRedSN (PProj p a) (PProj p 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). -Derive Dependent Inversion tred_inv with (forall n (a b : PTm n), TRedSN a b) Sort Prop. +Derive Inversion tred_inv with (forall (a b : PTm), TRedSN a b) Sort Prop. -Definition ishf {n} (a : PTm n) := - match a with - | PPair _ _ => true - | PAbs _ => true - | PUniv _ => true - | PBind _ _ _ => true - | _ => false - end. +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 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 -> +Lemma PProj_imp p a : + ishf a -> ~~ ispair a -> ~ SN (PProj p a). Proof. move => + + h. move E : (PProj p a) h => u h. move : p a E. - elim : n u / h => //=. + elim : u / h => //=. hauto lq:on inv:SNe,PTm. hauto lq:on inv:TRedSN. Qed. -Lemma PAbs_imp n a b : - @ishf n a -> +Lemma PApp_imp a b : + ishf a -> ~~ isabs a -> ~ SN (PApp a b). Proof. move => + + h. move E : (PApp a b) h => u h. - move : a b E. elim : n u /h=>//=. + move : a b E. elim : u /h=>//=. hauto lq:on inv:SNe,PTm. hauto lq:on inv:TRedSN. Qed. -Lemma PProjAbs_imp n p (a : PTm (S n)) : +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) : ~ SN (PProj p (PAbs a)). Proof. - 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. + sfirstorder use:PProj_imp. Qed. -Lemma PAppPair_imp n (a b0 b1 : PTm n ) : +Lemma PAppPair_imp (a b0 b1 : PTm ) : ~ SN (PApp (PPair b0 b1) a). Proof. - 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. + sfirstorder use:PApp_imp. Qed. -Lemma PAppBind_imp n p (A : PTm n) B b : +Lemma PAppBind_imp p (A : PTm) B b : ~ SN (PApp (PBind p A B) b). Proof. - 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. + sfirstorder use:PApp_imp. Qed. -Lemma PProjBind_imp n p p' (A : PTm n) B : +Lemma PProjBind_imp p p' (A : PTm) 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 : n u /hu=>//=. + elim : u /hu=>//=. hauto lq:on inv:SNe. hauto lq:on inv:TRedSN. Qed. @@ -265,7 +284,7 @@ Scheme sne_ind := Induction for SNe Sort Prop Combined Scheme sn_mutual from sne_ind, sn_ind, sred_ind. -Fixpoint ne {n} (a : PTm n) := +Fixpoint ne (a : PTm) := match a with | VarPTm i => true | PApp a b => ne a && nf b @@ -274,9 +293,12 @@ Fixpoint ne {n} (a : PTm n) := | PProj _ a => ne a | PUniv _ => false | PBind _ _ _ => false - | PBot => true + | PInd P a b c => nf P && ne a && nf b && nf c + | PNat => false + | PSuc a => false + | PZero => false end -with nf {n} (a : PTm n) := +with nf (a : PTm) := match a with | VarPTm i => true | PApp a b => ne a && nf b @@ -285,41 +307,66 @@ with nf {n} (a : PTm n) := | PProj _ a => ne a | PUniv _ => true | PBind _ A B => nf A && nf B - | PBot => true + | PInd P a b c => nf P && ne a && nf b && nf c + | PNat => true + | PSuc a => nf a + | PZero => true end. -Lemma ne_nf n a : @ne n a -> nf a. +Lemma ne_nf a : ne a -> nf a. Proof. elim : a => //=. Qed. -Inductive TRedSN' {n} (a : PTm n) : PTm n -> Prop := +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 := | T_Refl : TRedSN' a a | T_Once b : TRedSN a b -> TRedSN' a b. -Lemma SN_Proj n p (a : PTm n) : +Lemma SN_Proj p (a : PTm) : SN (PProj p a) -> SN a. Proof. move E : (PProj p a) => u h. move : a E. - elim : n u / h => n //=; sauto. + elim : u / h => n //=; sauto. Qed. -Lemma N_β' n a (b : PTm n) u : +Lemma N_β' a (b : PTm) u : u = (subst_PTm (scons b VarPTm) a) -> SN b -> TRedSN (PApp (PAbs a) b) u. Proof. move => ->. apply N_β. Qed. -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)). +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)). Proof. - 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. + 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. Qed. #[export]Hint Constructors SN SNe TRedSN : sn. @@ -328,41 +375,53 @@ 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 - | fin _ -> _ _ => (ltac1:(case;qauto depth:2 db:sn)) + | nat -> nat => (ltac1:(case;qauto depth:2 db:sn)) + | nat -> PTm => (ltac1:(case;qauto depth:2 db:sn)) | _ => solve_anti_ren () end. Ltac solve_anti_ren := ltac2:(Control.enter solve_anti_ren). -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, +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, a = ren_PTm ξ a0 -> exists b0, TRedSN a0 b0 /\ b = ren_PTm ξ b0). Proof. - move : n. apply sn_mutual => n; try solve_anti_ren. + apply sn_mutual; try solve_anti_ren. + move => *. subst. spec_refl. hauto lq:on ctrs:TRedSN, SN. - move => a b ha iha m ξ []//= u u0 [+ ?]. subst. + move => a b ha iha ξ []//= u u0 [+ ?]. subst. case : u => //= => u [*]. subst. spec_refl. eexists. split. apply N_β=>//. by asimpl. - move => a b hb ihb m ξ[]//= p p0 [? +]. subst. + move => a b hb ihb ξ[]//= p p0 [? +]. subst. case : p0 => //= p p0 [*]. subst. spec_refl. by eauto with sn. - move => a b ha iha m ξ[]//= u u0 [? ]. subst. + move => a b ha iha ξ[]//= 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 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, +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, a = subst_PTm ρ a0 -> (exists b0, b = subst_PTm ρ b0 /\ TRedSN a0 b0) \/ SNe a0). Proof. - move : n. apply sn_mutual => n; try solve_anti_ren. - - move => a b ha iha m ξ b0. + apply sn_mutual; try solve_anti_ren. + - hauto q:on db:sn. + - move => a b ha iha ξ b0. case : b0 => //=. + hauto lq:on rew:off db:sn. + move => p p0 [+ ?]. subst. @@ -373,7 +432,7 @@ Proof. spec_refl. eexists. split; last by eauto using N_β. by asimpl. - - move => a0 a1 b hb ihb ha iha m ρ []//=. + - move => a0 a1 b hb ihb ha iha ρ []//=. + hauto lq:on rew:off db:sn. + move => t0 t1 [*]. subst. spec_refl. @@ -384,16 +443,18 @@ Proof. * move => h. right. apply N_App => //. - - move => a b hb ihb m ρ []//=. + - move => a b hb ihb ρ []//=. + 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 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 => 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 => t0 t1 [*]. subst. spec_refl. case : iha. @@ -401,35 +462,66 @@ 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 n (a b : PTm n), SN (PApp a b) -> SN a /\ SN b. +Lemma SN_AppInv : forall (a b : PTm), SN (PApp a b) -> SN a /\ SN b. Proof. - move => n a b. move E : (PApp a b) => u hu. move : a b E. - elim : n u /hu=>//=. + move => a b. move E : (PApp a b) => u hu. move : a b E. + elim : u /hu=>//=. hauto lq:on rew:off inv:SNe db:sn. - move => n a b ha hb ihb a0 b0 ?. subst. + move => 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 n p (a : PTm n), SN (PProj p a) -> SN a. +Lemma SN_ProjInv : forall p (a : PTm), SN (PProj p a) -> SN a. Proof. - move => n p a. move E : (PProj p a) => u hu. + move => p a. move E : (PProj p a) => u hu. move : p a E. - elim : n u / hu => //=. + 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 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). +Lemma SN_IndInv : forall P (a : PTm) b c, SN (PInd P a b c) -> SN P /\ SN a /\ SN b /\ SN c. Proof. - move : n. apply sn_mutual => n. + 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. - sauto lq:on. - sauto lq:on. - sauto lq:on. @@ -452,6 +544,9 @@ 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. @@ -462,7 +557,7 @@ Proof. exists (subst_PTm (scons b1 VarPTm) a2). split. sauto lq:on. - hauto lq:on use:EPar.morphing, EPar.refl inv:option. + hauto lq:on use:EPar.morphing, EPar.refl inv:nat. - sauto. - move => a b hb ihb c. elim /EPar.inv => //= _. @@ -483,17 +578,31 @@ 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 {n} : PTm n -> PTm n -> Prop := - (****************** Eta ***********************) + 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 ********************) | AbsCong a0 a1 : R a0 a1 -> @@ -518,57 +627,102 @@ 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). + 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). - Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. + Derive Inversion inv with (forall (a b : PTm), R a b) Sort Prop. - Lemma AppAbs' n a (b : PTm n) u : + Lemma AppAbs' a (b : PTm) u : u = (subst_PTm (scons b VarPTm) a) -> R (PApp (PAbs a) b) u. Proof. move => ->. by apply AppAbs. Qed. - Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : + 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 : m ξ. - elim : n a b /h. + move => h. move : ξ. + elim : a b /h. - move => n a b m ξ /=. + all : try qauto ctrs:R. + move => a b ξ /=. apply AppAbs'. by asimpl. - all : qauto ctrs:R. + move => */=; apply IndSuc'; eauto. by asimpl. 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 - | fin _ -> _ _ => (ltac1:(case;hauto q:on depth:2 ctrs:RRed.R)) + | nat -> nat => (ltac1:(case;hauto q:on depth:2 ctrs:RRed.R)) + | nat -> PTm => (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 n m (a : PTm n) (b : PTm m) (ξ : fin n -> fin m) : + Lemma antirenaming (a : PTm) (b : PTm) (ξ : nat -> nat) : R (ren_PTm ξ a) b -> exists b0, R a b0 /\ ren_PTm ξ b0 = b. Proof. move E : (ren_PTm ξ a) => u h. - move : n ξ a E. elim : m u b/h; try solve_anti_ren. - - move => n a b m ξ []//=. move => []//= t t0 [*]. subst. + move : ξ a E. elim : u b/h; try solve_anti_ren. + - move => a b ξ []//=. move => []//= t t0 [*]. subst. eexists. split. apply AppAbs. by asimpl. - - move => n p a b m ξ []//=. + - move => p a b ξ []//=. 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 n (a b : PTm n) : + Lemma nf_imp (a b : PTm) : 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 {n} : PTm n -> PTm n -> Prop := + Inductive R : PTm -> PTm -> Prop := (****************** Beta ***********************) | AppAbs a0 a1 b0 b1 : R a0 a1 -> @@ -580,6 +734,18 @@ 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 -> @@ -603,92 +769,120 @@ Module RPar. R A0 A1 -> R B0 B1 -> R (PBind p A0 B0) (PBind p A1 B1) - | BotCong : - R PBot PBot. + | 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). - Lemma refl n (a : PTm n) : R a a. + Lemma refl (a : PTm) : R a a. Proof. - elim : n / a; hauto lq:on ctrs:R. + elim : a; hauto lq:on ctrs:R. Qed. - Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. + Derive Dependent Inversion inv with (forall (a b : PTm), R a b) Sort Prop. - Lemma AppAbs' n a0 a1 (b0 b1 : PTm n) u : + Lemma AppAbs' a0 a1 (b0 b1 : PTm) 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' n p u (a0 a1 b0 b1 : PTm n) : + Lemma ProjPair' p u (a0 a1 b0 b1 : PTm) : 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 renaming n m (a b : PTm n) (ξ : fin n -> fin m) : + 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) : R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : m ξ. - elim : n a b /h. + move => h. move : ξ. + elim : a b /h. - move => n a0 a1 b0 b1 ha iha hb ihb m ξ /=. + all : try qauto ctrs:R use:ProjPair'. + + move => a0 a1 b0 b1 ha iha hb ihb ξ /=. eapply AppAbs'; eauto. by asimpl. - all : qauto ctrs:R use:ProjPair'. + + move => * /=. apply : IndSuc'; eauto. by asimpl. Qed. - Lemma morphing_ren n m p (ρ0 ρ1 : fin n -> PTm m) (ξ : fin m -> fin p) : + Lemma morphing_ren (ρ0 ρ1 : nat -> PTm) (ξ : nat -> nat) : (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 n m (ρ0 ρ1 : fin n -> PTm m) a b : + Lemma morphing_ext (ρ0 ρ1 : nat -> PTm) 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:option. Qed. + Proof. hauto q:on inv:nat. Qed. - Lemma morphing_up n m (ρ0 ρ1 : fin n -> PTm m) : + Lemma morphing_up (ρ0 ρ1 : nat -> PTm) : (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 n m (a b : PTm n) (ρ0 ρ1 : fin n -> PTm m) : + Lemma morphing (a b : PTm) (ρ0 ρ1 : nat -> PTm) : (forall i, R (ρ0 i) (ρ1 i)) -> R a b -> R (subst_PTm ρ0 a) (subst_PTm ρ1 b). Proof. - 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. + 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. by asimpl. - all : hauto lq:on ctrs:R use:morphing_up, ProjPair'. Qed. - Lemma substing n m (a : PTm n) b (ρ : fin n -> PTm m) : + Lemma substing (a : PTm) b (ρ : nat -> PTm) : R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). Proof. hauto l:on use:morphing, refl. Qed. - - Lemma cong n (a0 a1 : PTm (S n)) b0 b1 : + Lemma cong (a0 a1 : PTm) 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:option ctrs:R. + hauto q:on inv:nat ctrs:R. Qed. - Lemma FromRRed n (a b : PTm n) : + Lemma FromRRed (a b : PTm) : RRed.R a b -> RPar.R a b. Proof. induction 1; qauto l:on use:RPar.refl ctrs:RPar.R. Qed. - Function tstar {n} (a : PTm n) := + Function tstar (a : PTm) := match a with | VarPTm i => a | PAbs a => PAbs (tstar a) @@ -699,14 +893,20 @@ Module RPar. | PProj p a => PProj p (tstar a) | PUniv i => PUniv i | PBind p A B => PBind p (tstar A) (tstar B) - | PBot => PBot + | 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) end. - Lemma triangle n (a b : PTm n) : + Lemma triangle (a b : PTm) : RPar.R a b -> RPar.R b (tstar a). Proof. move : b. - apply tstar_ind => {}n{}a. + apply tstar_ind => {}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. @@ -731,29 +931,43 @@ 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 n (a b c : PTm n) : + Lemma diamond (a b c : PTm) : 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 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). +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). Proof. - move : n. apply sn_mutual => n. + apply sn_mutual. - 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. @@ -773,6 +987,19 @@ 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. @@ -784,54 +1011,73 @@ Module RReds. #[local]Ltac solve_s := repeat (induction 1; last by solve_s_rec); apply rtc_refl. - Lemma AbsCong n (a b : PTm (S n)) : + Lemma AbsCong (a b : PTm) : rtc RRed.R a b -> rtc RRed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong (a0 a1 b0 b1 : PTm) : 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 n (a0 a1 b0 b1 : PTm n) : + Lemma PairCong (a0 a1 b0 b1 : PTm) : 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 n p (a0 a1 : PTm n) : + Lemma ProjCong p (a0 a1 : PTm) : rtc RRed.R a0 a1 -> rtc RRed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : + 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 : 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 n m (a b : PTm n) (ξ : fin n -> fin m) : + Lemma renaming (a b : PTm) (ξ : nat -> nat) : rtc RRed.R a b -> rtc RRed.R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : m ξ. elim : a b /h; hauto lq:on ctrs:rtc use:RRed.renaming. + move => h. move : ξ. elim : a b /h; hauto lq:on ctrs:rtc use:RRed.renaming. Qed. - Lemma FromRPar n (a b : PTm n) (h : RPar.R a b) : + Lemma FromRPar (a b : PTm) (h : RPar.R a b) : rtc RRed.R a b. Proof. - elim : n a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong. - move => n a0 a1 b0 b1 ha iha hb ihb. + elim : a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong, IndCong, SucCong. + move => a0 a1 b0 b1 ha iha hb ihb. apply : rtc_r; last by apply RRed.AppAbs. by eauto using AppCong, AbsCong. - move => n p a0 a1 b0 b1 ha iha hb ihb. + move => 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 n (a b : PTm n) : + Lemma RParIff (a b : PTm) : rtc RRed.R a b <-> rtc RPar.R a b. Proof. split. @@ -839,21 +1085,20 @@ Module RReds. induction 1; hauto l:on ctrs:rtc use:FromRPar, @relations.rtc_transitive. Qed. - Lemma nf_refl n (a b : PTm n) : + Lemma nf_refl (a b : PTm) : 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 {n} : PTm n -> PTm n -> Prop := + Inductive R_nonelim : PTm -> PTm -> Prop := (****************** Eta ***********************) | AppEta a0 a1 : ~~ ishf a0 -> @@ -886,9 +1131,22 @@ Module NeEPar. R_nonelim A0 A1 -> R_nonelim B0 B1 -> R_nonelim (PBind p A0 B0) (PBind p A1 B1) - | BotCong : - R_nonelim PBot PBot - with R_elim {n} : PTm n -> PTm n -> Prop := + | 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 := | NAbsCong a0 a1 : R_nonelim a0 a1 -> R_elim (PAbs a0) (PAbs a1) @@ -911,19 +1169,32 @@ Module NeEPar. R_nonelim A0 A1 -> R_nonelim B0 B1 -> R_elim (PBind p A0 B0) (PBind p A1 B1) - | NBotCong : - R_elim PBot PBot. + | 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). 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 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). + 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). Proof. - move : n. apply epar_mutual => n //=. + apply epar_mutual => //=. - 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. @@ -931,6 +1202,7 @@ 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. @@ -948,24 +1220,25 @@ 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 n (a b : PTm n) : + Lemma R_nonelim_nothf (a b : PTm) : R_nonelim a b -> ~~ ishf a -> R_elim a b. Proof. - move => h. elim : n a b /h=>//=; hauto lq:on ctrs:R_elim. + move => h. elim : a b /h=>//=; hauto lq:on ctrs:R_elim. Qed. - Lemma R_elim_nonelim n (a b : PTm n) : + Lemma R_elim_nonelim (a b : PTm) : R_elim a b -> R_nonelim a b. - move => h. elim : n a b /h=>//=; hauto lq:on ctrs:R_nonelim. + move => h. elim : a b /h=>//=; hauto lq:on ctrs:R_nonelim. Qed. - 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). + 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). Proof. apply epar_mutual; qauto l:on ctrs:EPar.R. Qed. @@ -973,45 +1246,45 @@ Module NeEPar. End NeEPar. Module Type NoForbid. - Parameter P : forall n, PTm n -> Prop. - Arguments P {n}. + Parameter P : PTm -> Prop. - 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_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_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_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_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 n (a b : PTm n), rtc EPar.R a b -> M.P a -> M.P b. + Axiom P_EPars : forall (a b : PTm), rtc EPar.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. + Axiom P_RReds : forall (a b : PTm), 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 n (a b : PTm n), rtc EPar.R a b -> P a -> P b. + Lemma P_EPars : forall (a b : PTm), 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 n (a b : PTm n), rtc RRed.R a b -> P a -> P b. + Lemma P_RReds : forall (a b : PTm), rtc RRed.R a b -> P a -> P b. Proof. induction 1; eauto using P_RRed, rtc_l, rtc_refl. Qed. @@ -1019,67 +1292,78 @@ End NoForbid_Fact. Module SN_NoForbid <: NoForbid. Definition P := @SN. - Arguments P {n}. - Lemma P_EPar : forall n (a b : PTm n), EPar.R a b -> P a -> P b. + Lemma P_EPar : forall (a b : PTm), EPar.R a b -> P a -> P b. Proof. sfirstorder use:epar_sn_preservation. Qed. - Lemma P_RRed : forall n (a b : PTm n), RRed.R a b -> P a -> P b. + Lemma P_RRed : forall (a b : PTm), RRed.R a b -> P a -> P b. Proof. hauto q:on use:red_sn_preservation, RPar.FromRRed. Qed. - 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). + 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). sfirstorder use:fp_red.PProj_imp. Qed. - Lemma P_AppInv : forall n (a b : PTm n), P (PApp a b) -> P a /\ P b. + 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. Proof. sfirstorder use:SN_AppInv. 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_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_ProjInv : forall n p (a : PTm n), P (PProj p a) -> P a. + Lemma P_ProjInv : forall p (a : PTm), P (PProj p a) -> P a. Proof. sfirstorder use:SN_ProjInv. Qed. - Lemma P_BindInv : forall n p (A : PTm n) B, P (PBind p A B) -> P A /\ P B. + Lemma P_BindInv : forall p (A : PTm) B, P (PBind p A B) -> P A /\ P B. Proof. - move => n p A B. + move => p A B. move E : (PBind p A B) => u hu. - move : p A B E. elim : n u /hu=>//=;sauto lq:on rew:off. + move : p A B E. elim : u /hu=>//=;sauto lq:on rew:off. Qed. - Lemma P_AbsInv : forall n (a : PTm (S n)), P (PAbs a) -> P a. + 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. Proof. - move => n a. move E : (PAbs a) => u h. + move => a. move E : (PAbs a) => u h. move : E. move : a. induction h; sauto lq:on rew:off. Qed. - Lemma P_renaming : forall n m (ξ : fin n -> fin m) a , P (ren_PTm ξ a) <-> P a. + Lemma P_renaming : forall (ξ : nat -> nat) a , P (ren_PTm ξ a) <-> P a. Proof. hauto lq:on use:sn_antirenaming, sn_renaming. Qed. - Lemma P_ProjBind : forall n p p' (A : PTm n) B, ~ P (PProj p (PBind p' A B)). + Lemma P_ProjBind : forall p p' (A : PTm) B, ~ P (PProj p (PBind p' A B)). Proof. sfirstorder use:PProjBind_imp. Qed. - Lemma P_AppBind : forall n p (A : PTm n) B b, ~ P (PApp (PBind p A B) b). + Lemma P_AppBind : forall p (A : PTm) 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 PAbs_imp PProj_imp : forbid. + #[local]Hint Resolve P_EPar P_RRed PApp_imp PProj_imp : forbid. - Lemma η_split n (a0 a1 : PTm n) : + Lemma η_split (a0 a1 : PTm) : EPar.R a0 a1 -> P a0 -> exists b, rtc RRed.R a0 b /\ NeEPar.R_nonelim b a1. Proof. - move => h. elim : n a0 a1 /h . - - move => n a0 a1 ha ih /[dup] hP. + move => h. elim : a0 a1 /h . + - move => a0 a1 ha ih /[dup] hP. move /P_AbsInv /P_AppInv => [/P_renaming ha0 _]. have {ih} := ih ha0. move => [b [ih0 ih1]]. @@ -1099,7 +1383,13 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). by eauto using RReds.renaming. apply rtc_refl. apply : RRed.AbsCong => /=. - apply RRed.AppAbs'. by asimpl. + apply RRed.AppAbs'. asimpl. + set y := subst_PTm _ _. + suff : ren_PTm id p = y. by asimpl. + subst y. + substify. + apply ext_PTm. + case => //=. (* violates SN *) + move /P_AbsInv in hP. have {}hP : P (PApp (ren_PTm shift b) (VarPTm var_zero)) @@ -1108,8 +1398,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:PAbs_imp. - - move => n a0 a1 h ih /[dup] hP. + sfirstorder use:PApp_imp. + - move => a0 a1 h ih /[dup] hP. move /P_PairInv => [/P_ProjInv + _]. move : ih => /[apply]. move => [b [ih0 ih1]]. @@ -1134,7 +1424,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 => n a0 a1 b0 b1 ha iha hb ihb. + - move => 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. @@ -1155,9 +1445,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:PAbs_imp. + sfirstorder use:PApp_imp. - hauto lq:on ctrs:NeEPar.R_nonelim use:RReds.PairCong, P_PairInv. - - move => n p a0 a1 ha ih /[dup] hP /P_ProjInv. + - move => 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). @@ -1182,35 +1472,58 @@ 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 n a b c : - @P n a -> + Lemma eta_postponement a b c : + P 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 : n a b /h => //=. - - move => n a0 a1 ha iha c /[dup] hP /P_AbsInv /P_AppInv [/P_renaming hP' _] hc. + elim : a b /h => //=. + - move => 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 => n a0 a1 ha iha c /P_PairInv [/P_ProjInv + _]. + - move => 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 => n a0 a1 ha iha c /P_AbsInv /[swap]. + - move => 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 => n a0 a1 b0 b1 ha iha hb ihb c hP. + - move => 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. @@ -1229,18 +1542,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. + apply RRed.AppAbs'. by asimpl. * 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:PAbs_imp. + sfirstorder use:PApp_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:option use:EPar.morphing,NeEPar.ToEPar. + hauto l:on inv:nat use:EPar.morphing,NeEPar.ToEPar. + move => a2 a3 b2 ha2 [*]. subst. move : iha (ha2) {ihb} => /[apply]. have : P a0 by sfirstorder use:P_AppInv. @@ -1253,10 +1566,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 => n a0 a1 b0 b1 ha iha hb ihb c /P_PairInv [hP hP']. + - move => 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 => n p a0 a1 ha iha c /[dup] hP /P_ProjInv hP'. + - move => 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]. @@ -1290,10 +1603,74 @@ 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 n a b c : - @P n a -> + Lemma η_postponement_star a b c : + P a -> EPar.R a b -> rtc RRed.R b c -> exists d, rtc RRed.R a d /\ EPar.R d c. @@ -1309,8 +1686,8 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). sfirstorder use:@relations.rtc_transitive. Qed. - Lemma η_postponement_star' n a b c : - @P n a -> + Lemma η_postponement_star' a b c : + P a -> EPar.R a b -> rtc RRed.R b c -> exists d, rtc RRed.R a d /\ NeEPar.R_nonelim d c. @@ -1327,7 +1704,7 @@ End UniqueNF. Module SN_UniqueNF := UniqueNF SN_NoForbid NoForbid_FactSN. Module ERed. - Inductive R {n} : PTm n -> PTm n -> Prop := + Inductive R : PTm -> PTm -> Prop := (****************** Eta ***********************) | AppEta a : @@ -1359,11 +1736,26 @@ 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). + 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). - Derive Dependent Inversion inv with (forall n (a b : PTm n), R a b) Sort Prop. + Derive Inversion inv with (forall (a b : PTm), R a b) Sort Prop. - Lemma ToEPar n (a b : PTm n) : + Lemma ToEPar (a b : PTm) : ERed.R a b -> EPar.R a b. Proof. induction 1; hauto lq:on use:EPar.refl ctrs:EPar.R. @@ -1373,102 +1765,157 @@ Module ERed. let x := Fresh.in_goal (Option.get (Ident.of_string "x")) in intro $x; lazy_match! Constr.type (Control.hyp x) with - | fin _ -> _ _ => (ltac1:(case;hauto q:on depth:2 ctrs:ERed.R)) + | nat -> _ => (ltac1:(case;hauto q:on depth:2 ctrs:ERed.R)) | _ => solve_anti_ren () end. Ltac solve_anti_ren := ltac2:(Control.enter solve_anti_ren). - (* 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)) -> + Lemma AppEta' a u : + u = (PApp (ren_PTm shift a) (VarPTm var_zero)) -> R (PAbs u) a. Proof. move => ->. apply AppEta. Qed. - Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : + Lemma renaming (a b : PTm) (ξ : nat -> nat) : R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). Proof. - move => h. move : m ξ. - elim : n a b /h. + move => h. move : ξ. + elim : a b /h. - move => n a m ξ /=. + move => a ξ /=. apply AppEta'; eauto. by asimpl. all : qauto ctrs:R. Qed. - (* Need to generalize to injective renaming *) - Lemma antirenaming n m (a : PTm n) (b : PTm m) (ξ : fin n -> fin m) : + (* 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) : (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 : n ξ a hξ E. - elim : m u b / hu; try solve_anti_ren. - - move => n a m ξ []//=. + move : ξ a hξ E. + elim : u b / hu; try solve_anti_ren. + - move => a ξ []//=. move => u hξ []. case : u => //=. move => u0 u1 []. case : u1 => //=. move => i /[swap] []. case : i => //= _ h. - have : exists p, ren_PTm shift p = u0 by admit. + suff : exists p, ren_PTm shift p = u0. move => [p ?]. subst. move : h. asimpl. - replace (ren_PTm (funcomp shift ξ) p) with + replace (ren_PTm (funcomp S ξ) p) with (ren_PTm shift (ren_PTm ξ p)); last by asimpl. move /ren_injective. - move /(_ ltac:(hauto l:on)). + move /(_ ltac:(hauto l:on unfold:ren_inj)). move => ?. subst. exists p. split=>//. apply AppEta. - - move => n a m ξ [] //=. + 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 => 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 => 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ξ. + - move => a0 a1 ha iha ξ []//= p hξ [?]. subst. + fcrush use:up_injective. + - move => p A B0 B1 hB ihB ξ + hξ. case => //= p' A2 B2 [*]. subst. - have : (forall i j, (upRen_PTm_PTm ξ) i = (upRen_PTm_PTm ξ) j -> i = j) by sauto. + have : (forall i j, (upRen_PTm_PTm ξ) i = (upRen_PTm_PTm ξ) j -> i = j) by sfirstorder use:up_injective. move => {}/ihB => ihB. spec_refl. sauto lq:on. - Admitted. + - 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. End ERed. @@ -1481,61 +1928,188 @@ Module EReds. #[local]Ltac solve_s := repeat (induction 1; last by solve_s_rec); apply rtc_refl. - Lemma AbsCong n (a b : PTm (S n)) : + Lemma AbsCong (a b : PTm) : rtc ERed.R a b -> rtc ERed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong (a0 a1 b0 b1 : PTm) : 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 n (a0 a1 b0 b1 : PTm n) : + Lemma PairCong (a0 a1 b0 b1 : PTm) : 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 n p (a0 a1 : PTm n) : + Lemma ProjCong p (a0 a1 : PTm) : rtc ERed.R a0 a1 -> rtc ERed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : + Lemma BindCong p (A0 A1 : PTm) 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 renaming n m (a b : PTm n) (ξ : fin n -> fin m) : + 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) : 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 n (a b : PTm n) : + Lemma FromEPar (a b : PTm) : EPar.R a b -> rtc ERed.R a b. Proof. - move => h. elim : n a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong. - - move => n a0 a1 _ h. + move => h. elim : a b /h; eauto using AbsCong, AppCong, PairCong, ProjCong, rtc_refl, BindCong, IndCong, SucCong. + - move => 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 => n a0 a1 _ h. + - move => 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 {n} : PTm n -> PTm n -> Prop := + Inductive R : PTm -> PTm -> Prop := (****************** Beta ***********************) | AppAbs a b : R (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -1543,6 +2117,12 @@ 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 @@ -1573,92 +2153,309 @@ 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). + 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). - Lemma ToBetaEta n (a b : PTm n) : + Lemma ToBetaEta (a b : PTm) : R a b -> ERed.R a b \/ RRed.R a b. Proof. induction 1; hauto lq:on db:red. Qed. - Lemma FromBeta n (a b : PTm n) : + Lemma FromBeta (a b : PTm) : RRed.R a b -> RERed.R a b. Proof. induction 1; qauto l:on ctrs:R. Qed. - Lemma FromEta n (a b : PTm n) : + Lemma FromEta (a b : PTm) : ERed.R a b -> RERed.R a b. Proof. induction 1; qauto l:on ctrs:R. Qed. - Lemma ToBetaEtaPar n (a b : PTm n) : + Lemma ToBetaEtaPar (a b : PTm) : R a b -> EPar.R a b \/ RRed.R a b. Proof. hauto q:on use:ERed.ToEPar, ToBetaEta. Qed. - Lemma sn_preservation n (a b : PTm n) : + Lemma sn_preservation (a b : PTm) : 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 sn_preservation n (a b : PTm n) : + 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) : rtc RERed.R a b -> SN a -> SN b. Proof. induction 1; eauto using RERed.sn_preservation. Qed. - Lemma FromRReds n (a b : PTm n) : + Lemma FromRReds (a b : PTm) : rtc RRed.R a b -> rtc RERed.R a b. Proof. induction 1; hauto lq:on ctrs:rtc use:RERed.FromBeta. Qed. - Lemma FromEReds n (a b : PTm n) : + Lemma FromEReds (a b : PTm) : 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 n (a b : PTm (S n)) : + Lemma AbsCong (a b : PTm) : rtc RERed.R a b -> rtc RERed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong (a0 a1 b0 b1 : PTm) : 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 n (a0 a1 b0 b1 : PTm n) : + Lemma PairCong (a0 a1 b0 b1 : PTm) : 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 n p (a0 a1 : PTm n) : + Lemma ProjCong p (a0 a1 : PTm) : rtc RERed.R a0 a1 -> rtc RERed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : + 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 : 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 {n} : PTm n -> PTm n -> Prop := + Inductive R : PTm -> PTm -> Prop := (****************** Beta ***********************) | AppAbs a b : R (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -1666,6 +2463,13 @@ 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 -> @@ -1695,25 +2499,69 @@ Module LoRed. | BindCong1 p A B0 B1 : nf A -> R B0 B1 -> - R (PBind p A B0) (PBind p A 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). - Lemma hf_preservation n (a b : PTm n) : + Lemma hf_preservation (a b : PTm) : LoRed.R a b -> ishf a -> ishf b. Proof. - move => h. elim : n a b /h=>//=. + move => h. elim : a b /h=>//=. Qed. - Lemma ToRRed n (a b : PTm n) : + Lemma ToRRed (a b : PTm) : 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 n (a b : PTm n) : + Lemma hf_preservation (a b : PTm) : rtc LoRed.R a b -> ishf a -> ishf b. @@ -1721,13 +2569,13 @@ Module LoReds. induction 1; eauto using LoRed.hf_preservation. Qed. - Lemma hf_ne_imp n (a b : PTm n) : + Lemma hf_ne_imp (a b : PTm) : rtc LoRed.R a b -> ne b -> ~~ ishf a. Proof. move : hf_preservation. repeat move/[apply]. - case : a; case : b => //=; itauto. + case : a; case : b => //=; sfirstorder b:on. Qed. #[local]Ltac solve_s_rec := @@ -1737,77 +2585,100 @@ Module LoReds. #[local]Ltac solve_s := repeat (induction 1; last by solve_s_rec); (move => *; apply rtc_refl). - Lemma AbsCong n (a b : PTm (S n)) : + Lemma AbsCong (a b : PTm) : rtc LoRed.R a b -> rtc LoRed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong (a0 a1 b0 b1 : PTm) : 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 n (a0 a1 b0 b1 : PTm n) : + Lemma PairCong (a0 a1 b0 b1 : PTm) : 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 n p (a0 a1 : PTm n) : + Lemma ProjCong p (a0 a1 : PTm) : rtc LoRed.R a0 a1 -> ne a1 -> rtc LoRed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : + Lemma BindCong p (A0 A1 : PTm) 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. - Local Ltac triv := simpl in *; itauto. + 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. - 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). + 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). 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 ctrs:rtc. + - hauto lq:on use:LoReds.IndCong solve+:triv. - 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 => n a0 a1 b hb ihb h. + - move => 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 => n p a b h. + - move => 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 n a, @SN n a -> exists v, rtc LoRed.R a v /\ nf v. + Lemma FromSN : forall a, SN a -> exists v, rtc LoRed.R a v /\ nf v. Proof. firstorder using FromSN_mutual. Qed. - Lemma ToRReds : forall n (a b : PTm n), rtc LoRed.R a b -> rtc RRed.R a b. + Lemma ToRReds : forall (a b : PTm), 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 {n} (a : PTm n) := +Fixpoint size_PTm (a : PTm) := match a with | VarPTm _ => 1 | PAbs a => 3 + size_PTm a @@ -1816,36 +2687,39 @@ Fixpoint size_PTm {n} (a : PTm n) := | 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) - | PBot => 1 + | 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 end. -Lemma size_PTm_ren n m (ξ : fin n -> fin m) a : size_PTm (ren_PTm ξ a) = size_PTm a. +Lemma size_PTm_ren (ξ : nat -> nat) a : size_PTm (ren_PTm ξ a) = size_PTm a. Proof. - move : m ξ. elim : n / a => //=; scongruence. + move : ξ. elim : a => //=; scongruence. Qed. #[export]Hint Rewrite size_PTm_ren : sizetm. -Lemma ered_size {n} (a b : PTm n) : +Lemma ered_size (a b : PTm) : ERed.R a b -> size_PTm b < size_PTm a. Proof. - move => h. elim : n a b /h; hauto l:on rew:db:sizetm. + move => h. elim : a b /h; try hauto l:on rew:db:sizetm solve+:lia. Qed. -Lemma ered_sn n (a : PTm n) : sn ERed.R a. +Lemma ered_sn (a : PTm) : 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 n (a b c : PTm n) : +Lemma ered_local_confluence (a b c : PTm) : 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 : n a b / h => n. + elim : a b / h. - move => a c. elim /ERed.inv => //= _. + move => a0 [+ ?]. subst => h. @@ -1906,10 +2780,46 @@ 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. + 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. Qed. -Lemma ered_confluence n (a b c : PTm n) : +Lemma ered_confluence (a b c : PTm) : rtc ERed.R a b -> rtc ERed.R a c -> exists d, rtc ERed.R b d /\ rtc ERed.R c d. @@ -1917,18 +2827,18 @@ Proof. sfirstorder use:relations.locally_confluent_confluent, ered_sn, ered_local_confluence. Qed. -Lemma red_confluence n (a b c : PTm n) : +Lemma red_confluence (a b c : PTm) : 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 n, rtc RPar.R b d /\ rtc RPar.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 by hauto lq:on use:RReds.RParIff. apply relations.diamond_confluent. rewrite /relations.diamond. eauto using RPar.diamond. Qed. -Lemma red_uniquenf n (a b c : PTm n) : +Lemma red_uniquenf (a b c : PTm) : rtc RRed.R a b -> rtc RRed.R a c -> nf b -> @@ -1943,20 +2853,20 @@ Proof. Qed. Module NeEPars. - Lemma R_nonelim_nf n (a b : PTm n) : + Lemma R_nonelim_nf (a b : PTm) : rtc NeEPar.R_nonelim a b -> nf b -> nf a. Proof. induction 1; sfirstorder use:NeEPar.R_elim_nf. Qed. - Lemma ToEReds : forall n, (forall (a b : PTm n), rtc NeEPar.R_nonelim a b -> rtc ERed.R a b). + Lemma ToEReds : (forall (a b : PTm), 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 n (a c : PTm n) : +Lemma rered_standardization (a c : PTm) : SN a -> rtc RERed.R a c -> exists b, rtc RRed.R a b /\ rtc NeEPar.R_nonelim b c. @@ -1973,7 +2883,7 @@ Proof. - hauto lq:on ctrs:rtc use:red_sn_preservation, RPar.FromRRed. Qed. -Lemma rered_confluence n (a b c : PTm n) : +Lemma rered_confluence (a b c : PTm) : SN a -> rtc RERed.R a b -> rtc RERed.R a c -> @@ -2005,17 +2915,52 @@ Proof. move /REReds.FromRReds : hc0. move /REReds.FromEReds : hv'. eauto using relations.rtc_transitive. Qed. -(* "Declarative" Joinability *) -Module DJoin. - Definition R {n} (a b : PTm n) := exists c, rtc RERed.R a c /\ rtc RERed.R b c. - - Lemma refl n (a : PTm n) : R a a. +(* 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 n (a b : PTm n) : R a b -> R b a. + Lemma symmetric (a b : PTm) : R a b -> R b a. Proof. sfirstorder unfold:R. Qed. - Lemma transitive n (a b c : PTm n) : SN b -> R a b -> R b c -> R a c. + 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. + +Module DJoin. + Definition R (a b : PTm) := exists c, rtc RERed.R a c /\ rtc RERed.R b c. + + Lemma refl (a : PTm) : 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. + Proof. sfirstorder unfold:R. Qed. + + Lemma transitive (a b c : PTm) : SN b -> R a b -> R b c -> R a c. Proof. rewrite /R. move => + [ab [ha +]] [bc [+ hc]]. @@ -2024,26 +2969,725 @@ Module DJoin. exists v. sfirstorder use:@relations.rtc_transitive. Qed. - Lemma AbsCong n (a b : PTm (S n)) : + Lemma AbsCong (a b : PTm) : R a b -> R (PAbs a) (PAbs b). Proof. hauto lq:on use:REReds.AbsCong unfold:R. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong (a0 a1 b0 b1 : PTm) : 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 n (a0 a1 b0 b1 : PTm n) : + Lemma PairCong (a0 a1 b0 b1 : PTm) : R a0 a1 -> R b0 b1 -> R (PPair a0 b0) (PPair a1 b1). Proof. hauto q:on use:REReds.PairCong. Qed. - Lemma ProjCong n p (a0 a1 : PTm n) : + Lemma ProjCong p (a0 a1 : PTm) : 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 new file mode 100644 index 0000000..e11659e --- /dev/null +++ b/theories/logrel.v @@ -0,0 +1,1704 @@ +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 new file mode 100644 index 0000000..301553e --- /dev/null +++ b/theories/preservation.v @@ -0,0 +1,172 @@ +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 new file mode 100644 index 0000000..877e3fb --- /dev/null +++ b/theories/soundness.v @@ -0,0 +1,15 @@ +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 new file mode 100644 index 0000000..207447d --- /dev/null +++ b/theories/structural.v @@ -0,0 +1,845 @@ +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 new file mode 100644 index 0000000..c5bc37e --- /dev/null +++ b/theories/termination.v @@ -0,0 +1,5 @@ +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 new file mode 100644 index 0000000..e911d51 --- /dev/null +++ b/theories/typing.v @@ -0,0 +1,237 @@ +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.