From 657c1325c99aa5891ba440af7ede8e3f656068c6 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 2 Mar 2025 16:40:39 -0500 Subject: [PATCH 01/51] Add unscoped syntax --- Makefile | 4 +- syntax.sig | 1 - theories/Autosubst2/syntax.v | 785 ++++++++++++--------------------- theories/Autosubst2/unscoped.v | 213 +++++++++ theories/common.v | 70 +-- 5 files changed, 532 insertions(+), 541 deletions(-) create mode 100644 theories/Autosubst2/unscoped.v 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 a50911e..24931eb 100644 --- a/syntax.sig +++ b/syntax.sig @@ -16,7 +16,6 @@ PPair : PTm -> PTm -> PTm PProj : PTag -> PTm -> PTm PBind : BTag -> PTm -> (bind PTm in PTm) -> PTm PUniv : nat -> PTm -PBot : PTm PNat : PTm PZero : PTm PSuc : PTm -> PTm diff --git a/theories/Autosubst2/syntax.v b/theories/Autosubst2/syntax.v index 5d04c05..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,221 +33,168 @@ 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 - | PNat : PTm n_PTm - | PZero : PTm n_PTm - | PSuc : PTm n_PTm -> PTm n_PTm - | PInd : - PTm (S n_PTm) -> - PTm n_PTm -> PTm n_PTm -> PTm (S (S n_PTm)) -> 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 congr_PNat {m_PTm : nat} : PNat m_PTm = PNat m_PTm. +Lemma congr_PZero : PZero = PZero. Proof. exact (eq_refl). Qed. -Lemma congr_PZero {m_PTm : nat} : PZero m_PTm = PZero m_PTm. +Lemma congr_PSuc {s0 : PTm} {t0 : PTm} (H0 : s0 = t0) : PSuc s0 = PSuc t0. Proof. -exact (eq_refl). +exact (eq_trans eq_refl (ap (fun x => PSuc x) H0)). Qed. -Lemma congr_PSuc {m_PTm : nat} {s0 : PTm m_PTm} {t0 : PTm m_PTm} - (H0 : s0 = t0) : PSuc m_PTm s0 = PSuc m_PTm t0. -Proof. -exact (eq_trans eq_refl (ap (fun x => PSuc m_PTm x) H0)). -Qed. - -Lemma congr_PInd {m_PTm : nat} {s0 : PTm (S m_PTm)} {s1 : PTm m_PTm} - {s2 : PTm m_PTm} {s3 : PTm (S (S m_PTm))} {t0 : PTm (S m_PTm)} - {t1 : PTm m_PTm} {t2 : PTm m_PTm} {t3 : PTm (S (S m_PTm))} (H0 : s0 = t0) - (H1 : s1 = t1) (H2 : s2 = t2) (H3 : s3 = t3) : - PInd m_PTm s0 s1 s2 s3 = PInd m_PTm t0 t1 t2 t3. +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 m_PTm x s1 s2 s3) H0)) - (ap (fun x => PInd m_PTm t0 x s2 s3) H1)) - (ap (fun x => PInd m_PTm t0 t1 x s3) H2)) - (ap (fun x => PInd m_PTm t0 t1 t2 x) H3)). + (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 {m : nat} {n : nat} (xi : fin m -> fin n) : - fin (S m) -> fin (S n). +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 - | PNat _ => PNat n_PTm - | PZero _ => PZero n_PTm - | PSuc _ s0 => PSuc n_PTm (ren_PTm xi_PTm s0) - | PInd _ s0 s1 s2 s3 => - PInd n_PTm (ren_PTm (upRen_PTm_PTm xi_PTm) s0) (ren_PTm xi_PTm s1) + | 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 - | PNat _ => PNat n_PTm - | PZero _ => PZero n_PTm - | PSuc _ s0 => PSuc n_PTm (subst_PTm sigma_PTm s0) - | PInd _ s0 s1 s2 s3 => - PInd n_PTm (subst_PTm (up_PTm_PTm sigma_PTm) s0) - (subst_PTm sigma_PTm s1) (subst_PTm sigma_PTm s2) + | 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 - | PNat _ => congr_PNat - | PZero _ => congr_PZero - | PSuc _ s0 => congr_PSuc (idSubst_PTm sigma_PTm Eq_PTm s0) - | PInd _ s0 s1 s2 s3 => + | 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) @@ -255,54 +202,42 @@ Fixpoint idSubst_PTm {m_PTm : nat} (sigma_PTm : fin m_PTm -> PTm m_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 - | PNat _ => congr_PNat - | PZero _ => congr_PZero - | PSuc _ s0 => congr_PSuc (extRen_PTm xi_PTm zeta_PTm Eq_PTm s0) - | PInd _ s0 s1 s2 s3 => + | 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) @@ -313,55 +248,43 @@ ren_PTm xi_PTm s = ren_PTm zeta_PTm s := (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 - | PNat _ => congr_PNat - | PZero _ => congr_PZero - | PSuc _ s0 => congr_PSuc (ext_PTm sigma_PTm tau_PTm Eq_PTm s0) - | PInd _ s0 s1 s2 s3 => + | 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) @@ -372,57 +295,43 @@ subst_PTm sigma_PTm s = subst_PTm tau_PTm s := (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 - | 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 => + | 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) @@ -434,66 +343,48 @@ Fixpoint compRenRen_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} (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 - | PNat _ => congr_PNat - | PZero _ => congr_PZero - | PSuc _ s0 => + | 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 => + | 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) @@ -506,9 +397,8 @@ Fixpoint compRenSubst_PTm {k_PTm : nat} {l_PTm : nat} {m_PTm : nat} 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 = @@ -516,76 +406,50 @@ 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 - | PNat _ => congr_PNat - | PZero _ => congr_PZero - | PSuc _ s0 => + | 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 => + | 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) @@ -598,9 +462,8 @@ ren_PTm zeta_PTm (subst_PTm sigma_PTm s) = subst_PTm theta_PTm s := 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 = @@ -608,78 +471,51 @@ 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 - | PNat _ => congr_PNat - | PZero _ => congr_PZero - | PSuc _ s0 => + | 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 => + | 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) @@ -692,126 +528,101 @@ subst_PTm tau_PTm (subst_PTm sigma_PTm s) = subst_PTm theta_PTm s := (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 - | 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 => + | 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) @@ -822,71 +633,61 @@ Fixpoint rinst_inst_PTm {m_PTm : nat} {n_PTm : nat} (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. @@ -894,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. @@ -932,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') @@ -942,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') @@ -960,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. @@ -994,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 ]). @@ -1021,36 +815,11 @@ End Core. Module Extra. -Import -Core. +Import Core. -Arguments VarPTm {n_PTm}. +#[global] Hint Opaque subst_PTm: rewrite. -Arguments PInd {n_PTm}. - -Arguments PSuc {n_PTm}. - -Arguments PZero {n_PTm}. - -Arguments PNat {n_PTm}. - -Arguments PBot {n_PTm}. - -Arguments PUniv {n_PTm}. - -Arguments PBind {n_PTm}. - -Arguments PProj {n_PTm}. - -Arguments PPair {n_PTm}. - -Arguments PApp {n_PTm}. - -Arguments PAbs {n_PTm}. - -#[global]Hint Opaque subst_PTm: rewrite. - -#[global]Hint Opaque ren_PTm: rewrite. +#[global] Hint Opaque ren_PTm: rewrite. End Extra. 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/common.v b/theories/common.v index 282038d..79b0b19 100644 --- a/theories/common.v +++ b/theories/common.v @@ -1,41 +1,52 @@ -Require Import Autosubst2.fintype Autosubst2.syntax Autosubst2.core ssreflect. +Require Import Autosubst2.unscoped Autosubst2.syntax Autosubst2.core ssreflect. From Ltac2 Require Ltac2. Import Ltac2.Notations. Import Ltac2.Control. From Hammer Require Import Tactics. -Definition renaming_ok {n m} (Γ : fin n -> PTm n) (Δ : fin m -> PTm m) (ξ : fin m -> fin n) := - forall (i : fin m), ren_PTm ξ (Δ i) = Γ (ξ i). +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 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. +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. - sblast inv:option. + 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 - | fin _ -> _ _ => (ltac1:(case;hauto lq:on rew:off use:up_injective)) + | 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 n m (a b : PTm n) (ξ : fin n -> fin m) : - (forall i j, ξ i = ξ j -> i = j) -> +Lemma ren_injective (a b : PTm) (ξ : nat -> nat) : + ren_inj ξ -> ren_PTm ξ a = ren_PTm ξ b -> a = b. Proof. - move : m ξ b. elim : n / a => //; try solve_anti_ren. + 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 {n} (a : PTm n) := +Definition ishf (a : PTm) := match a with | PPair _ _ => true | PAbs _ => true @@ -47,7 +58,7 @@ Definition ishf {n} (a : PTm n) := | _ => false end. -Definition toHF {n} (a : PTm n) := +Definition toHF (a : PTm) := match a with | PPair _ _ => H_Pair | PAbs _ => H_Abs @@ -59,54 +70,53 @@ Definition toHF {n} (a : PTm n) := | _ => H_Bot end. -Fixpoint ishne {n} (a : PTm n) := +Fixpoint ishne (a : PTm) := match a with | VarPTm _ => true | PApp a _ => ishne a | PProj _ a => ishne a - | PBot => true | PInd _ n _ _ => ishne n | _ => false end. -Definition isbind {n} (a : PTm n) := if a is PBind _ _ _ then true else false. +Definition isbind (a : PTm) := if a is PBind _ _ _ then true else false. -Definition isuniv {n} (a : PTm n) := if a is PUniv _ then true else false. +Definition isuniv (a : PTm) := if a is PUniv _ then true else false. -Definition ispair {n} (a : PTm n) := +Definition ispair (a : PTm) := match a with | PPair _ _ => true | _ => false end. -Definition isnat {n} (a : PTm n) := if a is PNat then true else false. +Definition isnat (a : PTm) := if a is PNat then true else false. -Definition iszero {n} (a : PTm n) := if a is PZero then true else false. +Definition iszero (a : PTm) := if a is PZero then true else false. -Definition issuc {n} (a : PTm n) := if a is PSuc _ then true else false. +Definition issuc (a : PTm) := if a is PSuc _ then true else false. -Definition isabs {n} (a : PTm n) := +Definition isabs (a : PTm) := match a with | PAbs _ => true | _ => false end. -Definition ishf_ren n m (a : PTm n) (ξ : fin n -> fin m) : +Definition ishf_ren (a : PTm) (ξ : nat -> nat) : ishf (ren_PTm ξ a) = ishf a. Proof. case : a => //=. Qed. -Definition isabs_ren n m (a : PTm n) (ξ : fin n -> fin m) : +Definition isabs_ren (a : PTm) (ξ : nat -> nat) : isabs (ren_PTm ξ a) = isabs a. Proof. case : a => //=. Qed. -Definition ispair_ren n m (a : PTm n) (ξ : fin n -> fin m) : +Definition ispair_ren (a : PTm) (ξ : nat -> nat) : ispair (ren_PTm ξ a) = ispair a. Proof. case : a => //=. Qed. -Definition ishne_ren n m (a : PTm n) (ξ : fin n -> fin m) : +Definition ishne_ren (a : PTm) (ξ : nat -> nat) : ishne (ren_PTm ξ a) = ishne a. -Proof. move : m ξ. elim : n / a => //=. Qed. +Proof. move : ξ. elim : a => //=. Qed. -Lemma renaming_shift n m Γ (ρ : fin n -> PTm m) A : - renaming_ok (funcomp (ren_PTm shift) (scons (subst_PTm ρ A) Γ)) Γ shift. -Proof. sfirstorder. Qed. +Lemma renaming_shift Γ (ρ : nat -> PTm) A : + renaming_ok (cons A Γ) Γ shift. +Proof. rewrite /renaming_ok. hauto lq:on ctrs:lookup. Qed. From 226b196d159bb45dd1e04a7ebaeadc46472669f7 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 2 Mar 2025 17:35:51 -0500 Subject: [PATCH 02/51] Refactor half of fp_red --- theories/Autosubst2/fintype.v | 419 -------------- theories/fp_red.v | 988 +++++++++++++++++----------------- 2 files changed, 486 insertions(+), 921 deletions(-) delete mode 100644 theories/Autosubst2/fintype.v 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/fp_red.v b/theories/fp_red.v index bffe1a7..5f7ea0d 100644 --- a/theories/fp_red.v +++ b/theories/fp_red.v @@ -8,7 +8,7 @@ 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 common. +Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. Require Import Btauto. Require Import Cdcl.Itauto. @@ -23,7 +23,7 @@ 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,8 +54,6 @@ 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 : @@ -72,64 +70,64 @@ Module EPar. (* ------------ *) 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. all : try qauto ctrs:R. - move => n a0 a1 ha iha m ξ /=. + move => a0 a1 ha iha ξ /=. eapply AppEta'; 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)). + (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 n m (a b : PTm n) (ρ : fin n -> PTm m) : + 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 : @@ -139,15 +137,13 @@ Inductive SNe {n} : PTm n -> Prop := | N_Proj p a : SNe a -> SNe (PProj p a) -| N_Bot : - SNe PBot | N_Ind P a b c : SN P -> SNe a -> SN b -> SN c -> SNe (PInd P a b c) -with SN {n} : PTm n -> Prop := +with SN : PTm -> Prop := | N_Pair a b : SN a -> SN b -> @@ -175,7 +171,7 @@ with SN {n} : PTm n -> Prop := | N_Suc a : SN a -> SN (PSuc a) -with TRedSN {n} : PTm n -> PTm n -> Prop := +with TRedSN : PTm -> PTm -> Prop := | N_β a b : SN b -> TRedSN (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -210,38 +206,38 @@ with TRedSN {n} : PTm n -> PTm n -> Prop := 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. -Inductive SNat {n} : PTm n -> Prop := +Inductive SNat : PTm -> Prop := | S_Zero : SNat PZero | S_Neu a : SNe a -> SNat a | S_Suc a : SNat a -> SNat (PSuc a) | S_Red a b : TRedSN a b -> SNat b -> SNat a. -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 PApp_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 PInd_imp n P (a : PTm n) b c : +Lemma PInd_imp P (a : PTm) b c : ishf a -> ~~ iszero a -> ~~ issuc a -> @@ -249,35 +245,35 @@ Lemma PInd_imp n P (a : PTm n) b c : Proof. move => + + + h. move E : (PInd P a b c) h => u h. move : P a b c E. - elim : n u /h => //=. + 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 PProjAbs_imp p (a : PTm) : ~ SN (PProj p (PAbs a)). Proof. 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. 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. 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. @@ -288,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 @@ -297,13 +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 @@ -312,69 +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. -Lemma ne_nf_ren n m (a : PTm n) (ξ : fin n -> fin m) : +Lemma ne_nf_ren (a : PTm) (ξ : nat -> nat) : (ne a <-> ne (ren_PTm ξ a)) /\ (nf a <-> nf (ren_PTm ξ a)). Proof. - move : m ξ. elim : n / a => //=; solve [hauto b:on]. + move : ξ. elim : a => //=; solve [hauto b:on]. Qed. -Inductive TRedSN' {n} (a : PTm n) : PTm n -> Prop := +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 N_IndSuc' n P a b c u : +Lemma N_IndSuc' P a b c u : u = (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) -> SN P -> - @SN n a -> + SN a -> SN b -> SN c -> TRedSN (PInd P (PSuc a) b c) u. Proof. move => ->. apply N_IndSuc. 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 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. + move => */=. apply N_IndSuc'; eauto. by asimpl. Qed. -Lemma ne_nf_embed n (a : PTm n) : +Lemma ne_nf_embed (a : PTm) : (ne a -> SNe a) /\ (nf a -> SN a). Proof. - elim : n / a => //=; hauto qb:on ctrs:SNe, SN. + elim : a => //=; hauto qb:on ctrs:SNe, SN. Qed. #[export]Hint Constructors SN SNe TRedSN : sn. @@ -383,49 +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 m ξ []//= P0 a0 b0 c0 [?]. subst. + 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 m ξ []//= P0 a0 b0 c0 [?]. subst. + 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. + 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. @@ -436,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. @@ -447,18 +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. + - 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 m ρ []//=; first by hauto l:on db:sn. + - move => p a b ha iha ρ []//=; first by hauto l:on db:sn. move => t0 t1 [*]. subst. spec_refl. case : iha. @@ -466,12 +462,12 @@ 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 m ρ []//=. + - 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 m ρ []//=. + - 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 => //=. @@ -480,7 +476,7 @@ Proof. 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 m ρ[]//=. + - 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. @@ -491,42 +487,41 @@ Proof. * 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 SN_IndInv : forall n P (a : PTm n) b c, SN (PInd P a b c) -> SN P /\ SN a /\ SN b /\ SN c. +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 P a b c. move E : (PInd P a b c) => u hu. move : P a b c E. - elim : n u / hu => //=. + 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 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 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. - move : n. apply sn_mutual => n. - - sauto lq:on. + apply sn_mutual. - sauto lq:on. - sauto lq:on. - sauto lq:on. @@ -562,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 => //= _. @@ -590,12 +585,12 @@ Proof. 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:option. + 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 := + Inductive R : PTm -> PTm -> Prop := (****************** Beta ***********************) | AppAbs a b : R (PApp (PAbs a) b) (subst_PTm (scons b VarPTm) a) @@ -649,27 +644,27 @@ Module RRed. 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 IndSuc' n P a b c u : + Lemma IndSuc' P a b c u : u = (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) -> - R (@PInd n P (PSuc a) b c) u. + R (PInd P (PSuc a) b c) u. Proof. move => ->. apply IndSuc. 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. all : try qauto ctrs:R. - move => n a b m ξ /=. + move => a b ξ /=. apply AppAbs'. by asimpl. move => */=; apply IndSuc'; eauto. by asimpl. Qed. @@ -678,56 +673,56 @@ Module RRed. 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 => n p b c m ξ []//= P a0 b0 c0 [*]. subst. + - move => p b c ξ []//= P a0 b0 c0 [*]. subst. destruct a0 => //=. hauto lq:on ctrs:R. - - move => n P a b c m ξ []//=. + - 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 n (a b : PTm n) : + Lemma FromRedSN (a b : PTm) : TRedSN a b -> RRed.R a b. Proof. induction 1; hauto lq:on ctrs:RRed.R. Qed. - Lemma substing n m (a b : PTm n) (ρ : fin n -> PTm m) : + Lemma substing (a b : PTm) (ρ : nat -> PTm) : R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). Proof. - move => h. move : m ρ. elim : n a b / h => n. + move => h. move : ρ. elim : a b / h => n. all : try hauto lq:on ctrs:R. - move => a b m ρ /=. - eapply AppAbs'; eauto; cycle 1. by asimpl. + 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 -> @@ -774,8 +769,6 @@ 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 : @@ -792,28 +785,28 @@ Module RPar. (* ------------ *) 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 IndSuc' n P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 u : + 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 -> @@ -823,43 +816,43 @@ Module RPar. R (PInd P0 (PSuc a0) b0 c0) u. Proof. move => ->. apply IndSuc. 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. all : try qauto ctrs:R use:ProjPair'. - move => n a0 a1 b0 b1 ha iha hb ihb m ξ /=. + move => a0 a1 b0 b1 ha iha hb ihb ξ /=. eapply AppAbs'; eauto. by asimpl. 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 => + 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 m ρ0 ρ1 hρ /=. + 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. @@ -867,29 +860,29 @@ Module RPar. by asimpl. 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) @@ -900,7 +893,6 @@ 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) @@ -910,11 +902,11 @@ Module RPar. | 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. @@ -942,33 +934,31 @@ Module RPar. - hauto lq:on ctrs:R inv:R. - hauto lq:on ctrs:R inv:R. - hauto lq:on ctrs:R inv:R. - - move => P b c ?. subst. - move => h0. inversion 1; subst. hauto lq:on ctrs:R. qauto l:on inv:R ctrs: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:option. + 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 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. @@ -1002,13 +992,13 @@ Proof. 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:option. + 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:option. + hauto q:on use:RPar.morphing ctrs:RPar.R inv:nat. - sauto q:on. Qed. @@ -1021,34 +1011,34 @@ 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 SucCong n (a0 a1 : PTm n) : + Lemma SucCong (a0 a1 : PTm) : rtc RRed.R a0 a1 -> rtc RRed.R (PSuc a0) (PSuc a1). Proof. solve_s. Qed. - Lemma IndCong n P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 : + 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 -> @@ -1056,27 +1046,27 @@ Module RReds. rtc RRed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. solve_s. Qed. - Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : + 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, IndCong, SucCong. - 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. @@ -1087,7 +1077,7 @@ Module RReds. 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. @@ -1095,11 +1085,11 @@ 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 n (a b : PTm n) : + 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. @@ -1108,7 +1098,7 @@ End RReds. Module NeEPar. - Inductive R_nonelim {n} : PTm n -> PTm n -> Prop := + Inductive R_nonelim : PTm -> PTm -> Prop := (****************** Eta ***********************) | AppEta a0 a1 : ~~ ishf a0 -> @@ -1141,8 +1131,6 @@ 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 | NatCong : R_nonelim PNat PNat | IndCong P0 P1 a0 a1 b0 b1 c0 c1 : @@ -1158,7 +1146,7 @@ Module NeEPar. R_nonelim a0 a1 -> (* ------------ *) R_nonelim (PSuc a0) (PSuc a1) - with R_elim {n} : PTm n -> PTm n -> Prop := + with R_elim : PTm -> PTm -> Prop := | NAbsCong a0 a1 : R_nonelim a0 a1 -> R_elim (PAbs a0) (PAbs a1) @@ -1181,8 +1169,6 @@ 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 : @@ -1204,11 +1190,11 @@ Module NeEPar. 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. @@ -1237,22 +1223,22 @@ Module NeEPar. - 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. @@ -1260,51 +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 PApp_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 PInd_imp : forall n Q (a : PTm n) b c, + 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_SucInv : forall n (a : PTm n), P (PSuc a) -> P a. - Axiom P_BindInv : forall n p (A : PTm n) B, P (PBind p A B) -> P A /\ P B. - Axiom P_IndInv : forall n Q (a : PTm n) b c, P (PInd Q a b c) -> P Q /\ P a /\ P b /\ P c. - - 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. @@ -1312,62 +1292,61 @@ 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 PApp_imp : forall n a b, @ishf n a -> ~~ isabs a -> ~ P (PApp a b). + 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 n p a, @ishf n a -> ~~ ispair a -> ~ P (PProj p a). + Lemma PProj_imp : forall p a, ishf a -> ~~ ispair a -> ~ P (PProj p a). sfirstorder use:fp_red.PProj_imp. Qed. - Lemma PInd_imp : forall n Q (a : PTm n) b c, + 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 n (a b : PTm n), P (PApp a b) -> P a /\ P b. + 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_SucInv : forall n (a : PTm n), P (PSuc a) -> P a. + Lemma P_SucInv : forall (a : PTm), P (PSuc a) -> P a. Proof. sauto lq:on. Qed. - Lemma P_AbsInv : forall n (a : PTm (S n)), P (PAbs a) -> P a. + 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 n Q (a : PTm n) b c, P (PInd Q a b c) -> P Q /\ P a /\ P b /\ P c. + 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. @@ -1378,13 +1357,13 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). Import M MFacts. #[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]]. @@ -1404,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)) @@ -1414,7 +1399,7 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). have ? : ishf (ren_PTm shift b) by scongruence use:ishf_ren. exfalso. sfirstorder use:PApp_imp. - - move => n a0 a1 h ih /[dup] hP. + - move => a0 a1 h ih /[dup] hP. move /P_PairInv => [/P_ProjInv + _]. move : ih => /[apply]. move => [b [ih0 ih1]]. @@ -1439,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. @@ -1462,7 +1447,7 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). have : P (PApp a2 b0) by sfirstorder use:RReds.AppCong, @rtc_refl, P_RReds. 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). @@ -1487,8 +1472,7 @@ 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. - - hauto l:on ctrs:NeEPar.R_nonelim. - - move => n P0 P1 a0 a1 b0 b1 c0 c1 hP ihP ha iha hb ihb hc ihc /[dup] hInd /P_IndInv. + - 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]. @@ -1514,32 +1498,32 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). - 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. @@ -1558,7 +1542,7 @@ 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) @@ -1569,7 +1553,7 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). 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. @@ -1582,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]. @@ -1619,8 +1603,7 @@ 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. - - hauto q:on ctrs:rtc inv:RRed.R. - - move => n P0 P1 a0 a1 b0 b1 c0 c1 hP ihP ha iha hb ihb hc ihc u. + - 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. @@ -1650,7 +1633,12 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). apply : rtc_r. apply RReds.IndCong; eauto; eauto using rtc_refl. apply RRed.IndSuc. - apply EPar.morphing;eauto. hauto lq:on ctrs:EPar.R inv:option use:NeEPar.ToEPar. + 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. @@ -1672,7 +1660,7 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). 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 => n a0 a1 ha iha u /P_SucInv ha0. + - 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]]. @@ -1681,8 +1669,8 @@ Module UniqueNF (M : NoForbid) (MFacts : NoForbid_FactSig M). 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. @@ -1698,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. @@ -1716,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 : @@ -1765,9 +1753,9 @@ Module ERed. 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. @@ -1777,38 +1765,34 @@ 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 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. (* Characterization of variable freeness conditions *) - Definition tm_i_free {n} a (i : fin n) := exists m (ξ ξ0 : fin n -> fin m), ξ i <> ξ0 i /\ ren_PTm ξ a = ren_PTm ξ0 a. + Definition tm_i_free a (i : fin n) := exists m (ξ ξ0 : fin n -> fin m), ξ i <> ξ0 i /\ ren_PTm a = ren_PTm0 a. Lemma subst_differ_one_ren_up n m i (ξ0 ξ1 : fin n -> fin m) : (forall j, i <> j -> ξ0 j = ξ1 j) -> - (forall j, shift i <> j -> upRen_PTm_PTm ξ0 j = upRen_PTm_PTm ξ1 j). + (forall j, shift i <> j -> upRen_PTm_PTm0 j = upRen_PTm_PTm1 j). Proof. move => hξ. destruct j. asimpl. @@ -1820,7 +1804,7 @@ Module ERed. Lemma tm_free_ren_any n a i : tm_i_free a i -> forall m (ξ0 ξ1 : fin n -> fin m), (forall j, i <> j -> ξ0 j = ξ1 j) -> - ren_PTm ξ0 a = ren_PTm ξ1 a. + ren_PTm0 a = ren_PTm1 a. Proof. rewrite /tm_i_free. move => [+ [+ [+ +]]]. @@ -1841,7 +1825,7 @@ Module ERed. 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)). + move /(_ _ (upRen_PTm_PTm0) (upRen_PTm_PTm1)). apply. hauto l:on. - hauto lq:on rew:off. - hauto lq:on rew:off. @@ -1851,12 +1835,12 @@ Module ERed. - admit. Admitted. - Lemma antirenaming n m (a : PTm n) (b : PTm m) (ξ : fin n -> fin m) : + Lemma antirenaming n m (a : PTm) (b : PTm) (ξ : fin n -> fin m) : (forall i j, ξ i = ξ j -> i = j) -> - R (ren_PTm ξ a) b -> exists b0, R a b0 /\ ren_PTm ξ b0 = b. + 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 E : (ren_PTm a) => u hu. move : n ξ a hξ E. elim : m u b / hu; try solve_anti_ren. - move => n a m ξ []//=. @@ -1870,7 +1854,7 @@ Module ERed. move => [p ?]. subst. move : h. asimpl. replace (ren_PTm (funcomp shift ξ) p) with - (ren_PTm shift (ren_PTm ξ p)); last by asimpl. + (ren_PTm shift (ren_PTm p)); last by asimpl. move /ren_injective. move /(_ ltac:(hauto l:on)). move => ?. subst. @@ -1886,14 +1870,14 @@ Module ERed. sauto lq:on use:up_injective. - move => n p A B0 B1 hB ihB m ξ + hξ. case => //= p' A2 B2 [*]. subst. - have : (forall i j, (upRen_PTm_PTm ξ) i = (upRen_PTm_PTm ξ) j -> i = j) by sauto. + have : (forall i j, (upRen_PTm_PTm) i = (upRen_PTm_PTm) j -> i = j) by sauto. move => {}/ihB => ihB. spec_refl. sauto lq:on. Admitted. - Lemma substing n m (a b : PTm n) (ρ : fin n -> PTm m) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). + Lemma substing n m (a b : PTm) (ρ : fin n -> PTm) : + R a b -> R (subst_PTm a) (subst_PTm b). Proof. move => h. move : m ρ. elim : n a b /h => n. move => a m ρ /=. @@ -1901,7 +1885,7 @@ Module ERed. all : hauto lq:on ctrs:R. Qed. - Lemma nf_preservation n (a b : PTm n) : + Lemma nf_preservation n (a b : PTm) : ERed.R a b -> (nf a -> nf b) /\ (ne a -> ne b). Proof. move => h. @@ -1925,36 +1909,36 @@ Module EReds. rtc ERed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong n (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 n (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 n 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 n 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 n (a0 a1 : PTm n) : + Lemma SucCong n (a0 a1 : PTm) : rtc ERed.R a0 a1 -> rtc ERed.R (PSuc a0) (PSuc a1). Proof. solve_s. Qed. - Lemma IndCong n P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 : + Lemma IndCong n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : rtc ERed.R P0 P1 -> rtc ERed.R a0 a1 -> rtc ERed.R b0 b1 -> @@ -1962,11 +1946,11 @@ Module EReds. rtc ERed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. solve_s. Qed. - Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : - rtc ERed.R a b -> rtc ERed.R (ren_PTm ξ a) (ren_PTm ξ b). + Lemma renaming n m (a b : PTm) (ξ : fin n -> fin m) : + rtc ERed.R a b -> rtc ERed.R (ren_PTm a) (ren_PTm b). Proof. induction 1; hauto l:on use:ERed.renaming ctrs:rtc. Qed. - Lemma FromEPar n (a b : PTm n) : + Lemma FromEPar n (a b : PTm) : EPar.R a b -> rtc ERed.R a b. Proof. @@ -1981,18 +1965,18 @@ Module EReds. apply ERed.PairEta. Qed. - Lemma FromEPars n (a b : PTm n) : + Lemma FromEPars n (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 n m (a b : PTm n) (ρ : fin n -> PTm m) : - rtc ERed.R a b -> rtc ERed.R (subst_PTm ρ a) (subst_PTm ρ b). + Lemma substing n m (a b : PTm) (ρ : fin n -> 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 n (a0 b0 C : PTm n) : + Lemma app_inv n (a0 b0 C : PTm) : rtc ERed.R (PApp a0 b0) C -> exists a1 b1, C = PApp a1 b1 /\ rtc ERed.R a0 a1 /\ @@ -2006,7 +1990,7 @@ Module EReds. hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R. Qed. - Lemma proj_inv n p (a C : PTm n) : + Lemma proj_inv n p (a C : PTm) : rtc ERed.R (PProj p a) C -> exists c, C = PProj p c /\ rtc ERed.R a c. Proof. @@ -2016,7 +2000,7 @@ Module EReds. scrush ctrs:rtc,ERed.R inv:ERed.R. Qed. - Lemma bind_inv n p (A : PTm n) B C : + Lemma bind_inv n 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. @@ -2027,7 +2011,7 @@ Module EReds. hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. Qed. - Lemma suc_inv n (a : PTm n) C : + Lemma suc_inv n (a : PTm) C : rtc ERed.R (PSuc a) C -> exists b, rtc ERed.R a b /\ C = PSuc b. Proof. @@ -2038,14 +2022,14 @@ Module EReds. - hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. Qed. - Lemma zero_inv n (C : PTm n) : + Lemma zero_inv n (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 n P (a : PTm n) b c C : + Lemma ind_inv n 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 /\ @@ -2063,37 +2047,37 @@ End EReds. #[export]Hint Constructors ERed.R RRed.R EPar.R : red. Module EJoin. - Definition R {n} (a b : PTm n) := exists c, rtc ERed.R a c /\ rtc ERed.R b c. + Definition R (a b : PTm) := exists c, rtc ERed.R a c /\ rtc ERed.R b c. - Lemma hne_app_inj n (a0 b0 a1 b1 : PTm n) : + Lemma hne_app_inj n (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 n p0 p1 (a0 a1 : PTm n) : + Lemma hne_proj_inj n 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 n p0 p1 (A0 A1 : PTm n) B0 B1 : + Lemma bind_inj n 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 n (A0 A1 : PTm n) : + Lemma suc_inj n (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 n P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 : + Lemma ind_inj n 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. @@ -2101,7 +2085,7 @@ Module EJoin. 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) @@ -2162,79 +2146,79 @@ Module RERed. R a0 a1 -> R (PSuc a0) (PSuc a1). - Lemma ToBetaEta n (a b : PTm n) : + Lemma ToBetaEta n (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 n (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 n (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 n (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 n (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 n (a b : PTm n) : + Lemma bind_preservation n (a b : PTm) : R a b -> isbind a -> isbind b. Proof. hauto q:on inv:R. Qed. - Lemma univ_preservation n (a b : PTm n) : + Lemma univ_preservation n (a b : PTm) : R a b -> isuniv a -> isuniv b. Proof. hauto q:on inv:R. Qed. - Lemma nat_preservation n (a b : PTm n) : + Lemma nat_preservation n (a b : PTm) : R a b -> isnat a -> isnat b. Proof. hauto q:on inv:R. Qed. - Lemma sne_preservation n (a b : PTm n) : + Lemma sne_preservation n (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 n m (a b : PTm n) (ρ : fin n -> PTm m) : - RERed.R a b -> RERed.R (subst_PTm ρ a) (subst_PTm ρ b). + Lemma substing n m (a b : PTm) (ρ : fin n -> 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 n (a b : PTm n) : + Lemma hne_preservation n (a b : PTm) : RERed.R a b -> ishne a -> ishne b. Proof. induction 1; sfirstorder. Qed. End RERed. Module REReds. - Lemma hne_preservation n (a b : PTm n) : + Lemma hne_preservation n (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 n (a b : PTm n) : + Lemma sn_preservation n (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 n (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 n (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. @@ -2251,29 +2235,29 @@ Module REReds. rtc RERed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong n (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 n (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 n p (a0 a1 : PTm) : rtc RERed.R a0 a1 -> rtc RERed.R (PProj p a0) (PProj p a1). Proof. solve_s. Qed. - Lemma SucCong n (a0 a1 : PTm n) : + Lemma SucCong n (a0 a1 : PTm) : rtc RERed.R a0 a1 -> rtc RERed.R (PSuc a0) (PSuc a1). Proof. solve_s. Qed. - Lemma IndCong n P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 : + Lemma IndCong n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : rtc RERed.R P0 P1 -> rtc RERed.R a0 a1 -> rtc RERed.R b0 b1 -> @@ -2281,25 +2265,25 @@ Module REReds. rtc RERed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. solve_s. Qed. - Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : + Lemma BindCong n 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 n (a b : PTm n) : + Lemma bind_preservation n (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 n (a b : PTm n) : + Lemma univ_preservation n (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 n (a b : PTm n) : + Lemma nat_preservation n (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 n (a b : PTm n) : + Lemma sne_preservation n (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. @@ -2329,7 +2313,7 @@ Module REReds. move : i E. elim : u C /hu; hauto lq:on rew:off inv:RERed.R. Qed. - Lemma hne_app_inv n (a0 b0 C : PTm n) : + Lemma hne_app_inv n (a0 b0 C : PTm) : rtc RERed.R (PApp a0 b0) C -> ishne a0 -> exists a1 b1, C = PApp a1 b1 /\ @@ -2344,7 +2328,7 @@ Module REReds. hauto lq:on rew:off ctrs:rtc, RERed.R use:RERed.hne_preservation inv:RERed.R. Qed. - Lemma hne_proj_inv n p (a C : PTm n) : + Lemma hne_proj_inv n p (a C : PTm) : rtc RERed.R (PProj p a) C -> ishne a -> exists c, C = PProj p c /\ rtc RERed.R a c. @@ -2355,7 +2339,7 @@ Module REReds. scrush ctrs:rtc,RERed.R use:RERed.hne_preservation inv:RERed.R. Qed. - Lemma hne_ind_inv n P a b c (C : PTm n) : + Lemma hne_ind_inv n 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 /\ @@ -2369,47 +2353,47 @@ Module REReds. scrush ctrs:rtc,RERed.R use:RERed.hne_preservation inv:RERed.R. Qed. - Lemma substing n m (a b : PTm n) (ρ : fin n -> PTm m) : - rtc RERed.R a b -> rtc RERed.R (subst_PTm ρ a) (subst_PTm ρ b). + Lemma substing n m (a b : PTm) (ρ : fin n -> 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 n m (ρ0 ρ1 : fin n -> PTm m) : + Lemma cong_up n m (ρ0 ρ1 : fin n -> 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)). + (forall i, rtc RERed.R (up_PTm_PTm0 i) (up_PTm_PTm1 i)). Proof. move => h i. destruct i as [i|]. simpl. rewrite /funcomp. substify. by apply substing. apply rtc_refl. Qed. - Lemma cong_up2 n m (ρ0 ρ1 : fin n -> PTm m) : + Lemma cong_up2 n m (ρ0 ρ1 : fin n -> 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)). + (forall i, rtc RERed.R (up_PTm_PTm (up_PTm_PTm0) i) (up_PTm_PTm (up_PTm_PTm1) i)). Proof. hauto l:on use:cong_up. Qed. - Lemma cong n m (a : PTm n) (ρ0 ρ1 : fin n -> PTm m) : + Lemma cong n m (a : PTm) (ρ0 ρ1 : fin n -> PTm) : (forall i, rtc RERed.R (ρ0 i) (ρ1 i)) -> - rtc RERed.R (subst_PTm ρ0 a) (subst_PTm ρ1 a). + rtc RERed.R (subst_PTm0 a) (subst_PTm1 a). Proof. move : m ρ0 ρ1. elim : n / a => /=; eauto 20 using AppCong, AbsCong, BindCong, ProjCong, PairCong, cong_up, rtc_refl, IndCong, SucCong, cong_up2. Qed. - Lemma cong' n m (a b : PTm n) (ρ0 ρ1 : fin n -> PTm m) : + Lemma cong' n m (a b : PTm) (ρ0 ρ1 : fin n -> 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). + rtc RERed.R (subst_PTm0 a) (subst_PTm1 b). Proof. move => h0 h1. - have : rtc RERed.R (subst_PTm ρ0 a) (subst_PTm ρ1 a) by eauto using cong. + have : rtc RERed.R (subst_PTm0 a) (subst_PTm1 a) by eauto using cong. move => ?. apply : relations.rtc_transitive; eauto. hauto l:on use:substing. Qed. - Lemma ToEReds n (a b : PTm n) : + Lemma ToEReds n (a b : PTm) : nf a -> rtc RERed.R a b -> rtc ERed.R a b. Proof. @@ -2417,14 +2401,14 @@ Module REReds. induction h; hauto lq:on rew:off ctrs:rtc use:RERed.ToBetaEta, RReds.nf_refl, @rtc_once, ERed.nf_preservation. Qed. - Lemma zero_inv n (C : PTm n) : + Lemma zero_inv n (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 n (a : PTm n) C : + Lemma suc_inv n (a : PTm) C : rtc RERed.R (PSuc a) C -> exists b, rtc RERed.R a b /\ C = PSuc b. Proof. @@ -2447,7 +2431,7 @@ Module REReds. 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) @@ -2515,7 +2499,7 @@ Module LoRed. R a0 a1 -> R (PSuc a0) (PSuc a1). - Lemma hf_preservation n (a b : PTm n) : + Lemma hf_preservation n (a b : PTm) : LoRed.R a b -> ishf a -> ishf b. @@ -2523,12 +2507,12 @@ Module LoRed. move => h. elim : n a b /h=>//=. Qed. - Lemma ToRRed n (a b : PTm n) : + Lemma ToRRed n (a b : PTm) : LoRed.R a b -> RRed.R a b. Proof. induction 1; hauto lq:on ctrs:RRed.R. Qed. - Lemma AppAbs' n a (b : PTm n) u : + Lemma AppAbs' n a (b : PTm) u : u = (subst_PTm (scons b VarPTm) a) -> R (PApp (PAbs a) b) u. Proof. move => ->. apply AppAbs. Qed. @@ -2538,8 +2522,8 @@ Module LoRed. R (@PInd n P (PSuc a) b c) u. Proof. move => ->. apply IndSuc. Qed. - Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : - R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). + Lemma renaming n m (a b : PTm) (ξ : fin n -> fin m) : + R a b -> R (ren_PTm a) (ren_PTm b). Proof. move => h. move : m ξ. elim : n a b /h. @@ -2553,7 +2537,7 @@ Module LoRed. End LoRed. Module LoReds. - Lemma hf_preservation n (a b : PTm n) : + Lemma hf_preservation n (a b : PTm) : rtc LoRed.R a b -> ishf a -> ishf b. @@ -2561,7 +2545,7 @@ Module LoReds. induction 1; eauto using LoRed.hf_preservation. Qed. - Lemma hf_ne_imp n (a b : PTm n) : + Lemma hf_ne_imp n (a b : PTm) : rtc LoRed.R a b -> ne b -> ~~ ishf a. @@ -2582,34 +2566,34 @@ Module LoReds. rtc LoRed.R (PAbs a) (PAbs b). Proof. solve_s. Qed. - Lemma AppCong n (a0 a1 b0 b1 : PTm n) : + Lemma AppCong n (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 n (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 n 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 n 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. - Lemma IndCong n P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 : + Lemma IndCong n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : rtc LoRed.R a0 a1 -> rtc LoRed.R P0 P1 -> rtc LoRed.R b0 b1 -> @@ -2620,7 +2604,7 @@ Module LoReds. rtc LoRed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. solve_s. Qed. - Lemma SucCong n (a0 a1 : PTm n) : + Lemma SucCong n (a0 a1 : PTm) : rtc LoRed.R a0 a1 -> rtc LoRed.R (PSuc a0) (PSuc a1). Proof. solve_s. Qed. @@ -2628,9 +2612,9 @@ Module LoReds. Local Ltac triv := simpl in *; itauto. 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). + (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. @@ -2666,49 +2650,49 @@ Module LoReds. Lemma FromSN : forall n a, @SN n a -> exists v, rtc LoRed.R a v /\ nf v. Proof. firstorder using FromSN_mutual. Qed. - Lemma ToRReds : forall n (a b : PTm n), rtc LoRed.R a b -> rtc RRed.R a b. + Lemma ToRReds : forall n (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 - | PApp a b => 1 + Nat.add (size_PTm a) (size_PTm b) - | PProj p a => 1 + size_PTm a - | PPair a b => 3 + Nat.add (size_PTm a) (size_PTm b) + | PAbs a => 3 + size_PTm + | PApp a b => 1 + Nat.add (size_PTm) (size_PTm) + | PProj p a => 1 + size_PTm + | PPair a b => 3 + Nat.add (size_PTm) (size_PTm) | PUniv _ => 3 - | PBind p A B => 3 + Nat.add (size_PTm A) (size_PTm B) - | PInd P a b c => 3 + size_PTm P + size_PTm a + size_PTm b + size_PTm c + | PBind p A B => 3 + Nat.add (size_PTm) (size_PTm) + | PInd P a b c => 3 + size_PTm + size_PTm + size_PTm + size_PTm | PNat => 3 - | PSuc a => 3 + size_PTm a + | PSuc a => 3 + size_PTm | PZero => 3 | PBot => 1 end. -Lemma size_PTm_ren n m (ξ : fin n -> fin m) a : size_PTm (ren_PTm ξ a) = size_PTm a. +Lemma size_PTm_ren n m (ξ : fin n -> fin m) a : size_PTm (ren_PTm a) = size_PTm. Proof. move : m ξ. elim : n / 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. + size_PTm < size_PTm. Proof. move => h. elim : n a b /h; hauto l:on rew:db:sizetm. Qed. -Lemma ered_sn n (a : PTm n) : sn ERed.R a. +Lemma ered_sn n (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 n (a b c : PTm) : ERed.R a b -> ERed.R a c -> exists d, rtc ERed.R b d /\ rtc ERed.R c d. @@ -2814,7 +2798,7 @@ Proof. - qauto l:on inv:ERed.R ctrs:rtc use:EReds.SucCong. Qed. -Lemma ered_confluence n (a b c : PTm n) : +Lemma ered_confluence n (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. @@ -2822,18 +2806,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 n (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 n (a b c : PTm) : rtc RRed.R a b -> rtc RRed.R a c -> nf b -> @@ -2848,20 +2832,20 @@ Proof. Qed. Module NeEPars. - Lemma R_nonelim_nf n (a b : PTm n) : + Lemma R_nonelim_nf n (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 n, (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 n (a c : PTm) : SN a -> rtc RERed.R a c -> exists b, rtc RRed.R a b /\ rtc NeEPar.R_nonelim b c. @@ -2878,7 +2862,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 n (a b c : PTm) : SN a -> rtc RERed.R a b -> rtc RERed.R a c -> @@ -2912,14 +2896,14 @@ Qed. (* Beta joinability *) Module BJoin. - Definition R {n} (a b : PTm n) := exists c, rtc RRed.R a c /\ rtc RRed.R b c. - Lemma refl n (a : PTm n) : R a a. + Definition R (a b : PTm) := exists c, rtc RRed.R a c /\ rtc RRed.R b c. + Lemma refl n (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 n (a b : PTm) : R a b -> R b a. Proof. sfirstorder unfold:R. Qed. - Lemma transitive n (a b c : PTm n) : R a b -> R b c -> R a c. + Lemma transitive n (a b c : PTm) : R a b -> R b c -> R a c. Proof. rewrite /R. move => [ab [ha +]] [bc [+ hc]]. @@ -2933,7 +2917,7 @@ Module BJoin. (* R (PAbs a) (PAbs b). *) (* Proof. hauto lq:on use:RReds.AbsCong unfold:R. Qed. *) - (* Lemma AppCong n (a0 a1 b0 b1 : PTm n) : *) + (* Lemma AppCong n (a0 a1 b0 b1 : PTm) : *) (* R a0 a1 -> *) (* R b0 b1 -> *) (* R (PApp a0 b0) (PApp a1 b1). *) @@ -2941,21 +2925,21 @@ Module BJoin. End BJoin. Module DJoin. - Definition R {n} (a b : PTm n) := exists c, rtc RERed.R a c /\ rtc RERed.R b c. + Definition R (a b : PTm) := exists c, rtc RERed.R a c /\ rtc RERed.R b c. - Lemma refl n (a : PTm n) : R a a. + Lemma refl n (a : PTm) : R a a. Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma FromEJoin n (a b : PTm n) : EJoin.R a b -> DJoin.R a b. + Lemma FromEJoin n (a b : PTm) : EJoin.R a b -> DJoin.R a b. Proof. hauto q:on use:REReds.FromEReds. Qed. - Lemma ToEJoin n (a b : PTm n) : nf a -> nf b -> DJoin.R a b -> EJoin.R a b. + Lemma ToEJoin n (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 n (a b : PTm n) : R a b -> R b a. + Lemma symmetric n (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 n (a b c : PTm) : SN b -> R a b -> R b c -> R a c. Proof. rewrite /R. move => + [ab [ha +]] [bc [+ hc]]. @@ -2969,30 +2953,30 @@ Module DJoin. 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 n (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 n (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 n p (a0 a1 : PTm) : R a0 a1 -> R (PProj p a0) (PProj p a1). Proof. hauto q:on use:REReds.ProjCong. Qed. - Lemma BindCong n p (A0 A1 : PTm n) B0 B1 : + Lemma BindCong n 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 n P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 : + Lemma IndCong n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : R P0 P1 -> R a0 a1 -> R b0 b1 -> @@ -3000,12 +2984,12 @@ Module DJoin. R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. hauto q:on use:REReds.IndCong. Qed. - Lemma SucCong n (a0 a1 : PTm n) : + Lemma SucCong n (a0 a1 : PTm) : R a0 a1 -> R (PSuc a0) (PSuc a1). Proof. qauto l:on use:REReds.SucCong. Qed. - Lemma FromRedSNs n (a b : PTm n) : + Lemma FromRedSNs n (a b : PTm) : rtc TRedSN a b -> R a b. Proof. @@ -3013,7 +2997,7 @@ Module DJoin. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma sne_nat_noconf n (a b : PTm n) : + Lemma sne_nat_noconf n (a b : PTm) : R a b -> SNe a -> isnat b -> False. Proof. move => [c [? ?]] *. @@ -3021,7 +3005,7 @@ Module DJoin. qauto l:on inv:SNe. Qed. - Lemma sne_bind_noconf n (a b : PTm n) : + Lemma sne_bind_noconf n (a b : PTm) : R a b -> SNe a -> isbind b -> False. Proof. move => [c [? ?]] *. @@ -3029,14 +3013,14 @@ Module DJoin. qauto l:on inv:SNe. Qed. - Lemma sne_univ_noconf n (a b : PTm n) : + Lemma sne_univ_noconf n (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 n (a b : PTm n) : + Lemma bind_univ_noconf n (a b : PTm) : R a b -> isbind a -> isuniv b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3046,7 +3030,7 @@ Module DJoin. case : c => //=; itauto. Qed. - Lemma hne_univ_noconf n (a b : PTm n) : + Lemma hne_univ_noconf n (a b : PTm) : R a b -> ishne a -> isuniv b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3057,7 +3041,7 @@ Module DJoin. case : c => //=. Qed. - Lemma hne_bind_noconf n (a b : PTm n) : + Lemma hne_bind_noconf n (a b : PTm) : R a b -> ishne a -> isbind b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3068,7 +3052,7 @@ Module DJoin. case : c => //=. Qed. - Lemma hne_nat_noconf n (a b : PTm n) : + Lemma hne_nat_noconf n (a b : PTm) : R a b -> ishne a -> isnat b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3076,7 +3060,7 @@ Module DJoin. clear. case : c => //=; itauto. Qed. - Lemma bind_inj n p0 p1 (A0 A1 : PTm n) B0 B1 : + Lemma bind_inj n 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. @@ -3094,14 +3078,14 @@ Module DJoin. sauto lq:on rew:off use:REReds.univ_inv. Qed. - Lemma suc_inj n (A0 A1 : PTm n) : + Lemma suc_inj n (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 n (a0 b0 a1 b1 : PTm n) : + Lemma hne_app_inj n (a0 b0 a1 b1 : PTm) : R (PApp a0 b0) (PApp a1 b1) -> ishne a0 -> ishne a1 -> @@ -3110,7 +3094,7 @@ Module DJoin. hauto lq:on use:REReds.hne_app_inv. Qed. - Lemma hne_proj_inj n p0 p1 (a0 a1 : PTm n) : + Lemma hne_proj_inj n p0 p1 (a0 a1 : PTm) : R (PProj p0 a0) (PProj p1 a1) -> ishne a0 -> ishne a1 -> @@ -3119,45 +3103,45 @@ Module DJoin. sauto lq:on use:REReds.hne_proj_inv. Qed. - Lemma FromRRed0 n (a b : PTm n) : + Lemma FromRRed0 n (a b : PTm) : RRed.R a b -> R a b. Proof. hauto lq:on ctrs:rtc use:RERed.FromBeta unfold:R. Qed. - Lemma FromRRed1 n (a b : PTm n) : + Lemma FromRRed1 n (a b : PTm) : RRed.R b a -> R a b. Proof. hauto lq:on ctrs:rtc use:RERed.FromBeta unfold:R. Qed. - Lemma FromRReds n (a b : PTm n) : + Lemma FromRReds n (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 n (a b : PTm n) : + Lemma FromBJoin n (a b : PTm) : BJoin.R a b -> R a b. Proof. hauto lq:on ctrs:rtc use:REReds.FromRReds unfold:R. Qed. - Lemma substing n m (a b : PTm n) (ρ : fin n -> PTm m) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). + Lemma substing n m (a b : PTm) (ρ : fin n -> 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 n m (a b : PTm n) (ρ : fin n -> fin m) : - R a b -> R (ren_PTm ρ a) (ren_PTm ρ b). + Lemma renaming n m (a b : PTm) (ρ : fin n -> fin m) : + R a b -> R (ren_PTm a) (ren_PTm b). Proof. substify. apply substing. Qed. - Lemma weakening n (a b : PTm n) : + Lemma weakening n (a b : PTm) : R a b -> R (ren_PTm shift a) (ren_PTm shift b). Proof. apply renaming. Qed. - Lemma cong n m (a : PTm (S n)) c d (ρ : fin n -> PTm m) : + Lemma cong n m (a : PTm (S n)) c d (ρ : fin n -> PTm) : R c d -> R (subst_PTm (scons c ρ) a) (subst_PTm (scons d ρ) a). Proof. rewrite /R. move => [cd [h0 h1]]. @@ -3165,7 +3149,7 @@ Module DJoin. hauto q:on ctrs:rtc inv:option use:REReds.cong. Qed. - Lemma cong' n m (a b : PTm (S n)) c d (ρ : fin n -> PTm m) : + Lemma cong' n m (a b : PTm (S n)) c d (ρ : fin n -> PTm) : R a b -> R c d -> R (subst_PTm (scons c ρ) a) (subst_PTm (scons d ρ) b). Proof. @@ -3174,7 +3158,7 @@ Module DJoin. hauto q:on ctrs:rtc inv:option use:REReds.cong'. Qed. - Lemma pair_inj n (a0 a1 b0 b1 : PTm n) : + Lemma pair_inj n (a0 a1 b0 b1 : PTm) : SN (PPair a0 b0) -> SN (PPair a1 b1) -> R (PPair a0 b0) (PPair a1 b1) -> @@ -3201,7 +3185,7 @@ Module DJoin. split; eauto using transitive. Qed. - Lemma ejoin_pair_inj n (a0 a1 b0 b1 : PTm n) : + Lemma ejoin_pair_inj n (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. @@ -3250,7 +3234,7 @@ Module DJoin. hauto l:on use:ToEJoin. Qed. - Lemma standardization n (a b : PTm n) : + Lemma standardization n (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. @@ -3270,7 +3254,7 @@ Module DJoin. hauto q:on use:NeEPars.ToEReds unfold:EJoin.R. Qed. - Lemma standardization_lo n (a b : PTm n) : + Lemma standardization_lo n (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. @@ -3288,7 +3272,7 @@ End DJoin. Module Sub1. - Inductive R {n} : PTm n -> PTm n -> Prop := + Inductive R : PTm -> PTm -> Prop := | Refl a : R a a | Univ i j : @@ -3303,21 +3287,21 @@ Module Sub1. R B0 B1 -> R (PBind PSig A0 B0) (PBind PSig A1 B1). - Lemma transitive0 n (A B C : PTm n) : + Lemma transitive0 n (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 : n A B /h; hauto lq:on ctrs:R inv:R solve+:lia. Qed. - Lemma transitive n (A B C : PTm n) : + Lemma transitive n (A B C : PTm) : R A B -> R B C -> R A C. Proof. hauto q:on use:transitive0. Qed. - Lemma refl n (A : PTm n) : R A A. + Lemma refl n (A : PTm) : R A A. Proof. sfirstorder. Qed. - Lemma commutativity0 n (A B C : PTm n) : + Lemma commutativity0 n (A B C : PTm) : R A B -> (RERed.R A C -> exists D, RERed.R B D /\ R C D) /\ @@ -3328,7 +3312,7 @@ Module Sub1. elim : n A B / h; hauto lq:on ctrs:RERed.R, R inv:RERed.R. Qed. - Lemma commutativity_Ls n (A B C : PTm n) : + Lemma commutativity_Ls n (A B C : PTm) : R A B -> rtc RERed.R A C -> exists D, rtc RERed.R B D /\ R C D. @@ -3336,7 +3320,7 @@ Module Sub1. move => + h. move : B. induction h; sauto lq:on use:commutativity0. Qed. - Lemma commutativity_Rs n (A B C : PTm n) : + Lemma commutativity_Rs n (A B C : PTm) : R A B -> rtc RERed.R B C -> exists D, rtc RERed.R A D /\ R D C. @@ -3345,46 +3329,46 @@ Module Sub1. Qed. Lemma sn_preservation : forall n, - (forall (a : PTm n) (s : SNe a), forall b, R a b \/ R b a -> a = b) /\ - (forall (a : PTm n) (s : SN a), forall b, R a b \/ R b a -> SN b) /\ - (forall (a b : PTm n) (_ : TRedSN a b), forall c, R a c \/ R c a -> a = c). + (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 n (a b : PTm n) : + Lemma bind_preservation n (a b : PTm) : R a b -> isbind a = isbind b. Proof. hauto q:on inv:R. Qed. - Lemma univ_preservation n (a b : PTm n) : + Lemma univ_preservation n (a b : PTm) : R a b -> isuniv a = isuniv b. Proof. hauto q:on inv:R. Qed. - Lemma sne_preservation n (a b : PTm n) : + Lemma sne_preservation n (a b : PTm) : R a b -> SNe a <-> SNe b. Proof. hfcrush use:sn_preservation. Qed. - Lemma renaming n m (a b : PTm n) (ξ : fin n -> fin m) : - R a b -> R (ren_PTm ξ a) (ren_PTm ξ b). + Lemma renaming n m (a b : PTm) (ξ : fin n -> fin m) : + R a b -> R (ren_PTm a) (ren_PTm b). Proof. move => h. move : m ξ. elim : n a b /h; hauto lq:on ctrs:R. Qed. - Lemma substing n m (a b : PTm n) (ρ : fin n -> PTm m) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). + Lemma substing n m (a b : PTm) (ρ : fin n -> PTm) : + R a b -> R (subst_PTm a) (subst_PTm b). Proof. move => h. move : m ρ. elim : n a b /h; hauto lq:on ctrs:R. Qed. - Lemma hne_refl n (a b : PTm n) : + Lemma hne_refl n (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 {n} (a b : PTm n) := exists c0 c1, rtc ERed.R a c0 /\ rtc ERed.R b c1 /\ Sub1.R c0 c1. + 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 n (A0 A1 : PTm n) B0 B1 : + Lemma pi_inj n (A0 A1 : PTm) B0 B1 : R (PBind PPi A0 B0) (PBind PPi A1 B1) -> R A1 A0 /\ R B0 B1. Proof. @@ -3394,7 +3378,7 @@ Module ESub. sauto lq:on rew:off inv:Sub1.R. Qed. - Lemma sig_inj n (A0 A1 : PTm n) B0 B1 : + Lemma sig_inj n (A0 A1 : PTm) B0 B1 : R (PBind PSig A0 B0) (PBind PSig A1 B1) -> R A0 A1 /\ R B0 B1. Proof. @@ -3404,7 +3388,7 @@ Module ESub. sauto lq:on rew:off inv:Sub1.R. Qed. - Lemma suc_inj n (a b : PTm n) : + Lemma suc_inj n (a b : PTm) : R (PSuc a) (PSuc b) -> R a b. Proof. @@ -3414,12 +3398,12 @@ Module ESub. End ESub. Module Sub. - Definition R {n} (a b : PTm n) := exists c d, rtc RERed.R a c /\ rtc RERed.R b d /\ Sub1.R c d. + Definition R (a b : PTm) := exists c d, rtc RERed.R a c /\ rtc RERed.R b d /\ Sub1.R c d. - Lemma refl n (a : PTm n) : R a a. + Lemma refl n (a : PTm) : R a a. Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma ToJoin n (a b : PTm n) : + Lemma ToJoin n (a b : PTm) : ishne a \/ ishne b -> R a b -> DJoin.R a b. @@ -3429,7 +3413,7 @@ Module Sub. hauto lq:on rew:off use:Sub1.hne_refl. Qed. - Lemma transitive n (a b c : PTm n) : SN b -> R a b -> R b c -> R a c. + Lemma transitive n (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. @@ -3441,10 +3425,10 @@ Module Sub. exists a',c'; hauto l:on use:Sub1.transitive, @relations.rtc_transitive. Qed. - Lemma FromJoin n (a b : PTm n) : DJoin.R a b -> R a b. + Lemma FromJoin n (a b : PTm) : DJoin.R a b -> R a b. Proof. sfirstorder. Qed. - Lemma PiCong n (A0 A1 : PTm n) B0 B1 : + Lemma PiCong n (A0 A1 : PTm) B0 B1 : R A1 A0 -> R B0 B1 -> R (PBind PPi A0 B0) (PBind PPi A1 B1). @@ -3456,7 +3440,7 @@ Module Sub. repeat split; eauto using REReds.BindCong, Sub1.PiCong. Qed. - Lemma SigCong n (A0 A1 : PTm n) B0 B1 : + Lemma SigCong n (A0 A1 : PTm) B0 B1 : R A0 A1 -> R B0 B1 -> R (PBind PSig A0 B0) (PBind PSig A1 B1). @@ -3473,7 +3457,7 @@ Module Sub. @R n (PUniv i) (PUniv j). Proof. hauto lq:on ctrs:Sub1.R, rtc. Qed. - Lemma sne_nat_noconf n (a b : PTm n) : + Lemma sne_nat_noconf n (a b : PTm) : R a b -> SNe a -> isnat b -> False. Proof. move => [c [d [h0 [h1 h2]]]] *. @@ -3481,7 +3465,7 @@ Module Sub. move : h2. clear. hauto q:on inv:Sub1.R, SNe. Qed. - Lemma nat_sne_noconf n (a b : PTm n) : + Lemma nat_sne_noconf n (a b : PTm) : R a b -> isnat a -> SNe b -> False. Proof. move => [c [d [h0 [h1 h2]]]] *. @@ -3489,7 +3473,7 @@ Module Sub. move : h2. clear. hauto q:on inv:Sub1.R, SNe. Qed. - Lemma sne_bind_noconf n (a b : PTm n) : + Lemma sne_bind_noconf n (a b : PTm) : R a b -> SNe a -> isbind b -> False. Proof. rewrite /R. @@ -3499,7 +3483,7 @@ Module Sub. qauto l:on inv:SNe. Qed. - Lemma hne_bind_noconf n (a b : PTm n) : + Lemma hne_bind_noconf n (a b : PTm) : R a b -> ishne a -> isbind b -> False. Proof. rewrite /R. @@ -3510,7 +3494,7 @@ Module Sub. clear. case : d => //=. Qed. - Lemma bind_sne_noconf n (a b : PTm n) : + Lemma bind_sne_noconf n (a b : PTm) : R a b -> SNe b -> isbind a -> False. Proof. rewrite /R. @@ -3520,14 +3504,14 @@ Module Sub. qauto l:on inv:SNe. Qed. - Lemma sne_univ_noconf n (a b : PTm n) : + Lemma sne_univ_noconf n (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 n (a b : PTm n) : + Lemma univ_sne_noconf n (a b : PTm) : R a b -> SNe b -> isuniv a -> False. Proof. move => [c[d] [? []]] *. @@ -3537,7 +3521,7 @@ Module Sub. clear. case : c => //=. inversion 2. Qed. - Lemma univ_nat_noconf n (a b : PTm n) : + Lemma univ_nat_noconf n (a b : PTm) : R a b -> isuniv b -> isnat a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3547,7 +3531,7 @@ Module Sub. clear. case : d => //=. Qed. - Lemma nat_univ_noconf n (a b : PTm n) : + Lemma nat_univ_noconf n (a b : PTm) : R a b -> isnat b -> isuniv a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3557,7 +3541,7 @@ Module Sub. clear. case : d => //=. Qed. - Lemma bind_nat_noconf n (a b : PTm n) : + Lemma bind_nat_noconf n (a b : PTm) : R a b -> isbind b -> isnat a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3568,7 +3552,7 @@ Module Sub. case : d h1 => //=. Qed. - Lemma nat_bind_noconf n (a b : PTm n) : + Lemma nat_bind_noconf n (a b : PTm) : R a b -> isnat b -> isbind a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3579,7 +3563,7 @@ Module Sub. case : d h1 => //=. Qed. - Lemma bind_univ_noconf n (a b : PTm n) : + Lemma bind_univ_noconf n (a b : PTm) : R a b -> isbind a -> isuniv b -> False. Proof. move => [c[d] [h0 [h1 h1']]] h2 h3. @@ -3590,7 +3574,7 @@ Module Sub. case : c => //=; itauto. Qed. - Lemma univ_bind_noconf n (a b : PTm n) : + Lemma univ_bind_noconf n (a b : PTm) : R a b -> isbind b -> isuniv a -> False. Proof. move => [c[d] [h0 [h1 h1']]] h2 h3. @@ -3601,7 +3585,7 @@ Module Sub. case : c => //=; itauto. Qed. - Lemma bind_inj n p0 p1 (A0 A1 : PTm n) B0 B1 : + Lemma bind_inj n 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. @@ -3618,7 +3602,7 @@ Module Sub. sauto lq:on rew:off use:REReds.univ_inv. Qed. - Lemma suc_inj n (A0 A1 : PTm n) : + Lemma suc_inj n (A0 A1 : PTm) : R (PSuc A0) (PSuc A1) -> R A0 A1. Proof. @@ -3626,7 +3610,7 @@ Module Sub. Qed. - Lemma cong n m (a b : PTm (S n)) c d (ρ : fin n -> PTm m) : + Lemma cong n m (a b : PTm (S n)) c d (ρ : fin n -> PTm) : R a b -> DJoin.R c d -> R (subst_PTm (scons c ρ) a) (subst_PTm (scons d ρ) b). Proof. rewrite /R. @@ -3639,18 +3623,18 @@ Module Sub. eauto using Sub1.substing. Qed. - Lemma substing n m (a b : PTm n) (ρ : fin n -> PTm m) : - R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). + Lemma substing n m (a b : PTm) (ρ : fin n -> 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 n (a b : PTm n) : nf a -> nf b -> R a b -> ESub.R a b. + Lemma ToESub n (a b : PTm) : nf a -> nf b -> R a b -> ESub.R a b. Proof. hauto q:on use:REReds.ToEReds. Qed. - Lemma standardization n (a b : PTm n) : + Lemma standardization n (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. @@ -3668,7 +3652,7 @@ Module Sub. hauto lq:on. Qed. - Lemma standardization_lo n (a b : PTm n) : + Lemma standardization_lo n (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. From 551dd5c17ca15a29d6bf1a45b5204463ba888f48 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 2 Mar 2025 20:19:11 -0500 Subject: [PATCH 03/51] Fix the fv proof --- theories/fp_red.v | 178 ++++++++++++++++++++++++++-------------------- 1 file changed, 101 insertions(+), 77 deletions(-) diff --git a/theories/fp_red.v b/theories/fp_red.v index 5f7ea0d..1e7863b 100644 --- a/theories/fp_red.v +++ b/theories/fp_red.v @@ -1788,109 +1788,133 @@ Module ERed. Qed. (* Characterization of variable freeness conditions *) - Definition tm_i_free a (i : fin n) := exists m (ξ ξ0 : fin n -> fin m), ξ i <> ξ0 i /\ ren_PTm a = ren_PTm0 a. + 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 n m i (ξ0 ξ1 : fin n -> fin m) : + 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_PTm0 j = upRen_PTm_PTm1 j). + (forall j, shift i <> j -> upRen_PTm_PTm ξ0 j = upRen_PTm_PTm ξ1 j). Proof. move => hξ. - destruct j. asimpl. - move => h. have : i<> f by hauto lq:on rew:off inv:option. + case => // j. + asimpl. + move => h. have : i<> j by hauto lq:on rew:off. move /hξ. by rewrite /funcomp => ->. - done. Qed. - Lemma tm_free_ren_any n a i : + Lemma tm_free_ren_any a i : tm_i_free a i -> - forall m (ξ0 ξ1 : fin n -> fin m), (forall j, i <> j -> ξ0 j = ξ1 j) -> - ren_PTm0 a = ren_PTm1 a. + 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 : n / a => n. + elim : a. - hauto q:on. - - move => a iha i m ρ0 ρ1 [] => h [] h' m' ξ0 ξ1 hξ /=. + - 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=>//. split; eauto. - asimpl. rewrite /funcomp. hauto l:on. + 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 m ρ0 ρ1 [] ? h m' ξ0 ξ1 hξ /=. + - 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_PTm0) (upRen_PTm_PTm1)). - apply. hauto l:on. + 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. - - hauto lq:on rew:off. - - admit. - Admitted. + - 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 n m (a : PTm) (b : PTm) (ξ : fin n -> fin m) : + 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. + 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 E : (ren_PTm ξ a) => u hu. + 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 - (ren_PTm shift (ren_PTm p)); last by asimpl. + 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 n m (a b : PTm) (ρ : fin n -> PTm) : - R a b -> R (subst_PTm a) (subst_PTm b). + Lemma substing (a b : PTm) (ρ : nat -> PTm) : + R a b -> R (subst_PTm ρ a) (subst_PTm ρ b). Proof. - move => h. move : m ρ. elim : n a b /h => n. - move => a m ρ /=. + move => h. move : ρ. elim : a b /h. + move => a ρ /=. eapply AppEta'; eauto. by asimpl. all : hauto lq:on ctrs:R. Qed. - Lemma nf_preservation n (a b : PTm) : + Lemma nf_preservation (a b : PTm) : ERed.R a b -> (nf a -> nf b) /\ (ne a -> ne b). Proof. move => h. - elim : n a b /h => //=; - hauto lqb:on use:ne_nf_ren,ne_nf. + elim : a b /h => //=; + hauto lqb:on use:ne_nf_ren,ne_nf. Qed. End ERed. @@ -1904,41 +1928,40 @@ 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) : + 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) : + 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) : + 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) 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 n (a0 a1 : PTm) : + Lemma SucCong (a0 a1 : PTm) : rtc ERed.R a0 a1 -> rtc ERed.R (PSuc a0) (PSuc a1). Proof. solve_s. Qed. - Lemma IndCong n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : + 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 -> @@ -1946,37 +1969,37 @@ Module EReds. rtc ERed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. solve_s. Qed. - Lemma renaming n m (a b : PTm) (ξ : fin n -> fin m) : - rtc ERed.R a b -> rtc ERed.R (ren_PTm a) (ren_PTm b). + 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) : + 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, IndCong, SucCong. - - 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 n (a b : PTm) : + 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 n m (a b : PTm) (ρ : fin n -> PTm) : - rtc ERed.R a b -> rtc ERed.R (subst_PTm a) (subst_PTm b). + 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 n (a0 b0 C : PTm) : + 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 /\ @@ -1986,11 +2009,12 @@ Module EReds. move : a0 b0 E. elim : u C / hu. - hauto lq:on ctrs:rtc. - - move => a b c ha ha' iha a0 b0 ?. subst. + - 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 n p (a C : PTm) : + 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. @@ -2000,7 +2024,7 @@ Module EReds. scrush ctrs:rtc,ERed.R inv:ERed.R. Qed. - Lemma bind_inv n p (A : PTm) B C : + 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. @@ -2011,7 +2035,7 @@ Module EReds. hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. Qed. - Lemma suc_inv n (a : PTm) C : + Lemma suc_inv (a : PTm) C : rtc ERed.R (PSuc a) C -> exists b, rtc ERed.R a b /\ C = PSuc b. Proof. @@ -2022,14 +2046,14 @@ Module EReds. - hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. Qed. - Lemma zero_inv n (C : PTm) : + 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 n P (a : PTm) b c C : + 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 /\ @@ -2039,7 +2063,7 @@ Module EReds. move : P a b c E. elim : u C / hu. - hauto lq:on ctrs:rtc. - - hauto lq:on rew:off ctrs:rtc, ERed.R inv:ERed.R, rtc. + - scrush ctrs:rtc, ERed.R inv:ERed.R, rtc. Qed. End EReds. @@ -2049,35 +2073,35 @@ End EReds. Module EJoin. Definition R (a b : PTm) := exists c, rtc ERed.R a c /\ rtc ERed.R b c. - Lemma hne_app_inj n (a0 b0 a1 b1 : PTm) : + 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 n p0 p1 (a0 a1 : PTm) : + 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 n p0 p1 (A0 A1 : PTm) B0 B1 : + 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 n (A0 A1 : PTm) : + 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 n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : + 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. @@ -2094,7 +2118,7 @@ Module RERed. 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 + 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) @@ -2224,8 +2248,8 @@ Module REReds. 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. @@ -2324,7 +2348,7 @@ Module REReds. move : a0 b0 E. elim : u C / hu. - hauto lq:on ctrs:rtc. - - move => a b c ha ha' iha a0 b0 ?. subst. + - move => a b c ha ha iha a0 b0 ?. subst. hauto lq:on rew:off ctrs:rtc, RERed.R use:RERed.hne_preservation inv:RERed.R. Qed. From 7f38544a1e05ca3b8ce486ac07eba559ee219403 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sun, 2 Mar 2025 22:41:15 -0500 Subject: [PATCH 04/51] Finish refactoring fp_red --- theories/fp_red.v | 441 +++++++++++++++++++++++----------------------- 1 file changed, 224 insertions(+), 217 deletions(-) diff --git a/theories/fp_red.v b/theories/fp_red.v index 1e7863b..6aa7cb6 100644 --- a/theories/fp_red.v +++ b/theories/fp_red.v @@ -12,6 +12,14 @@ Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. Require Import Btauto. Require Import Cdcl.Itauto. +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. + Ltac2 spec_refl () := List.iter (fun a => match a with @@ -2170,79 +2178,79 @@ Module RERed. R a0 a1 -> R (PSuc a0) (PSuc a1). - Lemma ToBetaEta n (a b : PTm) : + 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) : + 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) : + 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) : + 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) : + 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 n (a b : PTm) : + Lemma bind_preservation (a b : PTm) : R a b -> isbind a -> isbind b. Proof. hauto q:on inv:R. Qed. - Lemma univ_preservation n (a b : PTm) : + Lemma univ_preservation (a b : PTm) : R a b -> isuniv a -> isuniv b. Proof. hauto q:on inv:R. Qed. - Lemma nat_preservation n (a b : PTm) : + Lemma nat_preservation (a b : PTm) : R a b -> isnat a -> isnat b. Proof. hauto q:on inv:R. Qed. - Lemma sne_preservation n (a b : PTm) : + 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 n m (a b : PTm) (ρ : fin n -> PTm) : - RERed.R a b -> RERed.R (subst_PTm a) (subst_PTm b). + 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 n (a b : PTm) : + Lemma hne_preservation (a b : PTm) : RERed.R a b -> ishne a -> ishne b. Proof. induction 1; sfirstorder. Qed. End RERed. Module REReds. - Lemma hne_preservation n (a b : PTm) : + 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 n (a b : PTm) : + 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) : + 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) : + 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. @@ -2254,34 +2262,34 @@ Module REReds. #[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) : + 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) : + 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) : + 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 SucCong n (a0 a1 : PTm) : + Lemma SucCong (a0 a1 : PTm) : rtc RERed.R a0 a1 -> rtc RERed.R (PSuc a0) (PSuc a1). Proof. solve_s. Qed. - Lemma IndCong n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : + 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 -> @@ -2289,30 +2297,30 @@ Module REReds. rtc RERed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. solve_s. Qed. - Lemma BindCong n p (A0 A1 : PTm) B0 B1 : + 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 n (a b : PTm) : + 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 n (a b : PTm) : + 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 n (a b : PTm) : + 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 n (a b : PTm) : + 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 n p A B C : - rtc (@RERed.R n) (PBind p A B) C -> + 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. @@ -2320,8 +2328,8 @@ Module REReds. elim : u C / hu; sauto lq:on rew:off. Qed. - Lemma univ_inv n i C : - rtc (@RERed.R n) (PUniv i) C -> + Lemma univ_inv i C : + rtc RERed.R (PUniv i) C -> C = PUniv i. Proof. move E : (PUniv i) => u hu. @@ -2329,7 +2337,7 @@ Module REReds. hauto lq:on rew:off ctrs:rtc inv:RERed.R. Qed. - Lemma var_inv n (i : fin n) C : + Lemma var_inv (i : nat) C : rtc RERed.R (VarPTm i) C -> C = VarPTm i. Proof. @@ -2337,7 +2345,7 @@ Module REReds. move : i E. elim : u C /hu; hauto lq:on rew:off inv:RERed.R. Qed. - Lemma hne_app_inv n (a0 b0 C : PTm) : + Lemma hne_app_inv (a0 b0 C : PTm) : rtc RERed.R (PApp a0 b0) C -> ishne a0 -> exists a1 b1, C = PApp a1 b1 /\ @@ -2348,11 +2356,11 @@ Module REReds. move : a0 b0 E. elim : u C / hu. - hauto lq:on ctrs:rtc. - - move => a b c ha ha iha a0 b0 ?. subst. + - 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 n p (a C : PTm) : + 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. @@ -2363,7 +2371,7 @@ Module REReds. scrush ctrs:rtc,RERed.R use:RERed.hne_preservation inv:RERed.R. Qed. - Lemma hne_ind_inv n P a b c (C : PTm) : + 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 /\ @@ -2377,47 +2385,47 @@ Module REReds. scrush ctrs:rtc,RERed.R use:RERed.hne_preservation inv:RERed.R. Qed. - Lemma substing n m (a b : PTm) (ρ : fin n -> PTm) : - rtc RERed.R a b -> rtc RERed.R (subst_PTm a) (subst_PTm b). + 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 n m (ρ0 ρ1 : fin n -> PTm) : + Lemma cong_up (ρ0 ρ1 : nat -> PTm) : (forall i, rtc RERed.R (ρ0 i) (ρ1 i)) -> - (forall i, rtc RERed.R (up_PTm_PTm0 i) (up_PTm_PTm1 i)). - Proof. move => h i. destruct i as [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 n m (ρ0 ρ1 : fin n -> PTm) : + 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_PTm0) i) (up_PTm_PTm (up_PTm_PTm1) 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 n m (a : PTm) (ρ0 ρ1 : fin n -> PTm) : + Lemma cong (a : PTm) (ρ0 ρ1 : nat -> PTm) : (forall i, rtc RERed.R (ρ0 i) (ρ1 i)) -> - rtc RERed.R (subst_PTm0 a) (subst_PTm1 a). + rtc RERed.R (subst_PTm ρ0 a) (subst_PTm ρ1 a). Proof. - move : m ρ0 ρ1. elim : n / a => /=; + move : ρ0 ρ1. elim : a => /=; eauto 20 using AppCong, AbsCong, BindCong, ProjCong, PairCong, cong_up, rtc_refl, IndCong, SucCong, cong_up2. Qed. - Lemma cong' n m (a b : PTm) (ρ0 ρ1 : fin n -> PTm) : + 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_PTm0 a) (subst_PTm1 b). + rtc RERed.R (subst_PTm ρ0 a) (subst_PTm ρ1 b). Proof. move => h0 h1. - have : rtc RERed.R (subst_PTm0 a) (subst_PTm1 a) by eauto using cong. + 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 n (a b : PTm) : + Lemma ToEReds (a b : PTm) : nf a -> rtc RERed.R a b -> rtc ERed.R a b. Proof. @@ -2425,14 +2433,14 @@ Module REReds. induction h; hauto lq:on rew:off ctrs:rtc use:RERed.ToBetaEta, RReds.nf_refl, @rtc_once, ERed.nf_preservation. Qed. - Lemma zero_inv n (C : PTm) : + 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 n (a : PTm) C : + Lemma suc_inv (a : PTm) C : rtc RERed.R (PSuc a) C -> exists b, rtc RERed.R a b /\ C = PSuc b. Proof. @@ -2443,8 +2451,8 @@ Module REReds. - hauto lq:on rew:off ctrs:rtc, RERed.R inv:RERed.R, rtc. Qed. - Lemma nat_inv n C : - rtc RERed.R (@PNat n) C -> + Lemma nat_inv C : + rtc RERed.R PNat C -> C = PNat. Proof. move E : PNat => u hu. move : E. @@ -2523,36 +2531,36 @@ Module LoRed. R a0 a1 -> R (PSuc a0) (PSuc a1). - Lemma hf_preservation n (a b : PTm) : + 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) : + 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' n a (b : PTm) u : + 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' n P a b c u : + Lemma IndSuc' P a b c u : u = (subst_PTm (scons (PInd P a b c) (scons a VarPTm)) c) -> - R (@PInd n P (PSuc a) b c) u. + R (@PInd P (PSuc a) b c) u. Proof. move => ->. apply IndSuc. Qed. - Lemma renaming n m (a b : PTm) (ξ : fin n -> fin m) : - R a b -> R (ren_PTm a) (ren_PTm b). + 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 ξ /=. + move => a b ξ /=. apply AppAbs'. by asimpl. all : try qauto ctrs:R use:ne_nf_ren, ishf_ren. move => * /=; apply IndSuc'. by asimpl. @@ -2561,7 +2569,7 @@ Module LoRed. End LoRed. Module LoReds. - Lemma hf_preservation n (a b : PTm) : + Lemma hf_preservation (a b : PTm) : rtc LoRed.R a b -> ishf a -> ishf b. @@ -2569,7 +2577,7 @@ Module LoReds. induction 1; eauto using LoRed.hf_preservation. Qed. - Lemma hf_ne_imp n (a b : PTm) : + Lemma hf_ne_imp (a b : PTm) : rtc LoRed.R a b -> ne b -> ~~ ishf a. @@ -2585,39 +2593,39 @@ 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) : + 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) : + 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) : + 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) 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. - Lemma IndCong n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : + 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 -> @@ -2628,14 +2636,14 @@ Module LoReds. rtc LoRed.R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. solve_s. Qed. - Lemma SucCong n (a0 a1 : PTm) : + 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 *; itauto. - Lemma FromSN_mutual : forall n, + 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). @@ -2644,7 +2652,6 @@ Module LoReds. - 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. @@ -2656,73 +2663,71 @@ Module LoReds. - 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 => n P a0 a1 b c hP ihP hb ihb hc ihc hr. + - 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), 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 (a : PTm) := match a with | VarPTm _ => 1 - | PAbs a => 3 + size_PTm - | PApp a b => 1 + Nat.add (size_PTm) (size_PTm) - | PProj p a => 1 + size_PTm - | PPair a b => 3 + Nat.add (size_PTm) (size_PTm) + | PAbs a => 3 + size_PTm a + | PApp a b => 1 + Nat.add (size_PTm a) (size_PTm b) + | PProj p a => 1 + size_PTm a + | PPair a b => 3 + Nat.add (size_PTm a) (size_PTm b) | PUniv _ => 3 - | PBind p A B => 3 + Nat.add (size_PTm) (size_PTm) - | PInd P a b c => 3 + size_PTm + size_PTm + size_PTm + size_PTm + | PBind p A B => 3 + Nat.add (size_PTm A) (size_PTm B) + | PInd P a b c => 3 + size_PTm P + size_PTm a + size_PTm b + size_PTm c | PNat => 3 - | PSuc a => 3 + size_PTm + | PSuc a => 3 + size_PTm a | PZero => 3 - | PBot => 1 end. -Lemma size_PTm_ren n m (ξ : fin n -> fin m) a : size_PTm (ren_PTm a) = size_PTm. +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 (a b : PTm) : ERed.R a b -> - size_PTm < size_PTm. + 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) : 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) : +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. @@ -2822,7 +2827,7 @@ Proof. - qauto l:on inv:ERed.R ctrs:rtc use:EReds.SucCong. Qed. -Lemma ered_confluence n (a b c : PTm) : +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. @@ -2830,7 +2835,7 @@ Proof. sfirstorder use:relations.locally_confluent_confluent, ered_sn, ered_local_confluence. Qed. -Lemma red_confluence n (a b c : PTm) : +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. @@ -2841,7 +2846,7 @@ Lemma red_confluence n (a b c : PTm) : eauto using RPar.diamond. Qed. -Lemma red_uniquenf n (a b c : PTm) : +Lemma red_uniquenf (a b c : PTm) : rtc RRed.R a b -> rtc RRed.R a c -> nf b -> @@ -2856,20 +2861,20 @@ Proof. Qed. Module NeEPars. - Lemma R_nonelim_nf n (a b : PTm) : + 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), 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) : +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. @@ -2886,7 +2891,7 @@ Proof. - hauto lq:on ctrs:rtc use:red_sn_preservation, RPar.FromRRed. Qed. -Lemma rered_confluence n (a b c : PTm) : +Lemma rered_confluence (a b c : PTm) : SN a -> rtc RERed.R a b -> rtc RERed.R a c -> @@ -2921,13 +2926,13 @@ Qed. (* Beta joinability *) Module BJoin. Definition R (a b : PTm) := exists c, rtc RRed.R a c /\ rtc RRed.R b c. - Lemma refl n (a : PTm) : R a a. + Lemma refl (a : PTm) : R a a. Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma symmetric n (a b : PTm) : 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) : 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]]. @@ -2951,19 +2956,19 @@ End BJoin. Module DJoin. Definition R (a b : PTm) := exists c, rtc RERed.R a c /\ rtc RERed.R b c. - Lemma refl n (a : PTm) : R a a. + Lemma refl (a : PTm) : R a a. Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma FromEJoin n (a b : PTm) : EJoin.R a b -> DJoin.R a b. + Lemma FromEJoin (a b : PTm) : EJoin.R a b -> DJoin.R a b. Proof. hauto q:on use:REReds.FromEReds. Qed. - Lemma ToEJoin n (a b : PTm) : nf a -> nf b -> DJoin.R a b -> EJoin.R a b. + 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 n (a b : PTm) : 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) : SN b -> R a b -> R b c -> R a c. + 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]]. @@ -2972,35 +2977,35 @@ 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) : + 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) : + 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) : + 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 n p (A0 A1 : PTm) B0 B1 : + 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 n P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : + Lemma IndCong P0 P1 (a0 a1 : PTm) b0 b1 c0 c1 : R P0 P1 -> R a0 a1 -> R b0 b1 -> @@ -3008,12 +3013,12 @@ Module DJoin. R (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1). Proof. hauto q:on use:REReds.IndCong. Qed. - Lemma SucCong n (a0 a1 : PTm) : + Lemma SucCong (a0 a1 : PTm) : R a0 a1 -> R (PSuc a0) (PSuc a1). Proof. qauto l:on use:REReds.SucCong. Qed. - Lemma FromRedSNs n (a b : PTm) : + Lemma FromRedSNs (a b : PTm) : rtc TRedSN a b -> R a b. Proof. @@ -3021,7 +3026,7 @@ Module DJoin. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma sne_nat_noconf n (a b : PTm) : + Lemma sne_nat_noconf (a b : PTm) : R a b -> SNe a -> isnat b -> False. Proof. move => [c [? ?]] *. @@ -3029,7 +3034,7 @@ Module DJoin. qauto l:on inv:SNe. Qed. - Lemma sne_bind_noconf n (a b : PTm) : + Lemma sne_bind_noconf (a b : PTm) : R a b -> SNe a -> isbind b -> False. Proof. move => [c [? ?]] *. @@ -3037,14 +3042,14 @@ Module DJoin. qauto l:on inv:SNe. Qed. - Lemma sne_univ_noconf n (a b : PTm) : + 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 n (a b : PTm) : + Lemma bind_univ_noconf (a b : PTm) : R a b -> isbind a -> isuniv b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3054,7 +3059,7 @@ Module DJoin. case : c => //=; itauto. Qed. - Lemma hne_univ_noconf n (a b : PTm) : + Lemma hne_univ_noconf (a b : PTm) : R a b -> ishne a -> isuniv b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3065,7 +3070,7 @@ Module DJoin. case : c => //=. Qed. - Lemma hne_bind_noconf n (a b : PTm) : + Lemma hne_bind_noconf (a b : PTm) : R a b -> ishne a -> isbind b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3076,7 +3081,7 @@ Module DJoin. case : c => //=. Qed. - Lemma hne_nat_noconf n (a b : PTm) : + Lemma hne_nat_noconf (a b : PTm) : R a b -> ishne a -> isnat b -> False. Proof. move => [c [h0 h1]] h2 h3. @@ -3084,7 +3089,7 @@ Module DJoin. clear. case : c => //=; itauto. Qed. - Lemma bind_inj n p0 p1 (A0 A1 : PTm) B0 B1 : + 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. @@ -3092,24 +3097,24 @@ Module DJoin. hauto lq:on rew:off use:REReds.bind_inv. Qed. - Lemma var_inj n (i j : fin n) : + 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 n i j : - @R n (PUniv i) (PUniv j) -> i = j. + 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 n (A0 A1 : PTm) : + 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 n (a0 b0 a1 b1 : PTm) : + Lemma hne_app_inj (a0 b0 a1 b1 : PTm) : R (PApp a0 b0) (PApp a1 b1) -> ishne a0 -> ishne a1 -> @@ -3118,7 +3123,7 @@ Module DJoin. hauto lq:on use:REReds.hne_app_inv. Qed. - Lemma hne_proj_inj n p0 p1 (a0 a1 : PTm) : + Lemma hne_proj_inj p0 p1 (a0 a1 : PTm) : R (PProj p0 a0) (PProj p1 a1) -> ishne a0 -> ishne a1 -> @@ -3127,62 +3132,62 @@ Module DJoin. sauto lq:on use:REReds.hne_proj_inv. Qed. - Lemma FromRRed0 n (a b : PTm) : + 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 n (a b : PTm) : + 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 n (a b : PTm) : + 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 n (a b : PTm) : + Lemma FromBJoin (a b : PTm) : BJoin.R a b -> R a b. Proof. - hauto lq:on ctrs:rtc use:REReds.FromRReds unfold:R. + hauto lq:on ctrs:rtc use:REReds.FromRReds unfold:R, BJoin.R. Qed. - Lemma substing n m (a b : PTm) (ρ : fin n -> PTm) : - R a b -> R (subst_PTm a) (subst_PTm b). + 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 n m (a b : PTm) (ρ : fin n -> fin m) : - R a b -> R (ren_PTm a) (ren_PTm b). + Lemma renaming (a b : PTm) (ρ : nat -> nat) : + R a b -> R (ren_PTm ρ a) (ren_PTm ρ b). Proof. substify. apply substing. Qed. - Lemma weakening n (a b : PTm) : + Lemma weakening (a b : PTm) : R a b -> R (ren_PTm shift a) (ren_PTm shift b). Proof. apply renaming. Qed. - Lemma cong n m (a : PTm (S n)) c d (ρ : fin n -> PTm) : + 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:option use:REReds.cong. + hauto q:on ctrs:rtc inv:nat use:REReds.cong. Qed. - Lemma cong' n m (a b : PTm (S n)) c d (ρ : fin n -> PTm) : + 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:option use:REReds.cong'. + hauto q:on ctrs:rtc inv:nat use:REReds.cong'. Qed. - Lemma pair_inj n (a0 a1 b0 b1 : PTm) : + Lemma pair_inj (a0 a1 b0 b1 : PTm) : SN (PPair a0 b0) -> SN (PPair a1 b1) -> R (PPair a0 b0) (PPair a1 b1) -> @@ -3209,7 +3214,7 @@ Module DJoin. split; eauto using transitive. Qed. - Lemma ejoin_pair_inj n (a0 a1 b0 b1 : PTm) : + 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. @@ -3221,7 +3226,7 @@ Module DJoin. hauto l:on use:ToEJoin. Qed. - Lemma abs_inj n (a0 a1 : PTm (S n)) : + Lemma abs_inj (a0 a1 : PTm) : SN a0 -> SN a1 -> R (PAbs a0) (PAbs a1) -> R a0 a1. @@ -3231,22 +3236,23 @@ Module DJoin. 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 by apply RRed.AppAbs'; asimpl. - have /FromRRed0 h1 : RRed.R (PApp (PAbs (ren_PTm (upRen_PTm_PTm shift) a1)) (VarPTm var_zero)) a1 by apply RRed.AppAbs'; asimpl. + 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. - by asimpl. + asimpl. by rewrite subst_scons_id. apply : transitive; try apply h1. apply : N_Exp. apply N_β. sauto. - by asimpl. + by asimpl; rewrite subst_scons_id. eauto. Qed. - Lemma ejoin_abs_inj n (a0 a1 : PTm (S n)) : + Lemma ejoin_abs_inj (a0 a1 : PTm) : nf a0 -> nf a1 -> EJoin.R (PAbs a0) (PAbs a1) -> EJoin.R a0 a1. @@ -3258,13 +3264,13 @@ Module DJoin. hauto l:on use:ToEJoin. Qed. - Lemma standardization n (a b : PTm) : + 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 hauto q:on use:LoReds.FromSN, LoReds.ToRReds. + 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. @@ -3278,7 +3284,7 @@ Module DJoin. hauto q:on use:NeEPars.ToEReds unfold:EJoin.R. Qed. - Lemma standardization_lo n (a b : PTm) : + 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. @@ -3311,21 +3317,21 @@ Module Sub1. R B0 B1 -> R (PBind PSig A0 B0) (PBind PSig A1 B1). - Lemma transitive0 n (A B C : PTm) : + 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 : n A B /h; hauto lq:on ctrs:R inv:R solve+:lia. + elim : A B /h; hauto lq:on ctrs:R inv:R solve+:lia. Qed. - Lemma transitive n (A B C : PTm) : + Lemma transitive (A B C : PTm) : R A B -> R B C -> R A C. Proof. hauto q:on use:transitive0. Qed. - Lemma refl n (A : PTm) : R A A. + Lemma refl (A : PTm) : R A A. Proof. sfirstorder. Qed. - Lemma commutativity0 n (A B C : PTm) : + Lemma commutativity0 (A B C : PTm) : R A B -> (RERed.R A C -> exists D, RERed.R B D /\ R C D) /\ @@ -3333,26 +3339,27 @@ Module Sub1. exists D, RERed.R A D /\ R D C). Proof. move => h. move : C. - elim : n A B / h; hauto lq:on ctrs:RERed.R, R inv:RERed.R. + elim : A B / h; hauto lq:on ctrs:RERed.R, R inv:RERed.R. Qed. - Lemma commutativity_Ls n (A B C : PTm) : + 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; sauto lq:on use:commutativity0. + move => + h. move : B. + induction h; ecrush use:commutativity0. Qed. - Lemma commutativity_Rs n (A B C : PTm) : + 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; sauto lq:on use:commutativity0. + move => + h. move : A. induction h; ecrush use:commutativity0. Qed. - Lemma sn_preservation : forall n, + 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). @@ -3360,30 +3367,30 @@ Module Sub1. apply sn_mutual; hauto lq:on inv:R ctrs:SN. Qed. - Lemma bind_preservation n (a b : PTm) : + Lemma bind_preservation (a b : PTm) : R a b -> isbind a = isbind b. Proof. hauto q:on inv:R. Qed. - Lemma univ_preservation n (a b : PTm) : + Lemma univ_preservation (a b : PTm) : R a b -> isuniv a = isuniv b. Proof. hauto q:on inv:R. Qed. - Lemma sne_preservation n (a b : PTm) : + Lemma sne_preservation (a b : PTm) : R a b -> SNe a <-> SNe b. Proof. hfcrush use:sn_preservation. Qed. - Lemma renaming n m (a b : PTm) (ξ : fin n -> fin m) : - R a b -> R (ren_PTm a) (ren_PTm b). + 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; hauto lq:on ctrs:R. + move => h. move : ξ. + elim : a b /h; hauto lq:on ctrs:R. Qed. - Lemma substing n m (a b : PTm) (ρ : fin n -> PTm) : - R a b -> R (subst_PTm a) (subst_PTm b). - Proof. move => h. move : m ρ. elim : n 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 n (a b : PTm) : + Lemma hne_refl (a b : PTm) : ishne a \/ ishne b -> R a b -> a = b. Proof. hauto q:on inv:R. Qed. @@ -3392,7 +3399,7 @@ 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 n (A0 A1 : PTm) B0 B1 : + Lemma pi_inj (A0 A1 : PTm) B0 B1 : R (PBind PPi A0 B0) (PBind PPi A1 B1) -> R A1 A0 /\ R B0 B1. Proof. @@ -3402,7 +3409,7 @@ Module ESub. sauto lq:on rew:off inv:Sub1.R. Qed. - Lemma sig_inj n (A0 A1 : PTm) B0 B1 : + Lemma sig_inj (A0 A1 : PTm) B0 B1 : R (PBind PSig A0 B0) (PBind PSig A1 B1) -> R A0 A1 /\ R B0 B1. Proof. @@ -3412,7 +3419,7 @@ Module ESub. sauto lq:on rew:off inv:Sub1.R. Qed. - Lemma suc_inj n (a b : PTm) : + Lemma suc_inj (a b : PTm) : R (PSuc a) (PSuc b) -> R a b. Proof. @@ -3424,10 +3431,10 @@ 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 n (a : PTm) : R a a. + Lemma refl (a : PTm) : R a a. Proof. sfirstorder use:@rtc_refl unfold:R. Qed. - Lemma ToJoin n (a b : PTm) : + Lemma ToJoin (a b : PTm) : ishne a \/ ishne b -> R a b -> DJoin.R a b. @@ -3437,7 +3444,7 @@ Module Sub. hauto lq:on rew:off use:Sub1.hne_refl. Qed. - Lemma transitive n (a b c : PTm) : SN b -> R a b -> R b c -> R a c. + 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. @@ -3449,10 +3456,10 @@ Module Sub. exists a',c'; hauto l:on use:Sub1.transitive, @relations.rtc_transitive. Qed. - Lemma FromJoin n (a b : PTm) : DJoin.R a b -> R a b. + Lemma FromJoin (a b : PTm) : DJoin.R a b -> R a b. Proof. sfirstorder. Qed. - Lemma PiCong n (A0 A1 : PTm) B0 B1 : + Lemma PiCong (A0 A1 : PTm) B0 B1 : R A1 A0 -> R B0 B1 -> R (PBind PPi A0 B0) (PBind PPi A1 B1). @@ -3464,7 +3471,7 @@ Module Sub. repeat split; eauto using REReds.BindCong, Sub1.PiCong. Qed. - Lemma SigCong n (A0 A1 : PTm) B0 B1 : + Lemma SigCong (A0 A1 : PTm) B0 B1 : R A0 A1 -> R B0 B1 -> R (PBind PSig A0 B0) (PBind PSig A1 B1). @@ -3476,12 +3483,12 @@ Module Sub. repeat split; eauto using REReds.BindCong, Sub1.SigCong. Qed. - Lemma UnivCong n i j : + Lemma UnivCong i j : i <= j -> - @R n (PUniv i) (PUniv j). + @R (PUniv i) (PUniv j). Proof. hauto lq:on ctrs:Sub1.R, rtc. Qed. - Lemma sne_nat_noconf n (a b : PTm) : + Lemma sne_nat_noconf (a b : PTm) : R a b -> SNe a -> isnat b -> False. Proof. move => [c [d [h0 [h1 h2]]]] *. @@ -3489,7 +3496,7 @@ Module Sub. move : h2. clear. hauto q:on inv:Sub1.R, SNe. Qed. - Lemma nat_sne_noconf n (a b : PTm) : + Lemma nat_sne_noconf (a b : PTm) : R a b -> isnat a -> SNe b -> False. Proof. move => [c [d [h0 [h1 h2]]]] *. @@ -3497,7 +3504,7 @@ Module Sub. move : h2. clear. hauto q:on inv:Sub1.R, SNe. Qed. - Lemma sne_bind_noconf n (a b : PTm) : + Lemma sne_bind_noconf (a b : PTm) : R a b -> SNe a -> isbind b -> False. Proof. rewrite /R. @@ -3507,7 +3514,7 @@ Module Sub. qauto l:on inv:SNe. Qed. - Lemma hne_bind_noconf n (a b : PTm) : + Lemma hne_bind_noconf (a b : PTm) : R a b -> ishne a -> isbind b -> False. Proof. rewrite /R. @@ -3518,7 +3525,7 @@ Module Sub. clear. case : d => //=. Qed. - Lemma bind_sne_noconf n (a b : PTm) : + Lemma bind_sne_noconf (a b : PTm) : R a b -> SNe b -> isbind a -> False. Proof. rewrite /R. @@ -3528,14 +3535,14 @@ Module Sub. qauto l:on inv:SNe. Qed. - Lemma sne_univ_noconf n (a b : PTm) : + 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 n (a b : PTm) : + Lemma univ_sne_noconf (a b : PTm) : R a b -> SNe b -> isuniv a -> False. Proof. move => [c[d] [? []]] *. @@ -3545,7 +3552,7 @@ Module Sub. clear. case : c => //=. inversion 2. Qed. - Lemma univ_nat_noconf n (a b : PTm) : + Lemma univ_nat_noconf (a b : PTm) : R a b -> isuniv b -> isnat a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3555,7 +3562,7 @@ Module Sub. clear. case : d => //=. Qed. - Lemma nat_univ_noconf n (a b : PTm) : + Lemma nat_univ_noconf (a b : PTm) : R a b -> isnat b -> isuniv a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3565,7 +3572,7 @@ Module Sub. clear. case : d => //=. Qed. - Lemma bind_nat_noconf n (a b : PTm) : + Lemma bind_nat_noconf (a b : PTm) : R a b -> isbind b -> isnat a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3576,7 +3583,7 @@ Module Sub. case : d h1 => //=. Qed. - Lemma nat_bind_noconf n (a b : PTm) : + Lemma nat_bind_noconf (a b : PTm) : R a b -> isnat b -> isbind a -> False. Proof. move => [c[d] [? []]] h0 h1 h2 h3. @@ -3587,7 +3594,7 @@ Module Sub. case : d h1 => //=. Qed. - Lemma bind_univ_noconf n (a b : PTm) : + Lemma bind_univ_noconf (a b : PTm) : R a b -> isbind a -> isuniv b -> False. Proof. move => [c[d] [h0 [h1 h1']]] h2 h3. @@ -3598,7 +3605,7 @@ Module Sub. case : c => //=; itauto. Qed. - Lemma univ_bind_noconf n (a b : PTm) : + Lemma univ_bind_noconf (a b : PTm) : R a b -> isbind b -> isuniv a -> False. Proof. move => [c[d] [h0 [h1 h1']]] h2 h3. @@ -3609,7 +3616,7 @@ Module Sub. case : c => //=; itauto. Qed. - Lemma bind_inj n p0 p1 (A0 A1 : PTm) B0 B1 : + 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. @@ -3620,13 +3627,13 @@ Module Sub. inversion h; subst; sauto lq:on. Qed. - Lemma univ_inj n i j : - @R n (PUniv i) (PUniv j) -> i <= j. + 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 n (A0 A1 : PTm) : + Lemma suc_inj (A0 A1 : PTm) : R (PSuc A0) (PSuc A1) -> R A0 A1. Proof. @@ -3634,7 +3641,7 @@ Module Sub. Qed. - Lemma cong n m (a b : PTm (S n)) c d (ρ : fin n -> PTm) : + 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. @@ -3642,23 +3649,23 @@ Module Sub. move => [cd][h3]h4. exists (subst_PTm (scons cd ρ) a0), (subst_PTm (scons cd ρ) b0). repeat split. - hauto l:on use:REReds.cong' inv:option. - hauto l:on use:REReds.cong' inv:option. + hauto l:on use:REReds.cong' inv:nat. + hauto l:on use:REReds.cong' inv:nat. eauto using Sub1.substing. Qed. - Lemma substing n m (a b : PTm) (ρ : fin n -> PTm) : - R a b -> R (subst_PTm a) (subst_PTm b). + 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 n (a b : PTm) : nf a -> nf b -> R a b -> ESub.R a b. + 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 n (a b : PTm) : + 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. @@ -3676,7 +3683,7 @@ Module Sub. hauto lq:on. Qed. - Lemma standardization_lo n (a b : PTm) : + 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. From 47e21df801b8e43967ab4becf7e7aad1258ceaf0 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 01:15:21 -0500 Subject: [PATCH 05/51] Finish refactoring logical relations --- theories/common.v | 2 + theories/logrel.v | 692 +++++++++++++++++++++------------------------- 2 files changed, 318 insertions(+), 376 deletions(-) diff --git a/theories/common.v b/theories/common.v index 79b0b19..a890edd 100644 --- a/theories/common.v +++ b/theories/common.v @@ -10,6 +10,8 @@ Inductive lookup : nat -> list PTm -> PTm -> Prop := lookup i Γ A -> lookup (S i) (cons B Γ) (ren_PTm shift A). +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). diff --git a/theories/logrel.v b/theories/logrel.v index a245362..a113437 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -1,4 +1,4 @@ -Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax. +Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax. Require Import common fp_red. From Hammer Require Import Tactics. From Equations Require Import Equations. @@ -8,19 +8,19 @@ From stdpp Require Import relations (rtc(..), rtc_subrel). Import Psatz. Require Import Cdcl.Itauto. -Definition ProdSpace {n} (PA : PTm n -> Prop) - (PF : PTm n -> (PTm n -> Prop) -> Prop) b : Prop := +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 {n} (PA : PTm n -> Prop) - (PF : PTm n -> (PTm n -> Prop) -> Prop) t : Prop := +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 {n} p := if p is PPi then @ProdSpace n else SumSpace. +Definition BindSpace p := if p is PPi then ProdSpace else SumSpace. Reserved Notation "⟦ A ⟧ i ;; I ↘ S" (at level 70). -Inductive InterpExt {n} i (I : nat -> PTm n -> Prop) : PTm n -> (PTm n -> Prop) -> Prop := +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) @@ -44,7 +44,7 @@ Inductive InterpExt {n} i (I : nat -> PTm n -> Prop) : PTm n -> (PTm n -> Prop) ⟦ A ⟧ i ;; I ↘ PA where "⟦ A ⟧ i ;; I ↘ S" := (InterpExt i I A S). -Lemma InterpExt_Univ' n i I j (PF : PTm n -> Prop) : +Lemma InterpExt_Univ' i I j (PF : PTm -> Prop) : PF = I j -> j < i -> ⟦ PUniv j ⟧ i ;; I ↘ PF. @@ -52,16 +52,15 @@ Proof. hauto lq:on ctrs:InterpExt. Qed. Infix " (PTm n -> Prop) -> Prop by wf i lt := - InterpUnivN n i := @InterpExt n i +Equations InterpUnivN (i : nat) : PTm -> (PTm -> Prop) -> Prop by wf i lt := + InterpUnivN i := @InterpExt i (fun j A => match j exists PA, InterpUnivN n j A PA + | left _ => exists PA, InterpUnivN j A PA | right _ => False end). -Arguments InterpUnivN {n}. -Lemma InterpExt_lt_impl n i I I' A (PA : PTm n -> Prop) : +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. @@ -75,7 +74,7 @@ Proof. - hauto lq:on ctrs:InterpExt. Qed. -Lemma InterpExt_lt_eq n i I I' A (PA : PTm n -> Prop) : +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. @@ -87,8 +86,8 @@ Qed. Notation "⟦ A ⟧ i ↘ S" := (InterpUnivN i A S) (at level 70). -Lemma InterpUnivN_nolt n i : - @InterpUnivN n i = @InterpExt n i (fun j (A : PTm n) => exists PA, ⟦ A ⟧ j ↘ PA). +Lemma InterpUnivN_nolt i : + @InterpUnivN i = @InterpExt i (fun j (A : PTm ) => exists PA, ⟦ A ⟧ j ↘ PA). Proof. simp InterpUnivN. extensionality A. extensionality PA. @@ -98,64 +97,62 @@ Qed. #[export]Hint Rewrite @InterpUnivN_nolt : InterpUniv. -Check InterpExt_ind. - Lemma InterpUniv_ind - : forall n (P : nat -> PTm n -> (PTm n -> Prop) -> Prop), - (forall i (A : PTm n), SNe A -> P i A (fun a : PTm n => exists v : PTm n, rtc TRedSN a v /\ SNe v)) -> - (forall i (p : BTag) (A : PTm n) (B : PTm (S n)) (PA : PTm n -> Prop) - (PF : PTm n -> (PTm n -> Prop) -> Prop), + : 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 n, PA a -> exists PB : PTm n -> Prop, PF a PB) -> - (forall (a : PTm n) (PB : PTm n -> Prop), PF a PB -> ⟦ subst_PTm (scons a VarPTm) B ⟧ i ↘ PB) -> - (forall (a : PTm n) (PB : PTm n -> Prop), PF a PB -> P i (subst_PTm (scons a VarPTm) B) PB) -> + (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 n) (PA : PTm n -> Prop), TRedSN A A0 -> ⟦ A0 ⟧ i ↘ PA -> P i A0 PA -> P i A PA) -> - forall i (p : PTm n) (P0 : PTm n -> Prop), ⟦ p ⟧ i ↘ P0 -> P i p P0. + (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 => n P hSN hBind hNat hUniv hRed. + 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 n i I (A : PTm n) PA, InterpExt i I A PA) Sort Prop. +Derive Dependent Inversion iinv with (forall i I (A : PTm ) PA, InterpExt i I A PA) Sort Prop. -Lemma InterpUniv_Ne n i (A : PTm n) : +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 n i p A B PA PF : - ⟦ A : PTm n ⟧ i ↘ PA -> +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 n i j : - j < i -> ⟦ PUniv j : PTm n ⟧ i ↘ (fun A => exists PA, ⟦ A ⟧ j ↘ PA). +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 n A A0 PA : +Lemma InterpUniv_Step i A A0 PA : TRedSN A A0 -> - ⟦ A0 : PTm n ⟧ i ↘ PA -> + ⟦ A0 ⟧ i ↘ PA -> ⟦ A ⟧ i ↘ PA. Proof. simp InterpUniv. apply InterpExt_Step. Qed. -Lemma InterpUniv_Nat i n : - ⟦ PNat : PTm n ⟧ i ↘ SNat. +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 n i j I (A : PTm n) PA : +Lemma InterpExt_cumulative i j I (A : PTm ) PA : i <= j -> ⟦ A ⟧ i ;; I ↘ PA -> ⟦ A ⟧ j ;; I ↘ PA. @@ -165,18 +162,18 @@ Proof. hauto l:on ctrs:InterpExt solve+:(by lia). Qed. -Lemma InterpUniv_cumulative n i (A : PTm n) PA : +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 {n} (P : PTm n -> Prop) := +Definition CR (P : PTm -> Prop) := (forall a, P a -> SN a) /\ (forall a, SNe a -> P a). -Lemma N_Exps n (a b : PTm n) : +Lemma N_Exps (a b : PTm) : rtc TRedSN a b -> SN b -> SN a. @@ -184,21 +181,22 @@ Proof. induction 1; eauto using N_Exp. Qed. -Lemma CR_SNat : forall n, @CR n SNat. +Lemma CR_SNat : CR SNat. Proof. - move => n. rewrite /CR. + rewrite /CR. split. induction 1; hauto q:on ctrs:SN,SNe. hauto lq:on ctrs:SNat. Qed. -Lemma adequacy : forall i n A PA, - ⟦ A : PTm n ⟧ i ↘ PA -> +Lemma adequacy : forall i A PA, + ⟦ A ⟧ i ↘ PA -> CR PA /\ SN A. Proof. - move => + n. apply : InterpUniv_ind. + 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. @@ -218,18 +216,18 @@ Proof. apply : N_Exp; eauto using N_β. hauto lq:on. qauto l:on use:SN_AppInv, SN_NoForbid.P_AbsInv. - - qauto use:CR_SNat. + - sfirstorder use:CR_SNat. - hauto l:on ctrs:InterpExt rew:db:InterpUniv. - hauto l:on ctrs:SN unfold:CR. Qed. -Lemma InterpUniv_Steps i n A A0 PA : +Lemma InterpUniv_Steps i A A0 PA : rtc TRedSN A A0 -> - ⟦ A0 : PTm n ⟧ i ↘ PA -> + ⟦ A0 ⟧ i ↘ PA -> ⟦ A ⟧ i ↘ PA. Proof. induction 1; hauto l:on use:InterpUniv_Step. Qed. -Lemma InterpUniv_back_clos n i (A : PTm n) PA : +Lemma InterpUniv_back_clos i (A : PTm ) PA : ⟦ A ⟧ i ↘ PA -> forall a b, TRedSN a b -> PA b -> PA a. @@ -248,7 +246,7 @@ Proof. - hauto l:on use:InterpUniv_Step. Qed. -Lemma InterpUniv_back_closs n i (A : PTm n) PA : +Lemma InterpUniv_back_closs i (A : PTm) PA : ⟦ A ⟧ i ↘ PA -> forall a b, rtc TRedSN a b -> PA b -> PA a. @@ -256,7 +254,7 @@ Proof. induction 2; hauto lq:on ctrs:rtc use:InterpUniv_back_clos. Qed. -Lemma InterpUniv_case n i (A : PTm n) PA : +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. @@ -268,21 +266,21 @@ Proof. hauto lq:on ctrs:rtc. Qed. -Lemma redsn_preservation_mutual n : - (forall (a : PTm n) (s : SNe a), forall b, TRedSN a b -> False) /\ - (forall (a : PTm n) (s : SN a), forall b, TRedSN a b -> SN b) /\ - (forall (a b : PTm n) (_ : TRedSN a b), forall c, TRedSN a c -> b = c). +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. - move : n. apply sn_mutual; sauto lq:on rew:off. + apply sn_mutual; sauto lq:on rew:off. Qed. -Lemma redsns_preservation : forall n a b, @SN n a -> rtc TRedSN a b -> SN b. +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 n i (A : PTm n) PA : +Lemma InterpUniv_SNe_inv i (A : PTm) PA : SNe A -> ⟦ A ⟧ i ↘ PA -> PA = (fun a => exists v, rtc TRedSN a v /\ SNe v). @@ -291,9 +289,9 @@ Proof. hauto lq:on rew:off inv:InterpExt,SNe use:redsn_preservation_mutual. Qed. -Lemma InterpUniv_Bind_inv n i p A B S : +Lemma InterpUniv_Bind_inv i p A B S : ⟦ PBind p A B ⟧ i ↘ S -> exists PA PF, - ⟦ A : PTm n ⟧ i ↘ PA /\ + ⟦ 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. @@ -303,16 +301,16 @@ Proof. simp InterpUniv. sauto lq:on. Qed. -Lemma InterpUniv_Nat_inv n i S : - ⟦ PNat : PTm n ⟧ i ↘ S -> S = SNat. +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. + inversion 1; try hauto inv:SNe q:on use:redsn_preservation_mutual. + sauto lq:on. Qed. -Lemma InterpUniv_Univ_inv n i j S : - ⟦ PUniv j : PTm n ⟧ i ↘ S -> +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; @@ -321,9 +319,9 @@ Proof. subst. hauto lq:on inv:TRedSN. Qed. -Lemma bindspace_impl n p (PA PA0 : PTm n -> Prop) PF PF0 b : +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 n) (PB PB0 : PTm n -> Prop), PA0 a -> PF a PB -> PF0 a PB0 -> (forall x, PB x -> PB0 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). @@ -341,7 +339,7 @@ Proof. hauto lq:on. Qed. -Lemma InterpUniv_Sub' n i (A B : PTm n) PA PB : +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) /\ @@ -416,7 +414,7 @@ Proof. 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 itauto. - have : @isnat n PNat by simpl. + have : @isnat PNat by simpl. move : h0 hAB. clear. qauto l:on db:noconf. case : H h1 hAB h0 => //=. move /InterpUniv_Nat_inv. scongruence. @@ -427,7 +425,7 @@ Proof. 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 itauto. - have : @isnat n PNat by simpl. + have : @isnat PNat by simpl. move : h0 hAB. clear. qauto l:on db:noconf. case : H h1 hAB h0 => //=. move /InterpUniv_Nat_inv. scongruence. @@ -468,7 +466,7 @@ Proof. qauto l:on. Qed. -Lemma InterpUniv_Sub0 n i (A B : PTm n) PA PB : +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. @@ -477,7 +475,7 @@ Proof. move => [+ _]. apply. Qed. -Lemma InterpUniv_Sub n i j (A B : PTm n) PA PB : +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. @@ -490,7 +488,7 @@ Proof. apply. Qed. -Lemma InterpUniv_Join n i (A B : PTm n) PA PB : +Lemma InterpUniv_Join i (A B : PTm) PA PB : ⟦ A ⟧ i ↘ PA -> ⟦ B ⟧ i ↘ PB -> DJoin.R A B -> @@ -504,13 +502,13 @@ Proof. firstorder. Qed. -Lemma InterpUniv_Functional n i (A : PTm n) PA PB : +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' n i j (A B : PTm n) PA PB : +Lemma InterpUniv_Join' i j (A B : PTm) PA PB : ⟦ A ⟧ i ↘ PA -> ⟦ B ⟧ j ↘ PB -> DJoin.R A B -> @@ -523,16 +521,16 @@ Proof. eauto using InterpUniv_Join. Qed. -Lemma InterpUniv_Functional' n i j A PA PB : - ⟦ A : PTm n ⟧ i ↘ PA -> +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 n i p A B P (h : ⟦PBind p A B ⟧ i ↘ P) : - exists (PA : PTm n -> Prop), +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). @@ -559,19 +557,20 @@ Proof. split; hauto q:on use:InterpUniv_Functional. Qed. -Definition ρ_ok {n} (Γ : fin n -> PTm n) (ρ : fin n -> PTm 0) := forall i k PA, - ⟦ subst_PTm ρ (Γ i) ⟧ k ↘ PA -> PA (ρ i). +Definition ρ_ok (Γ : list PTm) (ρ : nat -> PTm) := forall i k A PA, + lookup i Γ A -> + ⟦ subst_PTm ρ A ⟧ k ↘ PA -> PA (ρ i). -Definition SemWt {n} Γ (a A : PTm n) := forall ρ, ρ_ok Γ ρ -> exists k PA, ⟦ subst_PTm ρ A ⟧ k ↘ PA /\ PA (subst_PTm ρ a). +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 {n} Γ (a b A : PTm n) := DJoin.R a b /\ forall ρ, ρ_ok Γ ρ -> exists k PA, ⟦ subst_PTm ρ A ⟧ k ↘ PA /\ PA (subst_PTm ρ a) /\ PA (subst_PTm ρ b). +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 {n} Γ (A B : PTm n) := Sub.R A B /\ exists i, forall ρ, ρ_ok Γ ρ -> exists S0 S1, ⟦ subst_PTm ρ A ⟧ i ↘ S0 /\ ⟦ subst_PTm ρ B ⟧ i ↘ S1. +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 n Γ (A : PTm n) i : +Lemma SemWt_Univ Γ (A : PTm) i : Γ ⊨ A ∈ PUniv i <-> forall ρ, ρ_ok Γ ρ -> exists S, ⟦ subst_PTm ρ A ⟧ i ↘ S. Proof. @@ -586,13 +585,13 @@ Proof. + simpl. eauto. Qed. -Lemma SemEq_SemWt n Γ (a b A : PTm n) : Γ ⊨ a ≡ b ∈ A -> Γ ⊨ a ∈ A /\ Γ ⊨ b ∈ A /\ DJoin.R a b. +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 n Γ (A B : PTm n) : Γ ⊨ A ≲ B -> Sub.R A B /\ exists i, Γ ⊨ A ∈ PUniv i /\ Γ ⊨ B ∈ PUniv i. +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 n Γ (a b A : PTm n) : Γ ⊨ a ∈ A -> Γ ⊨ b ∈ A -> (DJoin.R a b) -> Γ ⊨ a ≡ b ∈ A. +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ρ. @@ -603,7 +602,7 @@ Proof. hauto lq:on. Qed. -Lemma SemWt_SemLEq n Γ (A B : PTm n) i j : +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 => //. @@ -621,77 +620,76 @@ Proof. Qed. (* Semantic context wellformedness *) -Definition SemWff {n} Γ := forall (i : fin n), exists j, Γ ⊨ Γ i ∈ PUniv j. +Definition SemWff Γ := forall (i : nat) A, lookup i Γ A -> exists j, Γ ⊨ A ∈ PUniv j. Notation "⊨ Γ" := (SemWff Γ) (at level 70). -Lemma ρ_ok_bot n (Γ : fin n -> PTm n) : - ρ_ok Γ (fun _ => PBot). +Lemma ρ_ok_id Γ : + ρ_ok Γ VarPTm. Proof. rewrite /ρ_ok. hauto q:on use:adequacy ctrs:SNe. Qed. -Lemma ρ_ok_cons n i (Γ : fin n -> PTm n) ρ a PA A : +Lemma ρ_ok_cons i Γ ρ a PA A : ⟦ subst_PTm ρ A ⟧ i ↘ PA -> PA a -> ρ_ok Γ ρ -> - ρ_ok (funcomp (ren_PTm shift) (scons A Γ)) (scons a ρ). + ρ_ok (cons A Γ) (scons a ρ). Proof. move => h0 h1 h2. rewrite /ρ_ok. - move => j. - destruct j as [j|]. + case => [|j]; cycle 1. - move => m PA0. asimpl => ?. - asimpl. - firstorder. - - move => m PA0. asimpl => h3. + 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' n i (Γ : fin n -> PTm n) ρ a PA A Δ : - Δ = (funcomp (ren_PTm shift) (scons A Γ)) -> +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 n m (Γ : fin n -> PTm n) ρ : - forall (Δ : fin m -> PTm m) ξ, +Lemma ρ_ok_renaming (Γ : list PTm) ρ : + forall (Δ : list PTm) ξ, renaming_ok Γ Δ ξ -> ρ_ok Γ ρ -> ρ_ok Δ (funcomp ρ ξ). Proof. move => Δ ξ hξ hρ. - rewrite /ρ_ok => i m' PA. + rewrite /ρ_ok => i m' A PA. rewrite /renaming_ok in hξ. rewrite /ρ_ok in hρ. - move => h. + move => PA0 h. rewrite /funcomp. - apply hρ with (k := m'). - move : h. rewrite -hξ. - by asimpl. + eapply hρ with (k := m'); eauto. + move : h. by asimpl. Qed. -Lemma renaming_SemWt {n} Γ a A : +Lemma renaming_SemWt Γ a A : Γ ⊨ a ∈ A -> - forall {m} Δ (ξ : fin n -> fin m), + forall Δ (ξ : nat -> nat), renaming_ok Δ Γ ξ -> Δ ⊨ ren_PTm ξ a ∈ ren_PTm ξ A. Proof. - rewrite /SemWt => h m Δ ξ hξ ρ hρ. + 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 {n m} (Δ : fin m -> PTm m) Γ (ρ : fin n -> PTm m) := +Definition smorphing_ok Δ Γ ρ := forall ξ, ρ_ok Δ ξ -> ρ_ok Γ (funcomp (subst_PTm ξ) ρ). -Lemma smorphing_ok_refl n (Δ : fin n -> PTm n) : smorphing_ok Δ Δ VarPTm. +Lemma smorphing_ok_refl Δ : smorphing_ok Δ Δ VarPTm. rewrite /smorphing_ok => ξ. apply. Qed. -Lemma smorphing_ren n m p Ξ Δ Γ - (ρ : fin n -> PTm m) (ξ : fin m -> fin p) : +Lemma smorphing_ren Ξ Δ Γ + (ρ : nat -> PTm) (ξ : nat -> nat) : renaming_ok Ξ Δ ξ -> smorphing_ok Δ Γ ρ -> smorphing_ok Ξ Γ (funcomp (ren_PTm ξ) ρ). Proof. @@ -707,111 +705,123 @@ Proof. move => ->. by apply hρ. Qed. -Lemma smorphing_ext n m Δ Γ (ρ : fin n -> PTm m) (a : PTm m) (A : PTm n) : +Lemma smorphing_ext Δ Γ (ρ : nat -> PTm) (a : PTm) (A : PTm) : smorphing_ok Δ Γ ρ -> Δ ⊨ a ∈ subst_PTm ρ A -> smorphing_ok - Δ (funcomp (ren_PTm shift) (scons A Γ)) (scons a ρ). + Δ (cons A Γ) (scons a ρ). Proof. move => h ha τ. move => /[dup] hτ. move : ha => /[apply]. move => [k][PA][h0]h1. apply h in hτ. - move => i. - destruct i as [i|]. - - move => k0 PA0. asimpl. rewrite {2}/funcomp. asimpl. - move : hτ => /[apply]. - by asimpl. - - move => k0 PA0. asimpl. rewrite {2}/funcomp. asimpl. + 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 n Γ (a A : PTm n), - Γ ⊨ a ∈ A -> forall m Δ (ρ : fin n -> PTm m), +Lemma morphing_SemWt : forall Γ (a A : PTm ), + Γ ⊨ a ∈ A -> forall Δ (ρ : nat -> PTm ), smorphing_ok Δ Γ ρ -> Δ ⊨ subst_PTm ρ a ∈ subst_PTm ρ A. Proof. - move => n Γ a A ha m Δ ρ hρ τ hτ. + move => Γ a A ha Δ ρ hρ τ hτ. have {}/hρ {}/ha := hτ. asimpl. eauto. Qed. -Lemma morphing_SemWt_Univ : forall n Γ (a : PTm n) i, - Γ ⊨ a ∈ PUniv i -> forall m Δ (ρ : fin n -> PTm m), +Lemma morphing_SemWt_Univ : forall Γ (a : PTm) i, + Γ ⊨ a ∈ PUniv i -> forall Δ (ρ : nat -> PTm), smorphing_ok Δ Γ ρ -> Δ ⊨ subst_PTm ρ a ∈ PUniv i. Proof. - move => n Γ a i ha. - move => m Δ ρ. + move => Γ a i ha Δ ρ. have -> : PUniv i = subst_PTm ρ (PUniv i) by reflexivity. by apply morphing_SemWt. Qed. -Lemma weakening_Sem n Γ (a : PTm n) A B i +Lemma weakening_Sem Γ (a : PTm) A B i (h0 : Γ ⊨ B ∈ PUniv i) (h1 : Γ ⊨ a ∈ A) : - funcomp (ren_PTm shift) (scons B Γ) ⊨ ren_PTm shift a ∈ ren_PTm shift A. + (cons B Γ) ⊨ ren_PTm shift a ∈ ren_PTm shift A. Proof. apply : renaming_SemWt; eauto. - hauto lq:on inv:option unfold:renaming_ok. + hauto lq:on ctrs:lookup unfold:renaming_ok. Qed. -Lemma SemWt_SN n Γ (a : PTm n) A : +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. + +Lemma SemWt_SN Γ (a : PTm) A : Γ ⊨ a ∈ A -> SN a /\ SN A. Proof. move => h. - have {}/h := ρ_ok_bot _ Γ => h. - have h0 : SN (subst_PTm (fun _ : fin n => (PBot : PTm 0)) A) by hauto l:on use:adequacy. - have h1 : SN (subst_PTm (fun _ : fin n => (PBot : PTm 0)) a)by hauto l:on use:adequacy. - move {h}. hauto l:on use:sn_unmorphing. + 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 n Γ (a b A : PTm n) : +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 n Γ (a b : PTm n) : +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. (* Structural laws for Semantic context wellformedness *) -Lemma SemWff_nil : SemWff null. -Proof. case. Qed. +Lemma SemWff_nil : SemWff nil. +Proof. hfcrush inv:lookup. Qed. -Lemma SemWff_cons n Γ (A : PTm n) i : +Lemma SemWff_cons Γ (A : PTm) i : ⊨ Γ -> Γ ⊨ A ∈ PUniv i -> (* -------------- *) - ⊨ funcomp (ren_PTm shift) (scons A Γ). + ⊨ (cons A Γ). Proof. move => h h0. - move => j. destruct j as [j|]. - - move /(_ j) : h => [k hk]. - exists k. change (PUniv k) with (ren_PTm shift (PUniv k : PTm n)). - eauto using weakening_Sem. + move => j A0. elim/lookup_inv => //=_. - hauto q:on use:weakening_Sem. + - move => i0 Γ0 A1 B + ? [*]. subst. + move : h => /[apply]. move => [k hk]. + exists k. change (PUniv k) with (ren_PTm shift (PUniv k)). + eauto using weakening_Sem. Qed. (* Semantic typing rules *) -Lemma ST_Var' n Γ (i : fin n) j : - Γ ⊨ Γ i ∈ PUniv j -> - Γ ⊨ VarPTm i ∈ Γ i. +Lemma ST_Var' Γ (i : nat) A j : + lookup i Γ A -> + Γ ⊨ A ∈ PUniv j -> + Γ ⊨ VarPTm i ∈ A. Proof. - move => /SemWt_Univ h. + move => hl /SemWt_Univ h. rewrite /SemWt => ρ /[dup] hρ {}/h [S hS]. exists j,S. - asimpl. firstorder. + asimpl. hauto q:on unfold:ρ_ok. Qed. -Lemma ST_Var n Γ (i : fin n) : +Lemma ST_Var Γ (i : nat) A : ⊨ Γ -> - Γ ⊨ VarPTm i ∈ Γ i. + lookup i Γ A -> + Γ ⊨ VarPTm i ∈ A. Proof. hauto l:on use:ST_Var' unfold:SemWff. Qed. -Lemma InterpUniv_Bind_nopf n p i (A : PTm n) B PA : +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)). @@ -820,9 +830,9 @@ Proof. Qed. -Lemma ST_Bind' n Γ i j p (A : PTm n) (B : PTm (S n)) : +Lemma ST_Bind' Γ i j p (A : PTm) (B : PTm) : Γ ⊨ A ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A Γ) ⊨ B ∈ PUniv j -> + (cons A Γ) ⊨ B ∈ PUniv j -> Γ ⊨ PBind p A B ∈ PUniv (max i j). Proof. move => /SemWt_Univ h0 /SemWt_Univ h1. @@ -835,9 +845,9 @@ Proof. - move => *. asimpl. hauto l:on use:InterpUniv_cumulative, ρ_ok_cons. Qed. -Lemma ST_Bind n Γ i p (A : PTm n) (B : PTm (S n)) : +Lemma ST_Bind Γ i p (A : PTm) (B : PTm) : Γ ⊨ A ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A Γ) ⊨ B ∈ PUniv i -> + cons A Γ ⊨ B ∈ PUniv i -> Γ ⊨ PBind p A B ∈ PUniv i. Proof. move => h0 h1. @@ -846,9 +856,9 @@ Proof. apply ST_Bind'. Qed. -Lemma ST_Abs n Γ (a : PTm (S n)) A B i : +Lemma ST_Abs Γ (a : PTm) A B i : Γ ⊨ PBind PPi A B ∈ (PUniv i) -> - funcomp (ren_PTm shift) (scons A Γ) ⊨ a ∈ B -> + (cons A Γ) ⊨ a ∈ B -> Γ ⊨ PAbs a ∈ PBind PPi A B. Proof. rename a into b. @@ -868,7 +878,7 @@ Proof. move : ha hPA. clear. hauto q:on use:adequacy. Qed. -Lemma ST_App n Γ (b a : PTm n) A B : +Lemma ST_App Γ (b a : PTm) A B : Γ ⊨ b ∈ PBind PPi A B -> Γ ⊨ a ∈ A -> Γ ⊨ PApp b a ∈ subst_PTm (scons a VarPTm) B. @@ -884,14 +894,14 @@ Proof. asimpl. hauto lq:on. Qed. -Lemma ST_App' n Γ (b a : PTm n) A B U : +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 n Γ (a b : PTm n) A B i : +Lemma ST_Pair Γ (a b : PTm) A B i : Γ ⊨ PBind PSig A B ∈ (PUniv i) -> Γ ⊨ a ∈ A -> Γ ⊨ b ∈ subst_PTm (scons a VarPTm) B -> @@ -917,12 +927,12 @@ Proof. have ? : PB0 = PB by eauto using InterpUniv_Functional'. by subst. Qed. -Lemma N_Projs n p (a b : PTm n) : +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 n Γ (a : PTm n) A B : +Lemma ST_Proj1 Γ (a : PTm) A B : Γ ⊨ a ∈ PBind PSig A B -> Γ ⊨ PProj PL a ∈ A. Proof. @@ -944,7 +954,7 @@ Proof. apply : InterpUniv_back_closs; eauto. Qed. -Lemma ST_Proj2 n Γ (a : PTm n) A B : +Lemma ST_Proj2 Γ (a : PTm) A B : Γ ⊨ a ∈ PBind PSig A B -> Γ ⊨ PProj PR a ∈ subst_PTm (scons (PProj PL a) VarPTm) B. Proof. @@ -989,7 +999,7 @@ Proof. + hauto lq:on use:@relations.rtc_r, InterpUniv_back_closs. Qed. -Lemma ST_Conv' n Γ (a : PTm n) A B i : +Lemma ST_Conv' Γ (a : PTm) A B i : Γ ⊨ a ∈ A -> Γ ⊨ B ∈ PUniv i -> Sub.R A B -> @@ -1006,7 +1016,7 @@ Proof. hauto lq:on. Qed. -Lemma ST_Conv_E n Γ (a : PTm n) A B i : +Lemma ST_Conv_E Γ (a : PTm) A B i : Γ ⊨ a ∈ A -> Γ ⊨ B ∈ PUniv i -> DJoin.R A B -> @@ -1015,23 +1025,23 @@ Proof. hauto l:on use:ST_Conv', Sub.FromJoin. Qed. -Lemma ST_Conv n Γ (a : PTm n) A B : +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 n Γ (a : PTm n) A : +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 n Γ (a b : PTm n) A : +Lemma SE_Symmetric Γ (a b : PTm) A : Γ ⊨ a ≡ b ∈ A -> Γ ⊨ b ≡ a ∈ A. Proof. hauto q:on unfold:SemEq. Qed. -Lemma SE_Transitive n Γ (a b c : PTm n) A : +Lemma SE_Transitive Γ (a b c : PTm) A : Γ ⊨ a ≡ b ∈ A -> Γ ⊨ b ≡ c ∈ A -> Γ ⊨ a ≡ c ∈ A. @@ -1043,36 +1053,32 @@ Proof. hauto l:on use:DJoin.transitive. Qed. -Definition Γ_sub' {n} (Γ Δ : fin n -> PTm n) := forall ρ, ρ_ok Δ ρ -> ρ_ok Γ ρ. +Definition Γ_sub' Γ Δ := forall ρ, ρ_ok Δ ρ -> ρ_ok Γ ρ. -Definition Γ_eq' {n} (Γ Δ : fin n -> PTm n) := forall ρ, ρ_ok Δ ρ <-> ρ_ok Γ ρ. +Definition Γ_eq' Γ Δ := forall ρ, ρ_ok Δ ρ <-> ρ_ok Γ ρ. -Lemma Γ_sub'_refl n (Γ : fin n -> PTm n) : Γ_sub' Γ Γ. +Lemma Γ_sub'_refl Γ : Γ_sub' Γ Γ. rewrite /Γ_sub'. itauto. Qed. -Lemma Γ_sub'_cons n (Γ Δ : fin n -> PTm n) A B i j : +Lemma Γ_sub'_cons Γ Δ A B i j : Sub.R B A -> Γ_sub' Γ Δ -> Γ ⊨ A ∈ PUniv i -> Δ ⊨ B ∈ PUniv j -> - Γ_sub' (funcomp (ren_PTm shift) (scons A Γ)) (funcomp (ren_PTm shift) (scons B Δ)). + Γ_sub' (cons A Γ) (cons B Δ). Proof. move => hsub hsub' hA hB ρ hρ. - - move => k. - move => k0 PA. - have : ρ_ok Δ (funcomp ρ shift). + move => k k' A0 PA. + have hρ_inv : ρ_ok Δ (funcomp ρ shift). move : hρ. clear. move => hρ i. - specialize (hρ (shift i)). - move => k PA. move /(_ k PA) in hρ. - move : hρ. asimpl. by eauto. - move => hρ_inv. - destruct k as [k|]. - - rewrite /Γ_sub' in hsub'. - asimpl. - move /(_ (funcomp ρ shift) hρ_inv) in hsub'. - sfirstorder simp+:asimpl. + (* 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. @@ -1080,13 +1086,21 @@ Proof. move => [S]hS. move /SemWt_Univ : (hB) (hρ_inv)=>/[apply]. move => [S1]hS1. - move /(_ None) : hρ (hS1). asimpl => /[apply]. + 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 n (Γ Δ : fin n -> PTm n) a A : +Lemma Γ_sub'_SemWt Γ Δ a A : Γ_sub' Γ Δ -> Γ ⊨ a ∈ A -> Δ ⊨ a ∈ A. @@ -1096,32 +1110,15 @@ Proof. hauto l:on. Qed. -Definition Γ_eq {n} (Γ Δ : fin n -> PTm n) := forall i, DJoin.R (Γ i) (Δ i). - -Lemma Γ_eq_ρ_ok n Γ Δ (ρ : fin n -> PTm 0) : Γ_eq Γ Δ -> ⊨ Γ -> ρ_ok Γ ρ -> ρ_ok Δ ρ. -Proof. - move => hΓΔ hΓ h. - move => i k PA hPA. - move : hΓ. rewrite /SemWff. move /(_ i) => [j]. - move => hΓ. - rewrite SemWt_Univ in hΓ. - have {}/hΓ := h. - move => [S hS]. - move /(_ i) in h. suff : PA = S by qauto l:on. - move : InterpUniv_Join' hPA hS. repeat move/[apply]. - apply. move /(_ i) /DJoin.symmetric in hΓΔ. - hauto l:on use: DJoin.substing. -Qed. - -Lemma Γ_eq_sub n (Γ Δ : fin n -> PTm n) : Γ_eq' Γ Δ <-> Γ_sub' Γ Δ /\ Γ_sub' Δ Γ. +Lemma Γ_eq_sub Γ Δ : Γ_eq' Γ Δ <-> Γ_sub' Γ Δ /\ Γ_sub' Δ Γ. Proof. rewrite /Γ_eq' /Γ_sub'. hauto l:on. Qed. -Lemma Γ_eq'_cons n (Γ Δ : fin n -> PTm n) A B i j : +Lemma Γ_eq'_cons Γ Δ A B i j : DJoin.R B A -> Γ_eq' Γ Δ -> Γ ⊨ A ∈ PUniv i -> Δ ⊨ B ∈ PUniv j -> - Γ_eq' (funcomp (ren_PTm shift) (scons A Γ)) (funcomp (ren_PTm shift) (scons B Δ)). + Γ_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. @@ -1129,124 +1126,66 @@ Proof. hauto l:on use:Γ_sub'_cons. Qed. -Lemma Γ_eq'_refl n (Γ : fin n -> PTm n) : Γ_eq' Γ Γ. +Lemma Γ_eq'_refl Γ : Γ_eq' Γ Γ. Proof. rewrite /Γ_eq'. firstorder. Qed. -Definition Γ_sub {n} (Γ Δ : fin n -> PTm n) := forall i, Sub.R (Γ i) (Δ i). - -Lemma Γ_sub_ρ_ok n Γ Δ (ρ : fin n -> PTm 0) : Γ_sub Γ Δ -> ⊨ Γ -> ρ_ok Γ ρ -> ρ_ok Δ ρ. -Proof. - move => hΓΔ hΓ h. - move => i k PA hPA. - move : hΓ. rewrite /SemWff. move /(_ i) => [j]. - move => hΓ. - rewrite SemWt_Univ in hΓ. - have {}/hΓ := h. - move => [S hS]. - move /(_ i) in h. suff : forall x, S x -> PA x by qauto l:on. - move : InterpUniv_Sub hS hPA. repeat move/[apply]. - apply. by apply Sub.substing. -Qed. - -Lemma Γ_sub_refl n (Γ : fin n -> PTm n) : - Γ_sub Γ Γ. -Proof. sfirstorder use:Sub.refl. Qed. - -Lemma Γ_sub_cons n (Γ Δ : fin n -> PTm n) A B : - Sub.R A B -> - Γ_sub Γ Δ -> - Γ_sub (funcomp (ren_PTm shift) (scons A Γ)) (funcomp (ren_PTm shift) (scons B Δ)). -Proof. - move => h h0. - move => i. - destruct i as [i|]. - rewrite /funcomp. substify. apply Sub.substing. by asimpl. - rewrite /funcomp. - asimpl. substify. apply Sub.substing. by asimpl. -Qed. - -Lemma Γ_sub_cons' n (Γ : fin n -> PTm n) A B : - Sub.R A B -> - Γ_sub (funcomp (ren_PTm shift) (scons A Γ)) (funcomp (ren_PTm shift) (scons B Γ)). -Proof. eauto using Γ_sub_refl ,Γ_sub_cons. Qed. - -Lemma Γ_eq_refl n (Γ : fin n -> PTm n) : - Γ_eq Γ Γ. -Proof. sfirstorder use:DJoin.refl. Qed. - -Lemma Γ_eq_cons n (Γ Δ : fin n -> PTm n) A B : - DJoin.R A B -> - Γ_eq Γ Δ -> - Γ_eq (funcomp (ren_PTm shift) (scons A Γ)) (funcomp (ren_PTm shift) (scons B Δ)). -Proof. - move => h h0. - move => i. - destruct i as [i|]. - rewrite /funcomp. substify. apply DJoin.substing. by asimpl. - rewrite /funcomp. - asimpl. substify. apply DJoin.substing. by asimpl. -Qed. -Lemma Γ_eq_cons' n (Γ : fin n -> PTm n) A B : - DJoin.R A B -> - Γ_eq (funcomp (ren_PTm shift) (scons A Γ)) (funcomp (ren_PTm shift) (scons B Γ)). -Proof. eauto using Γ_eq_refl ,Γ_eq_cons. Qed. - -Lemma SE_Bind' n Γ i j p (A0 A1 : PTm n) B0 B1 : - ⊨ Γ -> +Lemma SE_Bind' Γ i j p (A0 A1 : PTm) B0 B1 : Γ ⊨ A0 ≡ A1 ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊨ B0 ≡ B1 ∈ PUniv j -> + cons A0 Γ ⊨ B0 ≡ B1 ∈ PUniv j -> Γ ⊨ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv (max i j). Proof. - move => hΓ hA hB. + 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. - have hΓ' : ⊨ funcomp (ren_PTm shift) (scons A1 Γ) by hauto l:on use:SemWff_cons. move => ρ hρ. - suff : ρ_ok (funcomp (ren_PTm shift) (scons A0 Γ)) ρ by hauto l:on. - move : Γ_eq_ρ_ok hΓ' hρ; repeat move/[apply]. apply. - hauto lq:on use:Γ_eq_cons'. + 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 n Γ i p (A0 A1 : PTm n) B0 B1 : - ⊨ Γ -> +Lemma SE_Bind Γ i p (A0 A1 : PTm) B0 B1 : Γ ⊨ A0 ≡ A1 ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊨ B0 ≡ B1 ∈ 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 n Γ (a b : PTm (S n)) A B i : +Lemma SE_Abs Γ (a b : PTm) A B i : Γ ⊨ PBind PPi A B ∈ (PUniv i) -> - funcomp (ren_PTm shift) (scons A Γ) ⊨ a ≡ b ∈ B -> + 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 n Γ i p (A : PTm n) B : +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 n Γ (b : PTm n) A B i : - ⊨ Γ -> +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 => hΓ h0 h1. apply SemWt_SemEq; eauto. + 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). by asimpl. + 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. - eauto using SemWff_cons. + 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)). @@ -1254,10 +1193,10 @@ Proof. hauto q:on ctrs:rtc,RERed.R. Qed. -Lemma SE_AppAbs n Γ (a : PTm (S n)) b A B i: +Lemma SE_AppAbs Γ (a : PTm) b A B i: Γ ⊨ PBind PPi A B ∈ PUniv i -> Γ ⊨ b ∈ A -> - funcomp (ren_PTm shift) (scons A Γ) ⊨ a ∈ B -> + (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. @@ -1271,7 +1210,7 @@ Proof. apply RRed.AppAbs. Qed. -Lemma SE_Conv' n Γ (a b : PTm n) A B i : +Lemma SE_Conv' Γ (a b : PTm) A B i : Γ ⊨ a ≡ b ∈ A -> Γ ⊨ B ∈ PUniv i -> Sub.R A B -> @@ -1281,7 +1220,7 @@ Proof. apply SemWt_SemEq; eauto using ST_Conv'. Qed. -Lemma SE_Conv n Γ (a b : PTm n) A B : +Lemma SE_Conv Γ (a b : PTm) A B : Γ ⊨ a ≡ b ∈ A -> Γ ⊨ A ≲ B -> Γ ⊨ a ≡ b ∈ B. @@ -1290,7 +1229,7 @@ Proof. eauto using SE_Conv'. Qed. -Lemma SBind_inst n Γ p i (A : PTm n) B (a : PTm n) : +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. @@ -1310,7 +1249,7 @@ Proof. hauto lq:on. Qed. -Lemma SE_Pair n Γ (a0 a1 b0 b1 : PTm n) A B i : +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 -> @@ -1320,7 +1259,7 @@ Proof. apply SemWt_SemEq; eauto using ST_Pair, DJoin.PairCong, SBind_inst, DJoin.cong, ST_Conv_E, ST_Pair. Qed. -Lemma SE_Proj1 n Γ (a b : PTm n) A B : +Lemma SE_Proj1 Γ (a b : PTm) A B : Γ ⊨ a ≡ b ∈ PBind PSig A B -> Γ ⊨ PProj PL a ≡ PProj PL b ∈ A. Proof. @@ -1328,7 +1267,7 @@ Proof. apply SemWt_SemEq; eauto using DJoin.ProjCong, ST_Proj1. Qed. -Lemma SE_Proj2 n Γ i (a b : PTm n) A B : +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. @@ -1344,22 +1283,22 @@ Proof. Qed. -Lemma ST_Nat n Γ i : - Γ ⊨ PNat : PTm n ∈ PUniv i. +Lemma ST_Nat Γ i : + Γ ⊨ PNat ∈ PUniv i. Proof. move => ?. apply SemWt_Univ. move => ρ hρ. eexists. by apply InterpUniv_Nat. Qed. -Lemma ST_Zero n Γ : - Γ ⊨ PZero : PTm n ∈ PNat. +Lemma ST_Zero Γ : + Γ ⊨ PZero ∈ PNat. Proof. move => ρ hρ. exists 0, SNat. simpl. split. apply InterpUniv_Nat. apply S_Zero. Qed. -Lemma ST_Suc n Γ (a : PTm n) : +Lemma ST_Suc Γ (a : PTm) : Γ ⊨ a ∈ PNat -> Γ ⊨ PSuc a ∈ PNat. Proof. @@ -1372,31 +1311,31 @@ Proof. Qed. -Lemma sn_unmorphing' n : (forall (a : PTm n) (s : SN a), forall m (ρ : fin m -> PTm n) b, a = subst_PTm ρ b -> SN b). +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 n m (a : PTm (S n)) (ρ : fin n -> PTm m) : - SN (subst_PTm (scons PBot ρ) a) -> SN (subst_PTm (up_PTm_PTm ρ) a). +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 PBot VarPTm)); eauto. + move => h. eapply sn_unmorphing' with (ρ := (scons (VarPTm i) VarPTm)); eauto. by asimpl. Qed. -Lemma sn_bot_up2 n m (a : PTm (S (S n))) (ρ : fin n -> PTm m) : - SN ((subst_PTm (scons PBot (scons PBot ρ)) a)) -> SN (subst_PTm (up_PTm_PTm (up_PTm_PTm ρ)) a). +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 PBot (scons PBot VarPTm))); eauto. + move => h. eapply sn_unmorphing' with (ρ := (scons (VarPTm j) (scons (VarPTm i) VarPTm))); eauto. by asimpl. Qed. -Lemma SNat_SN n (a : PTm n) : SNat a -> SN a. +Lemma SNat_SN (a : PTm) : SNat a -> SN a. induction 1; hauto lq:on ctrs:SN. Qed. -Lemma ST_Ind s Γ P (a : PTm s) b c i : - funcomp (ren_PTm shift) (scons PNat Γ) ⊨ P ∈ PUniv i -> +Lemma ST_Ind Γ P (a : PTm) b c i : + (cons PNat Γ) ⊨ P ∈ PUniv i -> Γ ⊨ a ∈ PNat -> Γ ⊨ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊨ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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ρ. @@ -1407,18 +1346,17 @@ Proof. 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 (funcomp (ren_PTm shift) (scons PNat Γ)) (scons PBot ρ) by apply : ρ_ok_cons; hauto lq:on ctrs:SNat, SNe use:(@InterpUniv_Nat 0). - - have hρbb : ρ_ok (funcomp (ren_PTm shift) (scons P (funcomp (ren_PTm shift) (scons PNat Γ)))) (scons PBot (scons PBot ρ)). + 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 apply sn_bot_up; move : hA hρb => /[apply]; hauto lq:on use:adequacy. + 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. + by apply: sn_bot_up2; move : hb hρbb => /[apply]; hauto lq:on use:adequacy. elim : u /hu. + exists m, PA. split. @@ -1426,7 +1364,7 @@ Proof. * apply : InterpUniv_back_clos; eauto. apply N_IndZero; eauto. + move => a snea. - have hρ' : ρ_ok (funcomp (ren_PTm shift) (scons PNat Γ)) (scons a ρ)by + 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]. @@ -1434,7 +1372,7 @@ Proof. eapply adequacy; eauto. apply N_Ind; eauto. + move => a ha [j][S][h0]h1. - have hρ' : ρ_ok (funcomp (ren_PTm shift) (scons PNat Γ)) (scons (PSuc a) ρ)by + 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]. @@ -1445,7 +1383,7 @@ Proof. (subst_PTm (up_PTm_PTm (up_PTm_PTm ρ)) c)) h1. move => r hr. have hρ'' : ρ_ok - (funcomp (ren_PTm shift) (scons P (funcomp (ren_PTm shift) (scons PNat Γ)))) (scons r (scons a ρ)) by + (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. @@ -1453,7 +1391,7 @@ Proof. have ? : PA1 = S0 by eauto using InterpUniv_Functional'. by subst. + move => a a' hr ha' [k][PA1][h0]h1. - have : ρ_ok (funcomp (ren_PTm shift) (scons PNat Γ)) (scons a ρ) + 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 => //. @@ -1466,10 +1404,10 @@ Proof. 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:option use:RPar.refl. + hauto lq:on inv:nat use:RPar.refl. Qed. -Lemma SE_SucCong n Γ (a b : PTm n) : +Lemma SE_SucCong Γ (a b : PTm) : Γ ⊨ a ≡ b ∈ PNat -> Γ ⊨ PSuc a ≡ PSuc b ∈ PNat. Proof. @@ -1478,11 +1416,11 @@ Proof. hauto q:on use:REReds.suc_inv, REReds.SucCong. Qed. -Lemma SE_IndCong n Γ P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 i : - funcomp (ren_PTm shift) (scons PNat Γ) ⊨ P0 ≡ P1 ∈ PUniv i -> +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 -> - funcomp (ren_PTm shift) (scons P0 (funcomp (ren_PTm shift) (scons PNat Γ))) ⊨ c0 ≡ c1 ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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. @@ -1501,22 +1439,22 @@ Proof. 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). - change (PUniv i) with (ren_PTm shift (@PUniv (S n) i)). - apply : weakening_Sem; eauto. move : hP1. + 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 n) by asimpl. + 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 ST_Nat. + 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 n Γ P i (b : PTm n) c : - funcomp (ren_PTm shift) (scons PNat Γ) ⊨ P ∈ PUniv i -> +Lemma SE_IndZero Γ P i (b : PTm) c : + (cons PNat Γ) ⊨ P ∈ PUniv i -> Γ ⊨ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊨ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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. @@ -1524,11 +1462,11 @@ Proof. apply DJoin.FromRRed0. apply RRed.IndZero. Qed. -Lemma SE_IndSuc s Γ P (a : PTm s) b c i : - funcomp (ren_PTm shift) (scons PNat Γ) ⊨ P ∈ PUniv i -> +Lemma SE_IndSuc Γ P (a : PTm) b c i : + (cons PNat Γ) ⊨ P ∈ PUniv i -> Γ ⊨ a ∈ PNat -> Γ ⊨ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊨ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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. @@ -1543,7 +1481,7 @@ Proof. apply RRed.IndSuc. Qed. -Lemma SE_ProjPair1 n Γ (a b : PTm n) A B i : +Lemma SE_ProjPair1 Γ (a b : PTm) A B i : Γ ⊨ PBind PSig A B ∈ (PUniv i) -> Γ ⊨ a ∈ A -> Γ ⊨ b ∈ subst_PTm (scons a VarPTm) B -> @@ -1554,7 +1492,7 @@ Proof. apply DJoin.FromRRed0. apply RRed.ProjPair. Qed. -Lemma SE_ProjPair2 n Γ (a b : PTm n) A B i : +Lemma SE_ProjPair2 Γ (a b : PTm) A B i : Γ ⊨ PBind PSig A B ∈ (PUniv i) -> Γ ⊨ a ∈ A -> Γ ⊨ b ∈ subst_PTm (scons a VarPTm) B -> @@ -1568,7 +1506,7 @@ Proof. apply DJoin.FromRRed0. apply RRed.ProjPair. Qed. -Lemma SE_PairEta n Γ (a : PTm n) A B i : +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. @@ -1578,7 +1516,7 @@ Proof. rewrite /DJoin.R. hauto lq:on ctrs:rtc,RERed.R. Qed. -Lemma SE_Nat n Γ (a b : PTm n) : +Lemma SE_Nat Γ (a b : PTm) : Γ ⊨ a ≡ b ∈ PNat -> Γ ⊨ PSuc a ≡ PSuc b ∈ PNat. Proof. @@ -1587,7 +1525,7 @@ Proof. eauto using DJoin.SucCong. Qed. -Lemma SE_App n Γ i (b0 b1 a0 a1 : PTm n) A B : +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 -> @@ -1599,14 +1537,14 @@ Proof. apply : ST_Conv_E; eauto using ST_App, DJoin.cong, DJoin.symmetric, SBind_inst. Qed. -Lemma SSu_Eq n Γ (A B : PTm n) i : +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 n Γ (A B C : PTm n) : +Lemma SSu_Transitive Γ (A B C : PTm) : Γ ⊨ A ≲ B -> Γ ⊨ B ≲ C -> Γ ⊨ A ≲ C. @@ -1618,32 +1556,32 @@ Proof. qauto l:on use:SemWt_SemLEq, Sub.transitive. Qed. -Lemma ST_Univ' n Γ i j : +Lemma ST_Univ' Γ i j : i < j -> - Γ ⊨ PUniv i : PTm n ∈ PUniv j. + Γ ⊨ PUniv i ∈ PUniv j. Proof. move => ?. apply SemWt_Univ. move => ρ hρ. eexists. by apply InterpUniv_Univ. Qed. -Lemma ST_Univ n Γ i : - Γ ⊨ PUniv i : PTm n ∈ PUniv (S i). +Lemma ST_Univ Γ i : + Γ ⊨ PUniv i ∈ PUniv (S i). Proof. apply ST_Univ'. lia. Qed. -Lemma SSu_Univ n Γ i j : +Lemma SSu_Univ Γ i j : i <= j -> - Γ ⊨ PUniv i : PTm n ≲ PUniv j. + Γ ⊨ PUniv i ≲ PUniv j. Proof. move => h. apply : SemWt_SemLEq; eauto using ST_Univ. sauto lq:on. Qed. -Lemma SSu_Pi n Γ (A0 A1 : PTm n) B0 B1 : +Lemma SSu_Pi Γ (A0 A1 : PTm ) B0 B1 : ⊨ Γ -> Γ ⊨ A1 ≲ A0 -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊨ B0 ≲ B1 -> + cons A0 Γ ⊨ B0 ≲ B1 -> Γ ⊨ PBind PPi A0 B0 ≲ PBind PPi A1 B1. Proof. move => hΓ hA hB. @@ -1655,17 +1593,18 @@ Proof. apply : SemWt_SemLEq; last by hauto l:on use:Sub.PiCong. hauto l:on use:ST_Bind'. apply ST_Bind'; eauto. - have hΓ' : ⊨ funcomp (ren_PTm shift) (scons A1 Γ) by hauto l:on use:SemWff_cons. + have hΓ' : ⊨ (cons A1 Γ) by hauto l:on use:SemWff_cons. move => ρ hρ. - suff : ρ_ok (funcomp (ren_PTm shift) (scons A0 Γ)) ρ by hauto l:on. - move : Γ_sub_ρ_ok hΓ' hρ; repeat move/[apply]. apply. - hauto lq:on use:Γ_sub_cons'. + 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 n Γ (A0 A1 : PTm n) B0 B1 : +Lemma SSu_Sig Γ (A0 A1 : PTm) B0 B1 : ⊨ Γ -> Γ ⊨ A0 ≲ A1 -> - funcomp (ren_PTm shift) (scons A1 Γ) ⊨ B0 ≲ B1 -> + cons A1 Γ ⊨ B0 ≲ B1 -> Γ ⊨ PBind PSig A0 B0 ≲ PBind PSig A1 B1. Proof. move => hΓ hA hB. @@ -1677,15 +1616,16 @@ Proof. apply : SemWt_SemLEq; last by hauto l:on use:Sub.SigCong. 2 : { hauto l:on use:ST_Bind'. } apply ST_Bind'; eauto. - have hΓ' : ⊨ funcomp (ren_PTm shift) (scons A1 Γ) by hauto l:on use:SemWff_cons. - have hΓ'' : ⊨ funcomp (ren_PTm shift) (scons A0 Γ) by hauto l:on use:SemWff_cons. + have hΓ' : ⊨ cons A1 Γ by hauto l:on use:SemWff_cons. + have hΓ'' : ⊨ cons A0 Γ by hauto l:on use:SemWff_cons. move => ρ hρ. - suff : ρ_ok (funcomp (ren_PTm shift) (scons A1 Γ)) ρ by hauto l:on. - apply : Γ_sub_ρ_ok; eauto. - hauto lq:on use:Γ_sub_cons'. + 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 n Γ (A0 A1 : PTm n) B0 B1 : +Lemma SSu_Pi_Proj1 Γ (A0 A1 : PTm) B0 B1 : Γ ⊨ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> Γ ⊨ A1 ≲ A0. Proof. @@ -1694,7 +1634,7 @@ Proof. hauto lq:on rew:off use:Sub.bind_inj. Qed. -Lemma SSu_Sig_Proj1 n Γ (A0 A1 : PTm n) B0 B1 : +Lemma SSu_Sig_Proj1 Γ (A0 A1 : PTm) B0 B1 : Γ ⊨ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> Γ ⊨ A0 ≲ A1. Proof. @@ -1703,7 +1643,7 @@ Proof. hauto lq:on rew:off use:Sub.bind_inj. Qed. -Lemma SSu_Pi_Proj2 n Γ (a0 a1 A0 A1 : PTm n) B0 B1 : +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. @@ -1716,7 +1656,7 @@ Proof. apply : ST_Conv'; eauto. hauto l:on use:SBind_inv1. Qed. -Lemma SSu_Sig_Proj2 n Γ (a0 a1 A0 A1 : PTm n) B0 B1 : +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. From b3bd75ad429cb400cb5a8ab38446dd63dc8c9fb9 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 01:38:22 -0500 Subject: [PATCH 06/51] Fix the typing rules --- theories/common.v | 7 ++ theories/structural.v | 77 ++++++++-------------- theories/typing.v | 145 +++++++++++++++++++++--------------------- 3 files changed, 103 insertions(+), 126 deletions(-) diff --git a/theories/common.v b/theories/common.v index a890edd..a3740ff 100644 --- a/theories/common.v +++ b/theories/common.v @@ -10,6 +10,13 @@ Inductive lookup : nat -> list PTm -> PTm -> Prop := lookup i Γ A -> lookup (S i) (cons B Γ) (ren_PTm shift A). +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) := diff --git a/theories/structural.v b/theories/structural.v index c25986c..39a573d 100644 --- a/theories/structural.v +++ b/theories/structural.v @@ -1,96 +1,69 @@ -Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax common typing. +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 n (Γ : fin n -> PTm n), ⊢ Γ -> True) /\ - (forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> ⊢ Γ) /\ - (forall n Γ (a b A : PTm n), Γ ⊢ a ≡ b ∈ A -> ⊢ Γ) /\ - (forall n Γ (A B : PTm n), Γ ⊢ A ≲ B -> ⊢ Γ). + (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' n Γ : +Lemma T_Nat' Γ : ⊢ Γ -> - Γ ⊢ PNat : PTm n ∈ PUniv 0. + Γ ⊢ PNat ∈ PUniv 0. Proof. apply T_Nat. Qed. -Lemma renaming_up n m (ξ : fin n -> fin m) Δ Γ A : +Lemma renaming_up (ξ : nat -> nat) Δ Γ A : renaming_ok Δ Γ ξ -> - renaming_ok (funcomp (ren_PTm shift) (scons (ren_PTm ξ A) Δ)) (funcomp (ren_PTm shift) (scons A Γ)) (upRen_PTm_PTm ξ) . + renaming_ok (cons (ren_PTm ξ A) Δ) (cons A Γ) (upRen_PTm_PTm ξ) . Proof. - move => h i. - destruct i as [i|]. - asimpl. rewrite /renaming_ok in h. - rewrite /funcomp. rewrite -h. - by asimpl. - by asimpl. + 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 n Γ a i : - Γ ⊢ a ∈ @PUniv n i -> +Lemma Su_Wt Γ a i : + Γ ⊢ a ∈ PUniv i -> Γ ⊢ a ≲ a. Proof. hauto lq:on ctrs:LEq, Eq. Qed. -Lemma Wt_Univ n Γ a A i +Lemma Wt_Univ Γ a A i (h : Γ ⊢ a ∈ A) : - Γ ⊢ @PUniv n i ∈ PUniv (S i). + Γ ⊢ @PUniv i ∈ PUniv (S i). Proof. hauto lq:on ctrs:Wt use:wff_mutual. Qed. -Lemma Bind_Inv n Γ p (A : PTm n) B U : +Lemma Bind_Inv Γ p (A : PTm) B U : Γ ⊢ PBind p A B ∈ U -> exists i, Γ ⊢ A ∈ PUniv i /\ - funcomp (ren_PTm shift) (scons A Γ) ⊢ B ∈ 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 : n Γ T U / h => //=. - - move => n Γ i p A B hA _ hB _ p0 A0 B0 [*]. subst. + 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 Pi_Inv n Γ (A : PTm n) B U : *) -(* Γ ⊢ PBind PPi A B ∈ U -> *) -(* exists i, Γ ⊢ A ∈ PUniv i /\ *) -(* funcomp (ren_PTm shift) (scons A Γ) ⊢ B ∈ PUniv i /\ *) -(* Γ ⊢ PUniv i ≲ U. *) -(* Proof. *) -(* move E :(PBind PPi A B) => T h. *) -(* move : A B E. *) -(* elim : n Γ T U / h => //=. *) -(* - hauto lq:on ctrs:Wt,LEq,Eq use:Wt_Univ. *) -(* - hauto lq:on rew:off ctrs:LEq. *) -(* Qed. *) - -(* Lemma Bind_Inv n Γ (A : PTm n) B U : *) -(* Γ ⊢ PBind PSig A B ∈ U -> *) -(* exists i, Γ ⊢ A ∈ PUniv i /\ *) -(* funcomp (ren_PTm shift) (scons A Γ) ⊢ B ∈ PUniv i /\ *) -(* Γ ⊢ PUniv i ≲ U. *) -(* Proof. *) -(* move E :(PBind PSig A B) => T h. *) -(* move : A B E. *) -(* elim : n Γ T U / h => //=. *) -(* - hauto lq:on ctrs:Wt,LEq,Eq use:Wt_Univ. *) -(* - hauto lq:on rew:off ctrs:LEq. *) -(* Qed. *) - -Lemma T_App' n Γ (b a : PTm n) A B U : +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' n Γ (a b : PTm n) A B i U : +Lemma T_Pair' Γ (a b : PTm ) A B i U : U = subst_PTm (scons a VarPTm) B -> Γ ⊢ a ∈ A -> Γ ⊢ b ∈ U -> @@ -100,7 +73,7 @@ Proof. move => ->. eauto using T_Pair. Qed. -Lemma E_IndCong' n Γ P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 i U : +Lemma E_IndCong' Γ P0 P1 (a0 a1 : PTm ) b0 b1 c0 c1 i U : U = subst_PTm (scons a0 VarPTm) P0 -> funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P0 ∈ PUniv i -> funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P0 ≡ P1 ∈ PUniv i -> diff --git a/theories/typing.v b/theories/typing.v index 818d6b5..ae78747 100644 --- a/theories/typing.v +++ b/theories/typing.v @@ -1,240 +1,237 @@ -Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax. +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 : forall {n}, (fin n -> PTm n) -> PTm n -> PTm n -> Prop := -| T_Var n Γ (i : fin n) : +Inductive Wt : list PTm -> PTm -> PTm -> Prop := +| T_Var i Γ A : ⊢ Γ -> - Γ ⊢ VarPTm i ∈ Γ i + lookup i Γ A -> + Γ ⊢ VarPTm i ∈ A -| T_Bind n Γ i p (A : PTm n) (B : PTm (S n)) : +| T_Bind Γ i p (A : PTm) (B : PTm) : Γ ⊢ A ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A Γ) ⊢ B ∈ PUniv i -> + cons A Γ ⊢ B ∈ PUniv i -> Γ ⊢ PBind p A B ∈ PUniv i -| T_Abs n Γ (a : PTm (S n)) A B i : +| T_Abs Γ (a : PTm) A B i : Γ ⊢ PBind PPi A B ∈ (PUniv i) -> - funcomp (ren_PTm shift) (scons A Γ) ⊢ a ∈ B -> + (cons A Γ) ⊢ a ∈ B -> Γ ⊢ PAbs a ∈ PBind PPi A B -| T_App n Γ (b a : PTm n) 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 n Γ (a b : PTm n) A B i : +| 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 n Γ (a : PTm n) A B : +| T_Proj1 Γ (a : PTm) A B : Γ ⊢ a ∈ PBind PSig A B -> Γ ⊢ PProj PL a ∈ A -| T_Proj2 n Γ (a : PTm n) A B : +| T_Proj2 Γ (a : PTm) A B : Γ ⊢ a ∈ PBind PSig A B -> Γ ⊢ PProj PR a ∈ subst_PTm (scons (PProj PL a) VarPTm) B -| T_Univ n Γ i : +| T_Univ Γ i : ⊢ Γ -> - Γ ⊢ PUniv i : PTm n ∈ PUniv (S i) + Γ ⊢ PUniv i ∈ PUniv (S i) -| T_Nat n Γ i : +| T_Nat Γ i : ⊢ Γ -> - Γ ⊢ PNat : PTm n ∈ PUniv i + Γ ⊢ PNat ∈ PUniv i -| T_Zero n Γ : +| T_Zero Γ : ⊢ Γ -> - Γ ⊢ PZero : PTm n ∈ PNat + Γ ⊢ PZero ∈ PNat -| T_Suc n Γ (a : PTm n) : +| T_Suc Γ (a : PTm) : Γ ⊢ a ∈ PNat -> Γ ⊢ PSuc a ∈ PNat -| T_Ind s Γ P (a : PTm s) b c i : - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P ∈ PUniv i -> +| T_Ind Γ P (a : PTm) b c i : + cons PNat Γ ⊢ P ∈ PUniv i -> Γ ⊢ a ∈ PNat -> Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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 n Γ (a : PTm n) A B : +| T_Conv Γ (a : PTm) A B : Γ ⊢ a ∈ A -> Γ ⊢ A ≲ B -> Γ ⊢ a ∈ B -with Eq : forall {n}, (fin n -> PTm n) -> PTm n -> PTm n -> PTm n -> Prop := +with Eq : list PTm -> PTm -> PTm -> PTm -> Prop := (* Structural *) -| E_Refl n Γ (a : PTm n) A : +| E_Refl Γ (a : PTm ) A : Γ ⊢ a ∈ A -> Γ ⊢ a ≡ a ∈ A -| E_Symmetric n Γ (a b : PTm n) A : +| E_Symmetric Γ (a b : PTm) A : Γ ⊢ a ≡ b ∈ A -> Γ ⊢ b ≡ a ∈ A -| E_Transitive n Γ (a b c : PTm n) A : +| E_Transitive Γ (a b c : PTm) A : Γ ⊢ a ≡ b ∈ A -> Γ ⊢ b ≡ c ∈ A -> Γ ⊢ a ≡ c ∈ A (* Congruence *) -| E_Bind n Γ i p (A0 A1 : PTm n) B0 B1 : - ⊢ Γ -> +| E_Bind Γ i p (A0 A1 : PTm) B0 B1 : Γ ⊢ A0 ∈ PUniv i -> Γ ⊢ A0 ≡ A1 ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊢ B0 ≡ B1 ∈ PUniv i -> + (cons A0 Γ) ⊢ B0 ≡ B1 ∈ PUniv i -> Γ ⊢ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv i -| E_Abs n Γ (a b : PTm (S n)) A B i : +| E_Abs Γ (a b : PTm) A B i : Γ ⊢ PBind PPi A B ∈ (PUniv i) -> - funcomp (ren_PTm shift) (scons A Γ) ⊢ a ≡ b ∈ B -> + (cons A Γ) ⊢ a ≡ b ∈ B -> Γ ⊢ PAbs a ≡ PAbs b ∈ PBind PPi A B -| E_App n Γ i (b0 b1 a0 a1 : PTm n) A B : +| 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_Pair n Γ (a0 a1 b0 b1 : PTm n) A B i : +| E_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 -| E_Proj1 n Γ (a b : PTm n) A B : +| E_Proj1 Γ (a b : PTm) A B : Γ ⊢ a ≡ b ∈ PBind PSig A B -> Γ ⊢ PProj PL a ≡ PProj PL b ∈ A -| E_Proj2 n Γ i (a b : PTm n) A B : +| 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 n Γ P0 P1 (a0 a1 : PTm n) b0 b1 c0 c1 i : - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P0 ∈ PUniv i -> - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P0 ≡ P1 ∈ PUniv i -> +| 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 -> - funcomp (ren_PTm shift) (scons P0 (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c0 ≡ c1 ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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 n Γ (a b : PTm n) : +| E_SucCong Γ (a b : PTm) : Γ ⊢ a ≡ b ∈ PNat -> Γ ⊢ PSuc a ≡ PSuc b ∈ PNat -| E_Conv n Γ (a b : PTm n) A B : +| E_Conv Γ (a b : PTm) A B : Γ ⊢ a ≡ b ∈ A -> Γ ⊢ A ≲ B -> Γ ⊢ a ≡ b ∈ B (* Beta *) -| E_AppAbs n Γ (a : PTm (S n)) b A B i: +| E_AppAbs Γ (a : PTm) b A B i: Γ ⊢ PBind PPi A B ∈ PUniv i -> Γ ⊢ b ∈ A -> - funcomp (ren_PTm shift) (scons A Γ) ⊢ a ∈ B -> + (cons A Γ) ⊢ a ∈ B -> Γ ⊢ PApp (PAbs a) b ≡ subst_PTm (scons b VarPTm) a ∈ subst_PTm (scons b VarPTm ) B -| E_ProjPair1 n Γ (a b : PTm n) A B i : +| 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 n Γ (a b : PTm n) A B i : +| 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 n Γ P i (b : PTm n) c : - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P ∈ PUniv i -> +| E_IndZero Γ P i (b : PTm) c : + (cons PNat Γ) ⊢ P ∈ PUniv i -> Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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 s Γ P (a : PTm s) b c i : - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P ∈ PUniv i -> +| E_IndSuc Γ P (a : PTm) b c i : + (cons PNat Γ) ⊢ P ∈ PUniv i -> Γ ⊢ a ∈ PNat -> Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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 (* Eta *) -| E_AppEta n Γ (b : PTm n) A B i : - ⊢ Γ -> +| E_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 -| E_PairEta n Γ (a : PTm n) A B i : +| E_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 -with LEq : forall {n}, (fin n -> PTm n) -> PTm n -> PTm n -> Prop := +with LEq : list PTm -> PTm -> PTm -> Prop := (* Structural *) -| Su_Transitive n Γ (A B C : PTm n) : +| Su_Transitive Γ (A B C : PTm) : Γ ⊢ A ≲ B -> Γ ⊢ B ≲ C -> Γ ⊢ A ≲ C (* Congruence *) -| Su_Univ n Γ i j : +| Su_Univ Γ i j : ⊢ Γ -> i <= j -> - Γ ⊢ PUniv i : PTm n ≲ PUniv j + Γ ⊢ PUniv i ≲ PUniv j -| Su_Pi n Γ (A0 A1 : PTm n) B0 B1 i : - ⊢ Γ -> +| Su_Pi Γ (A0 A1 : PTm) B0 B1 i : Γ ⊢ A0 ∈ PUniv i -> Γ ⊢ A1 ≲ A0 -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊢ B0 ≲ B1 -> + (cons A0 Γ) ⊢ B0 ≲ B1 -> Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -| Su_Sig n Γ (A0 A1 : PTm n) B0 B1 i : - ⊢ Γ -> +| Su_Sig Γ (A0 A1 : PTm) B0 B1 i : Γ ⊢ A1 ∈ PUniv i -> Γ ⊢ A0 ≲ A1 -> - funcomp (ren_PTm shift) (scons A1 Γ) ⊢ B0 ≲ B1 -> + (cons A1 Γ) ⊢ B0 ≲ B1 -> Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 (* Injecting from equalities *) -| Su_Eq n Γ (A : PTm n) B i : +| Su_Eq Γ (A : PTm) B i : Γ ⊢ A ≡ B ∈ PUniv i -> Γ ⊢ A ≲ B (* Projection axioms *) -| Su_Pi_Proj1 n Γ (A0 A1 : PTm n) B0 B1 : +| Su_Pi_Proj1 Γ (A0 A1 : PTm) B0 B1 : Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> Γ ⊢ A1 ≲ A0 -| Su_Sig_Proj1 n Γ (A0 A1 : PTm n) B0 B1 : +| Su_Sig_Proj1 Γ (A0 A1 : PTm) B0 B1 : Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> Γ ⊢ A0 ≲ A1 -| Su_Pi_Proj2 n Γ (a0 a1 A0 A1 : PTm n) B0 B1 : +| 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 n Γ (a0 a1 A0 A1 : PTm n) B0 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 : forall {n}, (fin n -> PTm n) -> Prop := +with Wff : list PTm -> Prop := | Wff_Nil : - ⊢ null -| Wff_Cons n Γ (A : PTm n) i : + ⊢ nil +| Wff_Cons Γ (A : PTm) i : ⊢ Γ -> Γ ⊢ A ∈ PUniv i -> (* -------------------------------- *) - ⊢ funcomp (ren_PTm shift) (scons A Γ) + ⊢ (cons A Γ) where "Γ ⊢ a ∈ A" := (Wt Γ a A) and "⊢ Γ" := (Wff Γ) and "Γ ⊢ a ≡ b ∈ A" := (Eq Γ a b A) and "Γ ⊢ A ≲ B" := (LEq Γ A B). From 896d22ac9bd010ca83332c8b6d876ac4d314a7a5 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 01:40:12 -0500 Subject: [PATCH 07/51] minor --- theories/logrel.v | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/theories/logrel.v b/theories/logrel.v index a113437..ae4169c 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -1579,7 +1579,6 @@ Proof. Qed. Lemma SSu_Pi Γ (A0 A1 : PTm ) B0 B1 : - ⊨ Γ -> Γ ⊨ A1 ≲ A0 -> cons A0 Γ ⊨ B0 ≲ B1 -> Γ ⊨ PBind PPi A0 B0 ≲ PBind PPi A1 B1. @@ -1602,12 +1601,11 @@ Proof. 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 => hΓ hA hB. + 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. From d68adf85f4b9a39ab24e5d2b814bf485b3fcad27 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 15:22:59 -0500 Subject: [PATCH 08/51] Finish refactoring substitution lemmas --- theories/common.v | 16 +- theories/fp_red.v | 8 - theories/preservation.v | 12 +- theories/structural.v | 443 ++++++++++++++++++++-------------------- 4 files changed, 244 insertions(+), 235 deletions(-) diff --git a/theories/common.v b/theories/common.v index a3740ff..5095fef 100644 --- a/theories/common.v +++ b/theories/common.v @@ -10,6 +10,12 @@ Inductive lookup : nat -> list PTm -> PTm -> Prop := 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. @@ -126,6 +132,14 @@ Definition ishne_ren (a : PTm) (ξ : nat -> nat) : ishne (ren_PTm ξ a) = ishne a. Proof. move : ξ. elim : a => //=. Qed. -Lemma renaming_shift Γ (ρ : nat -> PTm) A : +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. diff --git a/theories/fp_red.v b/theories/fp_red.v index 6aa7cb6..9d8718b 100644 --- a/theories/fp_red.v +++ b/theories/fp_red.v @@ -12,14 +12,6 @@ Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. Require Import Btauto. Require Import Cdcl.Itauto. -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. - Ltac2 spec_refl () := List.iter (fun a => match a with diff --git a/theories/preservation.v b/theories/preservation.v index b78f87e..fe0a920 100644 --- a/theories/preservation.v +++ b/theories/preservation.v @@ -1,15 +1,15 @@ -Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax common typing structural fp_red. +Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common typing structural fp_red. From Hammer Require Import Tactics. Require Import ssreflect. Require Import Psatz. Require Import Coq.Logic.FunctionalExtensionality. -Lemma App_Inv n Γ (b a : PTm n) U : +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 : n Γ u U / hu => n //=. + move : b a E. elim : Γ u U / hu => //=. - move => Γ b a A B hb _ ha _ b0 a0 [*]. subst. exists A,B. repeat split => //=. @@ -18,12 +18,12 @@ Proof. - hauto lq:on rew:off ctrs:LEq. Qed. -Lemma Abs_Inv n Γ (a : PTm (S n)) U : +Lemma Abs_Inv Γ (a : PTm) U : Γ ⊢ PAbs a ∈ U -> - exists A B, funcomp (ren_PTm shift) (scons A Γ) ⊢ a ∈ B /\ Γ ⊢ PBind PPi A B ≲ U. + exists A B, (cons A Γ) ⊢ a ∈ B /\ Γ ⊢ PBind PPi A B ≲ U. Proof. move E : (PAbs a) => u hu. - move : a E. elim : n Γ u U / hu => n //=. + 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. diff --git a/theories/structural.v b/theories/structural.v index 39a573d..10d6583 100644 --- a/theories/structural.v +++ b/theories/structural.v @@ -75,44 +75,44 @@ Qed. Lemma E_IndCong' Γ P0 P1 (a0 a1 : PTm ) b0 b1 c0 c1 i U : U = subst_PTm (scons a0 VarPTm) P0 -> - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P0 ∈ PUniv i -> - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P0 ≡ P1 ∈ PUniv i -> + (cons PNat Γ) ⊢ P0 ∈ PUniv i -> + (cons PNat Γ) ⊢ P0 ≡ P1 ∈ PUniv i -> Γ ⊢ a0 ≡ a1 ∈ PNat -> Γ ⊢ b0 ≡ b1 ∈ subst_PTm (scons PZero VarPTm) P0 -> - funcomp (ren_PTm shift) (scons P0 (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c0 ≡ c1 ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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' s Γ P (a : PTm s) b c i U : +Lemma T_Ind' Γ P (a : PTm) b c i U : U = subst_PTm (scons a VarPTm) P -> - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P ∈ PUniv i -> + cons PNat Γ ⊢ P ∈ PUniv i -> Γ ⊢ a ∈ PNat -> Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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' n Γ (a : PTm n) A B U : +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' n Γ i (a b : PTm n) A B U : +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' n Γ i p (A0 A1 : PTm n) B0 B1 : +Lemma E_Bind' Γ i p (A0 A1 : PTm) B0 B1 : Γ ⊢ A0 ∈ PUniv i -> Γ ⊢ A0 ≡ A1 ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊢ B0 ≡ B1 ∈ 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' n Γ i (b0 b1 a0 a1 : PTm n) A B U : +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 -> @@ -120,16 +120,16 @@ Lemma E_App' n Γ i (b0 b1 a0 a1 : PTm n) A B U : Γ ⊢ PApp b0 a0 ≡ PApp b1 a1 ∈ U. Proof. move => ->. apply E_App. Qed. -Lemma E_AppAbs' n Γ (a : PTm (S n)) b A B i u U : +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 -> - funcomp (ren_PTm shift) (scons A Γ) ⊢ a ∈ B -> + cons A Γ ⊢ a ∈ B -> Γ ⊢ PApp (PAbs a) b ≡ u ∈ U. move => -> ->. apply E_AppAbs. Qed. -Lemma E_ProjPair2' n Γ (a b : PTm n) A B i U : +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 -> @@ -137,14 +137,14 @@ Lemma E_ProjPair2' n Γ (a b : PTm n) A B i U : Γ ⊢ PProj PR (PPair a b) ≡ b ∈ U. Proof. move => ->. apply E_ProjPair2. Qed. -Lemma E_AppEta' n Γ (b : PTm n) A B i u : +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' n Γ (a0 a1 A0 A1 : PTm n) B0 B1 U T : +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 -> @@ -152,7 +152,7 @@ Lemma Su_Pi_Proj2' n Γ (a0 a1 A0 A1 : PTm n) B0 B1 U T : Γ ⊢ U ≲ T. Proof. move => -> ->. apply Su_Pi_Proj2. Qed. -Lemma Su_Sig_Proj2' n Γ (a0 a1 A0 A1 : PTm n) B0 B1 U T : +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 -> @@ -160,64 +160,61 @@ Lemma Su_Sig_Proj2' n Γ (a0 a1 A0 A1 : PTm n) B0 B1 U T : Γ ⊢ U ≲ T. Proof. move => -> ->. apply Su_Sig_Proj2. Qed. -Lemma E_IndZero' n Γ P i (b : PTm n) c U : +Lemma E_IndZero' Γ P i (b : PTm) c U : U = subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P ∈ PUniv i -> + cons PNat Γ ⊢ P ∈ PUniv i -> Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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' n Γ (A : PTm n) i : +Lemma Wff_Cons' Γ (A : PTm) i : Γ ⊢ A ∈ PUniv i -> (* -------------------------------- *) - ⊢ funcomp (ren_PTm shift) (scons A Γ). + ⊢ cons A Γ. Proof. hauto lq:on rew:off use:Wff_Cons, wff_mutual. Qed. -Lemma E_IndSuc' s Γ P (a : PTm s) b c i u U : +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 -> - funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P ∈ PUniv i -> + cons PNat Γ ⊢ P ∈ PUniv i -> Γ ⊢ a ∈ PNat -> Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P -> - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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 n (Γ : fin n -> PTm n), ⊢ Γ -> True) /\ - (forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> forall m Δ (ξ : fin n -> fin m), ⊢ Δ -> renaming_ok Δ Γ ξ -> + (forall Γ, ⊢ Γ -> True) /\ + (forall Γ (a A : PTm), Γ ⊢ a ∈ A -> forall Δ (ξ : nat -> nat), ⊢ Δ -> renaming_ok Δ Γ ξ -> Δ ⊢ ren_PTm ξ a ∈ ren_PTm ξ A) /\ - (forall n Γ (a b A : PTm n), Γ ⊢ a ≡ b ∈ A -> forall m Δ (ξ : fin n -> fin m), ⊢ Δ -> renaming_ok Δ Γ ξ -> + (forall Γ (a b A : PTm), Γ ⊢ a ≡ b ∈ A -> forall Δ (ξ : nat -> nat), ⊢ Δ -> renaming_ok Δ Γ ξ -> Δ ⊢ ren_PTm ξ a ≡ ren_PTm ξ b ∈ ren_PTm ξ A) /\ - (forall n Γ (A B : PTm n), Γ ⊢ A ≲ B -> forall m Δ (ξ : fin n -> fin m), ⊢ Δ -> renaming_ok Δ Γ ξ -> + (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. - - move => n Γ i hΓ _ m Δ ξ hΔ hξ. - rewrite hξ. - by apply T_Var. - hauto lq:on rew:off ctrs:Wt, Wff use:renaming_up. - - move => n Γ a A B i hP ihP ha iha m Δ ξ hΔ hξ. + - 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 => n Γ a A b B i hA ihA hB ihB hS ihS m Δ ξ hξ hΔ. + - 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 => n Γ a A B ha iha m Δ ξ hΔ hξ. apply : T_Proj2'; eauto. by asimpl. - - move => s Γ P a b c i hP ihP ha iha hb ihb hc ihc m Δ ξ hΔ hξ. + - 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 Ξ := funcomp _ _. + set Ξ := cons _ _. have hΞ : ⊢ Ξ. subst Ξ. apply : Wff_Cons'; eauto. apply hP. - move /(_ _ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. - set Ξ' := (funcomp _ _ : fin (S (S _)) -> _) . + 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]. @@ -225,31 +222,33 @@ Proof. - hauto lq:on ctrs:Wt,LEq. - hauto lq:on ctrs:Eq. - hauto lq:on rew:off use:E_Bind', Wff_Cons, renaming_up. - - move => n Γ a b A B i hPi ihPi ha iha m Δ ξ hΔ hξ. + - move => Γ a b A B i hPi ihPi ha iha Δ ξ hΔ hξ. move : ihPi (hΔ) (hξ). repeat move/[apply]. move => /Bind_Inv [j][h0][h1]h2. have ? : Δ ⊢ PBind PPi (ren_PTm ξ A) (ren_PTm (upRen_PTm_PTm ξ) B) ∈ PUniv j by qauto l:on ctrs:Wt. move {hPi}. apply : E_Abs; eauto. qauto l:on ctrs:Wff use:renaming_up. - move => *. apply : E_App'; eauto. by asimpl. - - move => n Γ a0 a1 b0 b1 A B i hA ihA ha iha hb ihb m Δ ξ hΔ hξ. + - move => Γ a0 a1 b0 b1 A B i hA ihA ha iha hb ihb Δ ξ hΔ hξ. apply : E_Pair; eauto. move : ihb hΔ hξ. repeat move/[apply]. by asimpl. - move => *. apply : E_Proj2'; eauto. by asimpl. - - move => n Γ P0 P1 a0 a1 b0 b1 c0 c1 i hP0 ihP0 hP ihP ha iha hb ihb hc ihc. - move => m Δ ξ hΔ hξ [:hP']. - apply E_IndCong' with (i := i). + - 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'. - by eauto with wt. + apply ihP; eauto with wt. move : ihb (hΔ) (hξ); do! move/[apply]. by asimpl. - set Ξ := funcomp _ _. + set Ξ := cons _ _. have hΞ : ⊢ Ξ. - subst Ξ. apply :Wff_Cons'; eauto. apply hP'. - move /(_ _ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. + 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 @@ -259,31 +258,33 @@ Proof. (ren_PTm (upRen_PTm_PTm ξ) P0)) by scongruence. by asimpl. - qauto l:on ctrs:Eq, LEq. - - move => n Γ a b A B i hP ihP hb ihb ha iha m Δ ξ hΔ hξ. + - 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 => n Γ a b A B i hP ihP ha iha hb ihb m Δ ξ hΔ hξ. + - 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 => n Γ a b A B i hP ihP ha iha hb ihb m Δ ξ hΔ hξ. + - 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 => n Γ P i b c hP ihP hb ihb hc ihc m Δ ξ hΔ hξ. + - move => Γ P i b c hP ihP hb ihb hc ihc Δ ξ hΔ hξ. apply E_IndZero' with (i := i); eauto. by asimpl. - qauto l:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ m Δ ξ hΔ) : ihb. + sauto lq:on use:Wff_Cons', T_Nat', renaming_up. + move /(_ Δ ξ hΔ) : ihb. asimpl. by apply. - set Ξ := funcomp _ _. - have hΞ : ⊢ Ξ by qauto l:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ _ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. - move /(_ ltac:(qauto l:on use:renaming_up)). + 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 @@ -291,15 +292,15 @@ Proof. (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift)) (ren_PTm (upRen_PTm_PTm ξ) P)) by scongruence. by asimpl. - - move => n Γ P a b c i hP ihP ha iha hb ihb hc ihc m Δ ξ hΔ hξ. + - 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. - qauto l:on use:Wff_Cons', T_Nat', renaming_up. + sauto lq:on use:Wff_Cons', T_Nat', renaming_up. by eauto with wt. - move /(_ m Δ ξ hΔ) : ihb. asimpl. by apply. - set Ξ := funcomp _ _. - have hΞ : ⊢ Ξ by qauto l:on use:Wff_Cons', T_Nat', renaming_up. - move /(_ _ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. - move /(_ ltac:(qauto l:on use: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. + move /(_ ltac:(by eauto using renaming_up)). by asimpl. - move => *. apply : E_AppEta'; eauto. by asimpl. @@ -315,94 +316,94 @@ Proof. - move => *. apply : Su_Sig_Proj2'; eauto; by asimpl. Qed. -Definition morphing_ok {n m} Δ Γ (ρ : fin n -> PTm m) := - forall i, Δ ⊢ ρ i ∈ subst_PTm ρ (Γ i). +Definition morphing_ok Δ Γ (ρ : nat -> PTm) := + forall i A, lookup i Γ A -> Δ ⊢ ρ i ∈ subst_PTm ρ A. -Lemma morphing_ren n m p Ξ Δ Γ - (ρ : fin n -> PTm m) (ξ : fin m -> fin p) : +Lemma morphing_ren Ξ Δ Γ + (ρ : nat -> PTm) (ξ : nat -> nat) : ⊢ Ξ -> renaming_ok Ξ Δ ξ -> morphing_ok Δ Γ ρ -> morphing_ok Ξ Γ (funcomp (ren_PTm ξ) ρ). Proof. - move => hΞ hξ hρ. - move => i. + move => hΞ hξ hρ i A. rewrite {1}/funcomp. have -> : - subst_PTm (funcomp (ren_PTm ξ) ρ) (Γ i) = - ren_PTm ξ (subst_PTm ρ (Γ i)) by asimpl. - eapply renaming; eauto. + subst_PTm (funcomp (ren_PTm ξ) ρ) A = + ren_PTm ξ (subst_PTm ρ A) by asimpl. + move => ?. eapply renaming; eauto. Qed. -Lemma morphing_ext n m Δ Γ (ρ : fin n -> PTm m) (a : PTm m) (A : PTm n) : +Lemma morphing_ext Δ Γ (ρ : nat -> PTm) (a : PTm) (A : PTm) : morphing_ok Δ Γ ρ -> Δ ⊢ a ∈ subst_PTm ρ A -> morphing_ok - Δ (funcomp (ren_PTm shift) (scons A Γ)) (scons a ρ). + Δ (cons A Γ) (scons a ρ). Proof. - move => h ha i. destruct i as [i|]; by asimpl. + 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 T_Var' n Γ (i : fin n) U : - U = Γ i -> - ⊢ Γ -> - Γ ⊢ VarPTm i ∈ U. -Proof. move => ->. apply T_Var. Qed. - -Lemma renaming_wt : forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> forall m Δ (ξ : fin n -> fin m), ⊢ Δ -> renaming_ok Δ Γ ξ -> Δ ⊢ ren_PTm ξ a ∈ ren_PTm ξ A. +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 n m Δ Γ a A (ξ : fin n -> fin m) u U, +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 n m Γ Δ (ρ : fin n -> PTm m) (A : PTm n) k : +Lemma morphing_up Γ Δ (ρ : nat -> PTm) (A : PTm) k : morphing_ok Γ Δ ρ -> Γ ⊢ subst_PTm ρ A ∈ PUniv k -> - morphing_ok (funcomp (ren_PTm shift) (scons (subst_PTm ρ A) Γ)) (funcomp (ren_PTm shift) (scons A Δ)) (up_PTm_PTm ρ). + morphing_ok (cons (subst_PTm ρ A) Γ) (cons A Δ) (up_PTm_PTm ρ). Proof. move => h h1 [:hp]. apply morphing_ext. rewrite /morphing_ok. - move => i. - rewrite {2}/funcomp. - apply : renaming_wt'; eauto. by asimpl. + 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. - eauto using renaming_shift. - apply : T_Var';eauto. rewrite /funcomp. by asimpl. + apply : T_Var;eauto. apply here'. by asimpl. Qed. -Lemma weakening_wt : forall n Γ (a A B : PTm n) i, +Lemma weakening_wt : forall Γ (a A B : PTm) i, Γ ⊢ B ∈ PUniv i -> Γ ⊢ a ∈ A -> - funcomp (ren_PTm shift) (scons B Γ) ⊢ ren_PTm shift a ∈ ren_PTm shift A. + cons B Γ ⊢ ren_PTm shift a ∈ ren_PTm shift A. Proof. - move => n Γ a A B i hB ha. + move => Γ a A B i hB ha. apply : renaming_wt'; eauto. apply : Wff_Cons'; eauto. apply : renaming_shift; eauto. Qed. -Lemma weakening_wt' : forall n Γ (a A B : PTm n) i U u, +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 -> - funcomp (ren_PTm shift) (scons B Γ) ⊢ u ∈ U. + cons B Γ ⊢ u ∈ U. Proof. move => > -> ->. apply weakening_wt. Qed. Lemma morphing : - (forall n (Γ : fin n -> PTm n), ⊢ Γ -> True) /\ - (forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> forall m Δ (ρ : fin n -> PTm m), ⊢ Δ -> morphing_ok Δ Γ ρ -> + (forall Γ, ⊢ Γ -> True) /\ + (forall Γ a A, Γ ⊢ a ∈ A -> forall Δ ρ, ⊢ Δ -> morphing_ok Δ Γ ρ -> Δ ⊢ subst_PTm ρ a ∈ subst_PTm ρ A) /\ - (forall n Γ (a b A : PTm n), Γ ⊢ a ≡ b ∈ A -> forall m Δ (ρ : fin n -> PTm m), ⊢ Δ -> morphing_ok Δ Γ ρ -> + (forall Γ a b A, Γ ⊢ a ≡ b ∈ A -> forall Δ ρ, ⊢ Δ -> morphing_ok Δ Γ ρ -> Δ ⊢ subst_PTm ρ a ≡ subst_PTm ρ b ∈ subst_PTm ρ A) /\ - (forall n Γ (A B : PTm n), Γ ⊢ A ≲ B -> forall m Δ (ρ : fin n -> PTm m), ⊢ Δ -> morphing_ok Δ Γ ρ -> + (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 => n Γ a A B i hP ihP ha iha m Δ ρ hΔ hρ. + - 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. @@ -411,7 +412,7 @@ Proof. hauto lq:on use:Wff_Cons', Bind_Inv. apply : morphing_up; eauto. - move => *; apply : T_App'; eauto; by asimpl. - - move => n Γ a A b B i hA ihA hB ihB hS ihS m Δ ρ hρ hΔ. + - 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. @@ -419,9 +420,8 @@ Proof. - qauto l:on ctrs:Wt. - qauto l:on ctrs:Wt. - qauto l:on ctrs:Wt. - - move => s Γ P a b c i hP ihP ha iha hb ihb hc ihc m Δ ξ hΔ hξ. - have hξ' : morphing_ok (funcomp (ren_PTm shift) (scons PNat Δ)) - (funcomp (ren_PTm shift) (scons PNat Γ)) (up_PTm_PTm ξ). + - 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]. @@ -430,11 +430,11 @@ Proof. move /morphing_up : hξ. move /(_ PNat 0). apply. by apply T_Nat. move : ihb hξ hΔ; do!move/[apply]. by asimpl. - set Ξ := funcomp _ _. + set Ξ := cons _ _. have hΞ : ⊢ Ξ. subst Ξ. apply : Wff_Cons'; eauto. apply hP. - move /(_ _ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. - set Ξ' := (funcomp _ _ : fin (S (S _)) -> _) . + 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]. @@ -447,23 +447,23 @@ Proof. - hauto lq:on ctrs:Eq. - hauto lq:on ctrs:Eq. - hauto lq:on rew:off use:E_Bind', Wff_Cons, morphing_up. - - move => n Γ a b A B i hPi ihPi ha iha m Δ ρ hΔ hρ. + - move => Γ a b A B i hPi ihPi ha iha Δ ρ hΔ hρ. move : ihPi (hΔ) (hρ). repeat move/[apply]. move => /Bind_Inv [j][h0][h1]h2. have ? : Δ ⊢ PBind PPi (subst_PTm ρ A) (subst_PTm (up_PTm_PTm ρ) B) ∈ PUniv j by qauto l:on ctrs:Wt. move {hPi}. apply : E_Abs; eauto. qauto l:on ctrs:Wff use:morphing_up. - move => *. apply : E_App'; eauto. by asimpl. - - move => n Γ a0 a1 b0 b1 A B i hA ihA ha iha hb ihb m Δ ρ hΔ hρ. + - move => Γ a0 a1 b0 b1 A B i hA ihA ha iha hb ihb Δ ρ hΔ hρ. apply : E_Pair; eauto. move : ihb hΔ hρ. repeat move/[apply]. by asimpl. - hauto q:on ctrs:Eq. - move => *. apply : E_Proj2'; eauto. by asimpl. - - move => n Γ P0 P1 a0 a1 b0 b1 c0 c1 i hP0 ihP0 hP ihP ha iha hb ihb hc ihc. - move => m Δ ξ hΔ hξ. - have hξ' : morphing_ok (funcomp (ren_PTm shift) (scons PNat Δ)) - (funcomp (ren_PTm shift) (scons PNat Γ)) (up_PTm_PTm ξ). + - 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']. @@ -474,56 +474,54 @@ Proof. qauto l:on use:renaming_up, Wff_Cons', T_Nat'. by eauto with wt. move : ihb (hΔ) (hξ); do! move/[apply]. by asimpl. - set Ξ := funcomp _ _. + set Ξ := cons _ _. have hΞ : ⊢ Ξ. subst Ξ. apply :Wff_Cons'; eauto. apply hP'. - move /(_ _ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. + 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 => n Γ a b A B i hP ihP hb ihb ha iha m Δ ρ hΔ hρ. + - 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 => n Γ a b A B i hP ihP ha iha hb ihb m Δ ρ hΔ hρ. + - 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 => n Γ a b A B i hP ihP ha iha hb ihb m Δ ρ hΔ hρ. + - 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 => n Γ P i b c hP ihP hb ihb hc ihc m Δ ξ hΔ hξ. - have hξ' : morphing_ok (funcomp (ren_PTm shift) (scons PNat Δ)) - (funcomp (ren_PTm shift) (scons PNat Γ)) (up_PTm_PTm ξ). + - 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 /(_ m Δ ξ hΔ) : ihb. + move /(_ Δ ξ hΔ) : ihb. asimpl. by apply. - set Ξ := funcomp _ _. + 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 /(_ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. move /(_ ltac:(sauto lq:on use:morphing_up)). asimpl. substify. by asimpl. - - move => n Γ P a b c i hP ihP ha iha hb ihb hc ihc m Δ ξ hΔ hξ. - have hξ' : morphing_ok (funcomp (ren_PTm shift) (scons PNat Δ)) - (funcomp (ren_PTm shift) (scons PNat Γ)) (up_PTm_PTm ξ). + - 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 /(_ m Δ ξ hΔ) : ihb. asimpl. by apply. - set Ξ := funcomp _ _. + 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 /(_ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. move /(_ ltac:(sauto l:on use:morphing_up)). asimpl. substify. by asimpl. - move => *. @@ -540,40 +538,39 @@ Proof. - move => *. apply : Su_Sig_Proj2'; eauto; by asimpl. Qed. -Lemma morphing_wt : forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> forall m Δ (ρ : fin n -> PTm m), ⊢ Δ -> morphing_ok Δ Γ ρ -> Δ ⊢ subst_PTm ρ a ∈ subst_PTm ρ A. +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 n m Δ Γ a A (ρ : fin n -> PTm m) u U, +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 n (Γ : fin n -> PTm n), ⊢ Γ -> morphing_ok Γ Γ VarPTm. +Lemma morphing_id : forall Γ, ⊢ Γ -> morphing_ok Γ Γ VarPTm. Proof. - move => n Γ hΓ. - rewrite /morphing_ok. - move => i. asimpl. by apply T_Var. + rewrite /morphing_ok => Γ hΓ i. asimpl. + eauto using T_Var. Qed. -Lemma substing_wt : forall n Γ (a : PTm (S n)) (b A : PTm n) B, - funcomp (ren_PTm shift) (scons A Γ) ⊢ a ∈ B -> +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 => n Γ a b A B ha hb [:hΓ]. apply : morphing_wt; eauto. + 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 n (A0 A1 : PTm n) i j Γ a A : - funcomp (ren_PTm shift) (scons A0 Γ) ⊢ a ∈ A -> +Lemma ctx_eq_subst_one (A0 A1 : PTm) i j Γ a A : + (cons A0 Γ) ⊢ a ∈ A -> Γ ⊢ A0 ∈ PUniv i -> Γ ⊢ A1 ∈ PUniv j -> Γ ⊢ A1 ≲ A0 -> - funcomp (ren_PTm shift) (scons A1 Γ) ⊢ a ∈ A. + (cons A1 Γ) ⊢ a ∈ A. Proof. move => h0 h1 h2 h3. replace a with (subst_PTm VarPTm a); last by asimpl. @@ -581,22 +578,23 @@ Proof. have ? : ⊢ Γ by sfirstorder use:wff_mutual. apply : morphing_wt; eauto. apply : Wff_Cons'; eauto. - move => k. destruct k as [k|]. - - asimpl. - eapply weakening_wt' with (a := VarPTm k);eauto using T_Var. + 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 => [:hΓ']. + - move => A3 Γ0 ? [*]. subst. + move => [:hΓ']. apply : T_Conv. apply T_Var. abstract : hΓ'. - eauto using Wff_Cons'. - rewrite /funcomp. asimpl. substify. asimpl. - renamify. + eauto using Wff_Cons'. apply here. + asimpl. renamify. eapply renaming; eauto. apply : renaming_shift; eauto. Qed. -Lemma bind_inst n Γ p (A : PTm n) B i a0 a1 : +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. @@ -606,7 +604,7 @@ Proof. case : p h => //=; hauto l:on use:Su_Pi_Proj2, Su_Sig_Proj2. Qed. -Lemma Cumulativity n Γ (a : PTm n) i j : +Lemma Cumulativity Γ (a : PTm ) i j : i <= j -> Γ ⊢ a ∈ PUniv i -> Γ ⊢ a ∈ PUniv j. @@ -616,9 +614,9 @@ Proof. sfirstorder use:wff_mutual. Qed. -Lemma T_Bind' n Γ i j p (A : PTm n) (B : PTm (S n)) : +Lemma T_Bind' Γ i j p (A : PTm ) (B : PTm) : Γ ⊢ A ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A Γ) ⊢ B ∈ PUniv j -> + (cons A Γ) ⊢ B ∈ PUniv j -> Γ ⊢ PBind p A B ∈ PUniv (max i j). Proof. move => h0 h1. @@ -629,47 +627,48 @@ Qed. Hint Resolve T_Bind' : wt. Lemma regularity : - (forall n (Γ : fin n -> PTm n), ⊢ Γ -> forall i, exists j, Γ ⊢ Γ i ∈ PUniv j) /\ - (forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> exists i, Γ ⊢ A ∈ PUniv i) /\ - (forall n Γ (a b A : PTm n), Γ ⊢ a ≡ b ∈ A -> Γ ⊢ a ∈ A /\ Γ ⊢ b ∈ A /\ exists i, Γ ⊢ A ∈ PUniv i) /\ - (forall n Γ (A B : PTm n), Γ ⊢ A ≲ B -> exists i, Γ ⊢ A ∈ PUniv i /\ Γ ⊢ B ∈ PUniv i). + (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 => n Γ A i hΓ ihΓ hA _ j. - destruct j as [j|]. - have := ihΓ j. - move => [j0 hj]. - exists j0. apply : renaming_wt' => //=; eauto using renaming_shift. - reflexivity. econstructor; eauto. - exists i. rewrite {2}/funcomp. simpl. - apply : renaming_wt'; eauto. reflexivity. - econstructor; eauto. - apply : renaming_shift; eauto. - - move => n Γ b a A B hb [i ihb] ha [j iha]. + - 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 => n Γ a A B ha [i /Bind_Inv[j][h0][h1]h2]. + - 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 => s Γ P a b c i + ? + *. clear. move => h ha. exists i. + - move => Γ P a b c i + ? + *. clear. move => h ha. exists i. hauto lq:on use:substing_wt. - sfirstorder. - sfirstorder. - sfirstorder. - - move => n Γ i p A0 A1 B0 B1 hΓ ihΓ hA0 + - move => Γ i p A0 A1 B0 B1 hΓ ihΓ hA0 [i0 ihA0] hA [ihA [ihA' [i1 ihA'']]]. - move => hB [ihB0 [ihB1 [i2 ihB2]]]. repeat split => //=. qauto use:T_Bind. apply T_Bind; eauto. + sfirstorder. apply : ctx_eq_subst_one; eauto using Su_Eq, E_Symmetric. - eauto using T_Univ. + hauto lq:on. - hauto lq:on ctrs:Wt,Eq. - - move => n Γ i b0 b1 a0 a1 A B hP _ hb [ihb0 [ihb1 [i0 ihb2]]] + - 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. @@ -680,15 +679,16 @@ Proof. hauto lq:on ctrs:Wt,Eq,LEq lq:on use:Bind_Inv, substing_wt. - hauto lq:on use:bind_inst db:wt. - hauto lq:on use:Bind_Inv db:wt. - - move => n Γ i a b A B hS _ hab [iha][ihb][j]ihs. + - 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 => n Γ P0 P1 a0 a1 b0 b1 c0 c1 i _ _ hPE [hP0 [hP1 _]] hae [ha0 [ha1 _]] _ [hb0 [hb1 hb2]] _ [hc0 [hc1 hc2]]. + - 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. @@ -696,13 +696,12 @@ Proof. apply : T_Conv. apply : ctx_eq_subst_one; eauto. by eauto using Su_Eq, E_Symmetric. eapply renaming; eauto. - eapply morphing; eauto 20 using Su_Eq, morphing_ext, morphing_id with wt. - apply morphing_ext; eauto. - replace (funcomp VarPTm shift) with (funcomp (@ren_PTm n _ shift) VarPTm); last by asimpl. - apply : morphing_ren; eauto using Wff_Cons' with wt. - apply : renaming_shift; eauto. by apply morphing_id. - apply T_Suc. apply T_Var'. by asimpl. apply : Wff_Cons'; eauto using T_Nat'. - apply : Wff_Cons'; eauto. apply : renaming_shift; 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. @@ -711,62 +710,62 @@ Proof. - hauto lq:on ctrs:Wt. - hauto q:on use:substing_wt db:wt. - hauto l:on use:bind_inst db:wt. - - move => n Γ P i b c hP _ hb _ hc _. + - 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 => s Γ P a b c i hP _ ha _ hb _ hc _. + - 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 Ξ : fin (S (S _)) -> _ := (X in X ⊢ _ ∈ _) in hc. + 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 => n Γ b A B i hΓ ihΓ hP _ hb [i0 ihb]. + - move => Γ b A B i hP _ hb [i0 ihb]. repeat split => //=; eauto with wt. - have {}hb : funcomp (ren_PTm shift) (scons A Γ) ⊢ ren_PTm shift b ∈ ren_PTm shift (PBind PPi A B) + have {}hb : (cons A Γ) ⊢ ren_PTm shift b ∈ ren_PTm shift (PBind PPi A B) by hauto lq:on use:weakening_wt, Bind_Inv. apply : T_Abs; eauto. - apply : T_App'; eauto; rewrite-/ren_PTm. - by asimpl. + apply : T_App'; eauto; rewrite-/ren_PTm. asimpl. by rewrite subst_scons_id. apply T_Var. sfirstorder use:wff_mutual. + apply here. - hauto lq:on ctrs:Wt. - - move => n Γ A B C hA [i [ihA0 ihA1]] hC [j [ihC0 ihC1]]. + - 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 => n Γ i j hΓ *. exists (S (max i j)). + - 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 => n Γ A0 A1 B0 B1 i hΓ ihΓ hA0 _ hA1 [i0][ih0]ih1 hB[j0][ihB0]ihB1. + - 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 hΓ ihΓ hA1 _ hA0 [i0][ihA0]ihA1 hB[i1][ihB0]ihB1. + - 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 => n Γ A0 A1 B0 B1 _ [i][ih0 ih1]. + - 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 => n Γ A0 A1 B0 B1 _ [i][ih0 ih1]. + - 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 => n Γ a0 a1 A0 A1 B0 B1 /Su_Pi_Proj1 hA1. + - 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' _]. @@ -779,7 +778,7 @@ Proof. 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 => n Γ a0 a1 A0 A1 B0 B1 /Su_Sig_Proj1 hA1. + - 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' _]. @@ -795,23 +794,25 @@ Proof. Unshelve. all: exact 0. Qed. -Lemma Var_Inv n Γ (i : fin n) A : +Lemma Var_Inv Γ (i : nat) B A : Γ ⊢ VarPTm i ∈ A -> - ⊢ Γ /\ Γ ⊢ Γ i ≲ A. + lookup i Γ B -> + ⊢ Γ /\ Γ ⊢ B ≲ A. Proof. move E : (VarPTm i) => u hu. move : i E. - elim : n Γ u A / hu=>//=. - - move => n Γ i hΓ i0 [?]. subst. + elim : Γ u A / hu=>//=. + - move => i Γ A hΓ hi i0 [?]. subst. repeat split => //=. - have h : Γ ⊢ VarPTm i ∈ Γ i by eauto using T_Var. + have ? : A = B by eauto using lookup_deter. subst. + have h : Γ ⊢ VarPTm i ∈ B 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 n m Δ Γ (ξ : fin n -> fin m) (A B : PTm n) u U , +Lemma renaming_su' : forall Δ Γ ξ (A B : PTm) u U , u = ren_PTm ξ A -> U = ren_PTm ξ B -> Γ ⊢ A ≲ B -> @@ -819,23 +820,23 @@ Lemma renaming_su' : forall n m Δ Γ (ξ : fin n -> fin m) (A B : PTm n) u U , Δ ⊢ u ≲ U. Proof. move => > -> ->. hauto l:on use:renaming. Qed. -Lemma weakening_su : forall n Γ (A0 A1 B : PTm n) i, +Lemma weakening_su : forall Γ (A0 A1 B : PTm) i, Γ ⊢ B ∈ PUniv i -> Γ ⊢ A0 ≲ A1 -> - funcomp (ren_PTm shift) (scons B Γ) ⊢ ren_PTm shift A0 ≲ ren_PTm shift A1. + (cons B Γ) ⊢ ren_PTm shift A0 ≲ ren_PTm shift A1. Proof. - move => n Γ A0 A1 B i hB hlt. + move => Γ A0 A1 B i hB hlt. apply : renaming_su'; eauto. apply : Wff_Cons'; eauto. apply : renaming_shift; eauto. Qed. -Lemma regularity_sub0 : forall n Γ (A B : PTm n), Γ ⊢ A ≲ B -> exists i, Γ ⊢ A ∈ PUniv i. +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 n Γ (A0 A1 : PTm n) B0 B1 : +Lemma Su_Pi_Proj2_Var Γ (A0 A1 : PTm) B0 B1 : Γ ⊢ PBind PPi A0 B0 ≲ PBind PPi A1 B1 -> - funcomp (ren_PTm shift) (scons A1 Γ) ⊢ B0 ≲ B1. + cons A1 Γ ⊢ B0 ≲ B1. Proof. move => h. have /Su_Pi_Proj1 h1 := h. @@ -843,15 +844,16 @@ Proof. 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. + apply E_Refl. apply T_Var with (i := var_zero); eauto. sfirstorder use:wff_mutual. - by asimpl. - by asimpl. + apply here. + by asimpl; rewrite subst_scons_id. + by asimpl; rewrite subst_scons_id. Qed. -Lemma Su_Sig_Proj2_Var n Γ (A0 A1 : PTm n) B0 B1 : +Lemma Su_Sig_Proj2_Var Γ (A0 A1 : PTm) B0 B1 : Γ ⊢ PBind PSig A0 B0 ≲ PBind PSig A1 B1 -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊢ B0 ≲ B1. + (cons A0 Γ) ⊢ B0 ≲ B1. Proof. move => h. have /Su_Sig_Proj1 h1 := h. @@ -859,8 +861,9 @@ Proof. 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. + apply E_Refl. apply T_Var with (i := var_zero); eauto. sfirstorder use:wff_mutual. - by asimpl. - by asimpl. + apply here. + by asimpl; rewrite subst_scons_id. + by asimpl; rewrite subst_scons_id. Qed. From fe418c2a785b2779456529d5dca74ce156c5bf1a Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 15:29:50 -0500 Subject: [PATCH 09/51] Fix preservation and broken cases in logrel --- theories/admissible.v | 43 +++++++++++------------------------------ theories/logrel.v | 5 +---- theories/preservation.v | 40 +++++++++++++++++++------------------- theories/soundness.v | 2 +- 4 files changed, 33 insertions(+), 57 deletions(-) diff --git a/theories/admissible.v b/theories/admissible.v index 392e3cf..830ceec 100644 --- a/theories/admissible.v +++ b/theories/admissible.v @@ -1,45 +1,24 @@ -Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax common typing structural. +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 Dependent Inversion wff_inv with (forall n (Γ : fin n -> PTm n), ⊢ Γ) Sort Prop. +Derive Inversion wff_inv with (forall Γ, ⊢ Γ) Sort Prop. -Lemma Wff_Cons_Inv n Γ (A : PTm n) : - ⊢ funcomp (ren_PTm shift) (scons A Γ) -> - ⊢ Γ /\ exists i, Γ ⊢ A ∈ PUniv i. -Proof. - elim /wff_inv => //= _. - move => n0 Γ0 A0 i0 hΓ0 hA0 [? _]. subst. - Equality.simplify_dep_elim. - have h : forall i, (funcomp (ren_PTm shift) (scons A0 Γ0)) i = (funcomp (ren_PTm shift) (scons A Γ)) i by scongruence. - move /(_ var_zero) : (h). - rewrite /funcomp. asimpl. - move /ren_injective. move /(_ ltac:(hauto lq:on rew:off inv:option)). - move => ?. subst. - have : Γ0 = Γ. extensionality i. - move /(_ (Some i)) : h. - rewrite /funcomp. asimpl. - move /ren_injective. move /(_ ltac:(hauto lq:on rew:off inv:option)). - done. - move => ?. subst. sfirstorder. -Qed. - -Lemma T_Abs n Γ (a : PTm (S n)) A B : - funcomp (ren_PTm shift) (scons A Γ) ⊢ a ∈ B -> +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, funcomp (ren_PTm shift) (scons A Γ) ⊢ B ∈ PUniv i by sfirstorder use:regularity. - have hΓ : ⊢ funcomp (ren_PTm shift) (scons A Γ) by sfirstorder use:wff_mutual. - move /Wff_Cons_Inv : hΓ => [hΓ][j]hA. - hauto lq:on rew:off use:T_Bind', typing.T_Abs. + 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 E_Bind n Γ i p (A0 A1 : PTm n) B0 B1 : +Lemma E_Bind Γ i p (A0 A1 : PTm) B0 B1 : Γ ⊢ A0 ≡ A1 ∈ PUniv i -> - funcomp (ren_PTm shift) (scons A0 Γ) ⊢ B0 ≡ B1 ∈ PUniv i -> + (cons A0 Γ) ⊢ B0 ≡ B1 ∈ PUniv i -> Γ ⊢ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv i. Proof. move => h0 h1. @@ -49,7 +28,7 @@ Proof. firstorder. Qed. -Lemma E_App n Γ (b0 b1 a0 a1 : PTm n) A B : +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. @@ -59,7 +38,7 @@ Proof. move : E_App h. by repeat move/[apply]. Qed. -Lemma E_Proj2 n Γ (a b : PTm n) A B : +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. diff --git a/theories/logrel.v b/theories/logrel.v index ae4169c..a479f81 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -1583,7 +1583,7 @@ Lemma SSu_Pi Γ (A0 A1 : PTm ) B0 B1 : cons A0 Γ ⊨ B0 ≲ B1 -> Γ ⊨ PBind PPi A0 B0 ≲ PBind PPi A1 B1. Proof. - move => hΓ hA hB. + 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. @@ -1592,7 +1592,6 @@ Proof. apply : SemWt_SemLEq; last by hauto l:on use:Sub.PiCong. hauto l:on use:ST_Bind'. apply ST_Bind'; eauto. - have hΓ' : ⊨ (cons A1 Γ) by hauto l:on use:SemWff_cons. move => ρ hρ. suff : ρ_ok (cons A0 Γ) ρ by hauto l:on. move : hρ. suff : Γ_sub' (A0 :: Γ) (A1 :: Γ) @@ -1614,8 +1613,6 @@ Proof. apply : SemWt_SemLEq; last by hauto l:on use:Sub.SigCong. 2 : { hauto l:on use:ST_Bind'. } apply ST_Bind'; eauto. - have hΓ' : ⊨ cons A1 Γ by hauto l:on use:SemWff_cons. - have hΓ'' : ⊨ cons A0 Γ by hauto l:on use:SemWff_cons. move => ρ hρ. suff : ρ_ok (cons A1 Γ) ρ by hauto l:on. move : hρ. suff : Γ_sub' (A1 :: Γ) (A0 :: Γ) by hauto l:on. diff --git a/theories/preservation.v b/theories/preservation.v index fe0a920..c8a2106 100644 --- a/theories/preservation.v +++ b/theories/preservation.v @@ -30,12 +30,12 @@ Proof. - hauto lq:on rew:off ctrs:LEq. Qed. -Lemma Proj1_Inv n Γ (a : PTm n) U : +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 : n Γ u U / hu => n //=. + move :a E. elim : Γ u U / hu => //=. - move => Γ a A B ha _ a0 [*]. subst. exists A, B. split => //=. eapply regularity in ha. @@ -45,12 +45,12 @@ Proof. - hauto lq:on rew:off ctrs:LEq. Qed. -Lemma Proj2_Inv n Γ (a : PTm n) U : +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 : n Γ u U / hu => n //=. + move :a E. elim : Γ u U / hu => //=. - move => Γ a A B ha _ a0 [*]. subst. exists A, B. split => //=. have ha' := ha. @@ -62,30 +62,30 @@ Proof. - hauto lq:on rew:off ctrs:LEq. Qed. -Lemma Pair_Inv n Γ (a b : PTm n) U : +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 : n Γ u U / hu => n //=. + 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 Ind_Inv n Γ P (a : PTm n) b c U : +Lemma Ind_Inv Γ P (a : PTm) b c U : Γ ⊢ PInd P a b c ∈ U -> - exists i, funcomp (ren_PTm shift) (scons PNat Γ) ⊢ P ∈ PUniv i /\ + exists i, (cons PNat Γ) ⊢ P ∈ PUniv i /\ Γ ⊢ a ∈ PNat /\ Γ ⊢ b ∈ subst_PTm (scons PZero VarPTm) P /\ - funcomp (ren_PTm shift)(scons P (funcomp (ren_PTm shift) (scons PNat Γ))) ⊢ c ∈ ren_PTm shift (subst_PTm (scons (PSuc (VarPTm var_zero)) (funcomp VarPTm shift) ) 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 : n Γ u U / hu => n //=. + 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. @@ -93,10 +93,10 @@ Proof. - hauto lq:on rew:off ctrs:LEq. Qed. -Lemma E_AppAbs : forall n (a : PTm (S n)) (b : PTm n) (Γ : fin n -> PTm n) (A : PTm n), +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 => n a b Γ A ha. + move => a b Γ A ha. move /App_Inv : ha. move => [A0][B0][ha][hb]hS. move /Abs_Inv : ha => [A1][B1][ha]hS0. @@ -112,10 +112,10 @@ Proof. eauto using T_Conv. Qed. -Lemma E_ProjPair1 : forall n (a b : PTm n) (Γ : fin n -> PTm n) (A : PTm n), +Lemma E_ProjPair1 : forall (a b : PTm) Γ (A : PTm), Γ ⊢ PProj PL (PPair a b) ∈ A -> Γ ⊢ PProj PL (PPair a b) ≡ a ∈ A. Proof. - move => n a b Γ A. + 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. @@ -125,25 +125,25 @@ Proof. apply : E_ProjPair1; eauto. Qed. -Lemma Suc_Inv n Γ (a : PTm n) A : +Lemma Suc_Inv Γ (a : PTm) A : Γ ⊢ PSuc a ∈ A -> Γ ⊢ a ∈ PNat /\ Γ ⊢ PNat ≲ A. Proof. move E : (PSuc a) => u hu. move : a E. - elim : n Γ u A /hu => //=. - - move => n Γ a ha iha a0 [*]. subst. + 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 n Γ (a b : PTm n) A : +Lemma RRed_Eq Γ (a b : PTm) A : Γ ⊢ a ∈ A -> RRed.R a b -> Γ ⊢ a ≡ b ∈ A. Proof. - move => + h. move : Γ A. elim : n a b /h => n. + move => + h. move : Γ A. elim : a b /h. - apply E_AppAbs. - move => p a b Γ A. case : p => //=. @@ -214,7 +214,7 @@ Proof. - hauto lq:on use:Suc_Inv, E_Conv, E_SucCong. Qed. -Theorem subject_reduction n Γ (a b A : PTm n) : +Theorem subject_reduction Γ (a b A : PTm) : Γ ⊢ a ∈ A -> RRed.R a b -> Γ ⊢ b ∈ A. diff --git a/theories/soundness.v b/theories/soundness.v index b11dded..8bfeedf 100644 --- a/theories/soundness.v +++ b/theories/soundness.v @@ -1,4 +1,4 @@ -Require Import Autosubst2.fintype Autosubst2.syntax. +Require Import Autosubst2.unscoped Autosubst2.syntax. Require Import fp_red logrel typing. From Hammer Require Import Tactics. From 3e8ad2c5bcb34072671da791b9abd15b7e83627f Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 15:50:08 -0500 Subject: [PATCH 10/51] Work on the refactoring proof --- theories/algorithmic.v | 249 +++++++++++++++++++---------------------- theories/soundness.v | 10 +- theories/structural.v | 13 +-- 3 files changed, 127 insertions(+), 145 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index 096ec94..a52ac7e 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1,4 +1,4 @@ -Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax +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. @@ -8,7 +8,7 @@ Require Import Coq.Logic.FunctionalExtensionality. Require Import Cdcl.Itauto. Module HRed. - 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) @@ -33,46 +33,46 @@ Module HRed. R a0 a1 -> R (PInd P a0 b c) (PInd P a1 b c). - Lemma ToRRed n (a b : PTm n) : HRed.R a b -> RRed.R a b. + 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 n Γ (a b A : PTm n) : Γ ⊢ a ∈ A -> HRed.R a b -> Γ ⊢ b ∈ A. + Lemma preservation Γ (a b A : PTm) : Γ ⊢ a ∈ A -> HRed.R a b -> Γ ⊢ b ∈ A. Proof. sfirstorder use:subject_reduction, ToRRed. Qed. - Lemma ToEq n Γ (a b : PTm n) A : Γ ⊢ a ∈ A -> HRed.R a b -> Γ ⊢ a ≡ b ∈ A. + 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 n Γ (a b A : PTm n) : Γ ⊢ a ∈ A -> rtc HRed.R a b -> Γ ⊢ b ∈ A. + 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 n Γ (a b : PTm n) A : Γ ⊢ a ∈ A -> rtc HRed.R a b -> Γ ⊢ a ≡ b ∈ A. + 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 n Γ (a : PTm n) A B i : +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 n Γ (a b : PTm n) A B i : +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 n Γ (a b : PTm n) A : +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 n Γ (a b : PTm n) A : +Lemma loreds_embed Γ (a b : PTm ) A : Γ ⊢ a ∈ A -> rtc LoRed.R a b -> Γ ⊢ a ≡ b ∈ A. Proof. move => + h. move : Γ A. @@ -84,25 +84,18 @@ Proof. hauto lq:on ctrs:Eq. Qed. -Lemma T_Bot_Imp n Γ (A : PTm n) : - Γ ⊢ PBot ∈ A -> False. - move E : PBot => u hu. - move : E. - induction hu => //=. -Qed. - -Lemma Zero_Inv n Γ U : - Γ ⊢ @PZero n ∈ U -> +Lemma Zero_Inv Γ U : + Γ ⊢ PZero ∈ U -> Γ ⊢ PNat ≲ U. Proof. move E : PZero => u hu. move : E. - elim : n Γ u U /hu=>//=. + 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 n Γ p (A : PTm n) B C : +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. @@ -140,7 +133,6 @@ Proof. have ? : b = p by hauto l:on use:Sub.bind_inj. subst. eauto. - hauto lq:on use:synsub_to_usub, Sub.bind_univ_noconf. - - hauto lq:on use:regularity, T_Bot_Imp. - move => _ _ /synsub_to_usub [_ [_ h]]. exfalso. apply Sub.nat_bind_noconf in h => //=. - move => h. @@ -158,7 +150,7 @@ Proof. exfalso. move : h2 hne. hauto l:on use:Sub.bind_sne_noconf. Qed. -Lemma Sub_Univ_InvR n (Γ : fin n -> PTm n) i C : +Lemma Sub_Univ_InvR Γ i C : Γ ⊢ PUniv i ≲ C -> exists j k, Γ ⊢ C ≡ PUniv j ∈ PUniv k. Proof. @@ -188,7 +180,6 @@ Proof. - 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 lq:on use:regularity, T_Bot_Imp. - hauto q:on use:synsub_to_usub, Sub.nat_univ_noconf. - move => h. have {}h : Γ ⊢ PZero ∈ PUniv j by hauto l:on use:regularity. @@ -205,7 +196,7 @@ Proof. exfalso. move : h2 hne. hauto l:on use:Sub.univ_sne_noconf. Qed. -Lemma Sub_Bind_InvL n Γ p (A : PTm n) B C : +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. @@ -243,7 +234,6 @@ Proof. 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. - - hauto lq:on use:regularity, T_Bot_Imp. - move => _ _ /synsub_to_usub [_ [_ h]]. exfalso. apply Sub.bind_nat_noconf in h => //=. - move => h. @@ -262,7 +252,7 @@ Proof. hauto l:on use:Sub.sne_bind_noconf. Qed. -Lemma T_Abs_Inv n Γ (a0 a1 : PTm (S n)) U : +Lemma T_Abs_Inv Γ (a0 a1 : PTm) U : Γ ⊢ PAbs a0 ∈ U -> Γ ⊢ PAbs a1 ∈ U -> exists Δ V, Δ ⊢ a0 ∈ V /\ Δ ⊢ a1 ∈ V. @@ -272,7 +262,7 @@ Proof. 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 (funcomp (ren_PTm shift) (scons A2 Γ)), B2. + 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'. @@ -287,15 +277,15 @@ Proof. apply : ctx_eq_subst_one; eauto. Qed. -Lemma T_Univ_Raise n Γ (a : PTm n) i j : +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 n Γ p (A : PTm n) B i : +Lemma Bind_Univ_Inv Γ p (A : PTm) B i : Γ ⊢ PBind p A B ∈ PUniv i -> - Γ ⊢ A ∈ PUniv i /\ funcomp (ren_PTm shift) (scons A Γ) ⊢ B ∈ PUniv i. + Γ ⊢ A ∈ PUniv i /\ (cons A Γ) ⊢ B ∈ PUniv i. Proof. move /Bind_Inv. move => [i0][hA][hB]h. @@ -303,9 +293,9 @@ Proof. sfirstorder use:T_Univ_Raise. Qed. -Lemma Abs_Pi_Inv n Γ (a : PTm (S n)) A B : +Lemma Abs_Pi_Inv Γ (a : PTm) A B : Γ ⊢ PAbs a ∈ PBind PPi A B -> - funcomp (ren_PTm shift) (scons A Γ) ⊢ a ∈ B. + (cons A Γ) ⊢ a ∈ B. Proof. move => h. have [i hi] : exists i, Γ ⊢ PBind PPi A B ∈ PUniv i by hauto use:regularity. @@ -314,15 +304,16 @@ Proof. 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 asimpl. + apply T_Var with (i := var_zero). by eauto using Wff_Cons'. + apply here. rewrite -/ren_PTm. - by asimpl. + by asimpl; rewrite subst_scons_id. rewrite -/ren_PTm. - by asimpl. + by asimpl; rewrite subst_scons_id. Qed. -Lemma Pair_Sig_Inv n Γ (a b : PTm n) A B : +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. @@ -345,7 +336,7 @@ Qed. Reserved Notation "a ∼ b" (at level 70). Reserved Notation "a ↔ b" (at level 70). Reserved Notation "a ⇔ b" (at level 70). -Inductive CoqEq {n} : PTm n -> PTm n -> Prop := +Inductive CoqEq : PTm -> PTm -> Prop := | CE_ZeroZero : PZero ↔ PZero @@ -409,7 +400,7 @@ Inductive CoqEq {n} : PTm n -> PTm n -> Prop := a0 ∼ a1 -> a0 ↔ a1 -with CoqEq_Neu {n} : PTm n -> PTm n -> Prop := +with CoqEq_Neu : PTm -> PTm -> Prop := | CE_VarCong i : (* -------------------------- *) VarPTm i ∼ VarPTm i @@ -439,7 +430,7 @@ with CoqEq_Neu {n} : PTm n -> PTm n -> Prop := (* ----------------------------------- *) PInd P0 u0 b0 c0 ∼ PInd P1 u1 b1 c1 -with CoqEq_R {n} : PTm n -> PTm n -> Prop := +with CoqEq_R : PTm -> PTm -> Prop := | CE_HRed a a' b b' : rtc HRed.R a a' -> rtc HRed.R b b' -> @@ -448,7 +439,7 @@ with CoqEq_R {n} : PTm n -> PTm n -> Prop := 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 n (a a' b : PTm n) : +Lemma CE_HRedL (a a' b : PTm) : HRed.R a a' -> a' ⇔ b -> a ⇔ b. @@ -463,27 +454,28 @@ Scheme Combined Scheme coqeq_mutual from coqeq_neu_ind, coqeq_ind, coqeq_r_ind. -Lemma coqeq_symmetric_mutual : forall n, - (forall (a b : PTm n), a ∼ b -> b ∼ a) /\ - (forall (a b : PTm n), a ↔ b -> b ↔ a) /\ - (forall (a b : PTm n), a ⇔ b -> b ⇔ a). +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 n, - (forall (a b : PTm n), a ∼ b -> forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> exists C, +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 n), a ↔ b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> Γ ⊢ a ≡ b ∈ A) /\ - (forall (a b : PTm n), 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) /\ + (forall (a b : PTm ), a ⇔ b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> Γ ⊢ a ≡ b ∈ A). Proof. move => [:hAppL hPairL]. apply coqeq_mutual. - - move => n i Γ A B hi0 hi1. - move /Var_Inv : hi0 => [hΓ h0]. - move /Var_Inv : hi1 => [_ h1]. - exists (Γ i). + - 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 => n [] u0 u1 hu0 hu1 hu ihu Γ A B hu0' hu1'. + - move => [] u0 u1 hu0 hu1 hu ihu Γ A B hu0' hu1'. + move /Proj1_Inv : hu0'. move => [A0][B0][hu0']hu0''. move /Proj1_Inv : hu1'. @@ -517,7 +509,7 @@ Proof. apply : Su_Sig_Proj2; eauto. apply : E_Proj1; eauto. apply : E_Proj2; eauto. - - move => n u0 u1 a0 a1 neu0 neu1 hu ihu ha iha Γ A B wta0 wta1. + - 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]. @@ -539,13 +531,13 @@ Proof. 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} => n P0 P1 u0 u1 b0 b1 c0 c1 neu0 neu1 hP ihP hu ihu hb ihb hc ihc Γ A B. + - 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Γ' : ⊢ funcomp (ren_PTm shift) (scons PNat Γ) by hauto lq:on use:Wff_Cons', T_Nat'. + 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. @@ -567,17 +559,17 @@ Proof. 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. by apply T_Var. + 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 => n a b ha iha Γ A h0 h1. + - 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 qauto l:on use:Wff_Cons_Inv, wff_mutual. - have [k ?] : exists j, Γ ⊢ A1 ∈ PUniv j by qauto l:on use:Wff_Cons_Inv, wff_mutual. + 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. @@ -591,7 +583,7 @@ Proof. apply : T_Conv; eauto. eapply ctx_eq_subst_one with (A0 := A1); eauto. - abstract : hAppL. - move => n a u hneu ha iha Γ A wta wtu. + 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. @@ -603,7 +595,6 @@ Proof. 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. - sfirstorder use:wff_mutual. hauto l:on use:regularity. apply T_Conv with (A := A);eauto. eauto using Su_Eq. @@ -616,19 +607,18 @@ Proof. apply : T_Conv; eauto. eapply ctx_eq_subst_one with (A0 := A0); eauto. sfirstorder use:Su_Pi_Proj1. - - (* move /Su_Pi_Proj2_Var in hPidup. *) - (* apply : T_Conv; eauto. *) - eapply T_App' with (A := ren_PTm shift A2) (B := ren_PTm (upRen_PTm_PTm shift) B2). by asimpl. + 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 => n a u hu ha iha Γ A hu0 ha0. + - 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} n a0 a1 b0 b1 ha iha hb ihb Γ A. + - 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. @@ -654,7 +644,7 @@ Proof. - move => {hAppL}. abstract : hPairL. move => {hAppL}. - move => n a0 a1 u neu h0 ih0 h1 ih1 Γ A ha hu. + 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. @@ -683,7 +673,7 @@ Proof. move => *. apply E_Symmetric. apply : hPairL; sfirstorder use:coqeq_symmetric_mutual, E_Symmetric. - sfirstorder use:E_Refl. - - move => {hAppL hPairL} n p A0 A1 B0 B1 hA ihA hB ihB Γ A hA0 hA1. + - 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 @@ -703,23 +693,23 @@ Proof. move : weakening_su hjk hA0. by repeat move/[apply]. - hauto lq:on ctrs:Eq,LEq,Wt. - hauto lq:on ctrs:Eq,LEq,Wt. - - move => n a a' b b' ha hb hab ihab Γ A ha0 hb0. + - 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 algo_metric {n} k (a b : PTm n) := +Definition algo_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 /\ EJoin.R va vb /\ size_PTm va + size_PTm vb + i + j <= k. -Lemma ne_hne n (a : PTm n) : ne a -> ishne a. +Lemma ne_hne (a : PTm) : ne a -> ishne a. Proof. elim : a => //=; sfirstorder b:on. Qed. -Lemma hf_hred_lored n (a b : PTm n) : +Lemma hf_hred_lored (a b : PTm) : ~~ ishf a -> LoRed.R a b -> HRed.R a b \/ ishne a. Proof. - move => + h. elim : n a b/ h=>//=. + move => + h. elim : a b/ h=>//=. - hauto l:on use:HRed.AppAbs. - hauto l:on use:HRed.ProjPair. - hauto lq:on ctrs:HRed.R. @@ -733,7 +723,7 @@ Proof. - hauto lq:on use:ne_hne. Qed. -Lemma algo_metric_case n k (a b : PTm n) : +Lemma algo_metric_case k (a b : PTm) : algo_metric k a b -> (ishf a \/ ishne a) \/ exists k' a', HRed.R a a' /\ algo_metric k' a' b /\ k' < k. Proof. @@ -761,28 +751,21 @@ Proof. + sfirstorder use:ne_hne. Qed. -Lemma algo_metric_sym n k (a b : PTm n) : +Lemma algo_metric_sym k (a b : PTm) : algo_metric k a b -> algo_metric k b a. Proof. hauto lq:on unfold:algo_metric solve+:lia. Qed. -Lemma hred_hne n (a b : PTm n) : +Lemma hred_hne (a b : PTm) : HRed.R a b -> ishne a -> False. Proof. induction 1; sfirstorder. Qed. -Lemma hf_not_hne n (a : PTm n) : +Lemma hf_not_hne (a : PTm) : ishf a -> ishne a -> False. Proof. case : a => //=. Qed. -(* Lemma algo_metric_hf_case n Γ k a b (A : PTm n) : *) -(* Γ ⊢ a ∈ A -> *) -(* Γ ⊢ b ∈ A -> *) -(* algo_metric k a b -> ishf a -> ishf b -> *) -(* (exists a' b' k', a = PAbs a' /\ b = PAbs b' /\ algo_metric k' a' b' /\ k' < k) \/ *) -(* (exists a0' a1' b0' b1' ka kb, a = PPair a0' a1' /\ b = PPair b0' b1' /\ algo_metric ka a0' b0' /\ algo_metric ) *) - -Lemma T_AbsPair_Imp n Γ a (b0 b1 : PTm n) A : +Lemma T_AbsPair_Imp Γ a (b0 b1 : PTm) A : Γ ⊢ PAbs a ∈ A -> Γ ⊢ PPair b0 b1 ∈ A -> False. @@ -794,7 +777,7 @@ Proof. clear. move /synsub_to_usub. hauto l:on use:Sub.bind_inj. Qed. -Lemma T_AbsZero_Imp n Γ a (A : PTm n) : +Lemma T_AbsZero_Imp Γ a (A : PTm) : Γ ⊢ PAbs a ∈ A -> Γ ⊢ PZero ∈ A -> False. @@ -806,7 +789,7 @@ Proof. clear. hauto lq:on use:synsub_to_usub, Sub.bind_nat_noconf. Qed. -Lemma T_AbsSuc_Imp n Γ a b (A : PTm n) : +Lemma T_AbsSuc_Imp Γ a b (A : PTm) : Γ ⊢ PAbs a ∈ A -> Γ ⊢ PSuc b ∈ A -> False. @@ -818,18 +801,18 @@ Proof. hauto lq:on use:Sub.bind_nat_noconf, synsub_to_usub. Qed. -Lemma Nat_Inv n Γ A: - Γ ⊢ @PNat n ∈ A -> +Lemma Nat_Inv Γ A: + Γ ⊢ PNat ∈ A -> exists i, Γ ⊢ PUniv i ≲ A. Proof. move E : PNat => u hu. move : E. - elim : n Γ u A / hu=>//=. + elim : Γ u A / hu=>//=. - hauto lq:on use:E_Refl, T_Univ, Su_Eq. - hauto lq:on ctrs:LEq. Qed. -Lemma T_AbsNat_Imp n Γ a (A : PTm n) : +Lemma T_AbsNat_Imp Γ a (A : PTm ) : Γ ⊢ PAbs a ∈ A -> Γ ⊢ PNat ∈ A -> False. @@ -841,7 +824,7 @@ Proof. hauto lq:on use:Sub.bind_univ_noconf, synsub_to_usub. Qed. -Lemma T_PairBind_Imp n Γ (a0 a1 : PTm n) p A0 B0 U : +Lemma T_PairBind_Imp Γ (a0 a1 : PTm ) p A0 B0 U : Γ ⊢ PPair a0 a1 ∈ U -> Γ ⊢ PBind p A0 B0 ∈ U -> False. @@ -853,7 +836,7 @@ Proof. clear. move /synsub_to_usub. hauto l:on use:Sub.bind_univ_noconf. Qed. -Lemma T_PairNat_Imp n Γ (a0 a1 : PTm n) U : +Lemma T_PairNat_Imp Γ (a0 a1 : PTm) U : Γ ⊢ PPair a0 a1 ∈ U -> Γ ⊢ PNat ∈ U -> False. @@ -864,7 +847,7 @@ Proof. clear. move /synsub_to_usub. hauto l:on use:Sub.bind_univ_noconf. Qed. -Lemma T_PairZero_Imp n Γ (a0 a1 : PTm n) U : +Lemma T_PairZero_Imp Γ (a0 a1 : PTm ) U : Γ ⊢ PPair a0 a1 ∈ U -> Γ ⊢ PZero ∈ U -> False. @@ -875,7 +858,7 @@ Proof. clear. move /synsub_to_usub. hauto l:on use:Sub.bind_nat_noconf. Qed. -Lemma T_PairSuc_Imp n Γ (a0 a1 : PTm n) b U : +Lemma T_PairSuc_Imp Γ (a0 a1 : PTm ) b U : Γ ⊢ PPair a0 a1 ∈ U -> Γ ⊢ PSuc b ∈ U -> False. @@ -886,17 +869,17 @@ Proof. clear. move /synsub_to_usub. hauto l:on use:Sub.bind_nat_noconf. Qed. -Lemma Univ_Inv n Γ i U : - Γ ⊢ @PUniv n i ∈ U -> +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 : n Γ u U / hu => n //=. + 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 n Γ (a0 a1 : PTm n) i U : +Lemma T_PairUniv_Imp Γ (a0 a1 : PTm) i U : Γ ⊢ PPair a0 a1 ∈ U -> Γ ⊢ PUniv i ∈ U -> False. @@ -909,7 +892,7 @@ Proof. hauto lq:on use:Sub.bind_univ_noconf. Qed. -Lemma T_AbsUniv_Imp n Γ a i (A : PTm n) : +Lemma T_AbsUniv_Imp Γ a i (A : PTm) : Γ ⊢ PAbs a ∈ A -> Γ ⊢ PUniv i ∈ A -> False. @@ -922,19 +905,19 @@ Proof. hauto lq:on use:Sub.bind_univ_noconf. Qed. -Lemma T_AbsUniv_Imp' n Γ (a : PTm (S n)) i : +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_PairUniv_Imp' n Γ (a b : PTm n) i : +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 n Γ a p A0 B0 (U : PTm n) : +Lemma T_AbsBind_Imp Γ a p A0 B0 (U : PTm ) : Γ ⊢ PAbs a ∈ U -> Γ ⊢ PBind p A0 B0 ∈ U -> False. @@ -947,7 +930,7 @@ Proof. hauto lq:on use:Sub.bind_univ_noconf. Qed. -Lemma lored_nsteps_suc_inv k n (a : PTm n) b : +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. @@ -957,7 +940,7 @@ Proof. - scrush ctrs:nsteps inv:LoRed.R. Qed. -Lemma lored_nsteps_abs_inv k n (a : PTm (S n)) b : +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. @@ -967,15 +950,15 @@ Proof. - scrush ctrs:nsteps inv:LoRed.R. Qed. -Lemma lored_hne_preservation n (a b : PTm n) : +Lemma lored_hne_preservation (a b : PTm) : LoRed.R a b -> ishne a -> ishne b. Proof. induction 1; sfirstorder. Qed. -Lemma loreds_hne_preservation n (a b : PTm n) : +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 n p (a0 : PTm n) b0 C : +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 /\ @@ -995,7 +978,7 @@ Proof. exists i,(S j),a1,b1. sauto lq:on solve+:lia. Qed. -Lemma lored_nsteps_ind_inv k n P0 (a0 : PTm n) b0 c0 U : +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, @@ -1026,7 +1009,7 @@ Proof. exists iP, ia, ib, (S ic). sauto lq:on solve+:lia. Qed. -Lemma lored_nsteps_app_inv k n (a0 b0 C : PTm n) : +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, @@ -1050,7 +1033,7 @@ Proof. exists i, (S j), a1, b1. sauto lq:on solve+:lia. Qed. -Lemma lored_nsteps_proj_inv k n p (a0 C : PTm n) : +Lemma lored_nsteps_proj_inv k p (a0 C : PTm) : nsteps LoRed.R k (PProj p a0) C -> ishne a0 -> exists i a1, @@ -1070,7 +1053,7 @@ Proof. exists (S i), a1. hauto lq:on ctrs:nsteps solve+:lia. Qed. -Lemma algo_metric_proj n k p0 p1 (a0 a1 : PTm n) : +Lemma algo_metric_proj k p0 p1 (a0 a1 : PTm) : algo_metric k (PProj p0 a0) (PProj p1 a1) -> ishne a0 -> ishne a1 -> @@ -1092,7 +1075,7 @@ Proof. Qed. -Lemma lored_nsteps_app_cong k n (a0 a1 b : PTm n) : +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). @@ -1106,7 +1089,7 @@ Lemma lored_nsteps_app_cong k n (a0 a1 b : PTm n) : apply ih. sfirstorder use:lored_hne_preservation. Qed. -Lemma lored_nsteps_proj_cong k n p (a0 a1 : PTm n) : +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). @@ -1119,7 +1102,7 @@ Lemma lored_nsteps_proj_cong k n p (a0 a1 : PTm n) : apply ih. sfirstorder use:lored_hne_preservation. Qed. -Lemma lored_nsteps_pair_inv k n (a0 b0 C : PTm n) : +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 /\ @@ -1139,7 +1122,7 @@ Lemma lored_nsteps_pair_inv k n (a0 b0 C : PTm n) : exists i, (S j), a1, b1. sauto lq:on solve+:lia. Qed. -Lemma algo_metric_join n k (a b : PTm n) : +Lemma algo_metric_join k (a b : PTm ) : algo_metric k a b -> DJoin.R a b. rewrite /algo_metric. @@ -1152,7 +1135,7 @@ Lemma algo_metric_join n k (a b : PTm n) : rewrite /DJoin.R. exists v. sfirstorder use:@relations.rtc_transitive. Qed. -Lemma algo_metric_pair n k (a0 b0 a1 b1 : PTm n) : +Lemma algo_metric_pair k (a0 b0 a1 b1 : PTm) : SN (PPair a0 b0) -> SN (PPair a1 b1) -> algo_metric k (PPair a0 b0) (PPair a1 b1) -> @@ -1170,18 +1153,18 @@ Lemma algo_metric_pair n k (a0 b0 a1 b1 : PTm n) : hauto l:on use:DJoin.ejoin_pair_inj. Qed. -Lemma hne_nf_ne n (a : PTm n) : +Lemma hne_nf_ne (a : PTm ) : ishne a -> nf a -> ne a. Proof. case : a => //=. Qed. -Lemma lored_nsteps_renaming k n m (a b : PTm n) (ξ : fin n -> fin m) : +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 algo_metric_neu_abs n k (a0 : PTm (S n)) u : +Lemma algo_metric_neu_abs k (a0 : PTm) u : algo_metric k u (PAbs a0) -> ishne u -> exists j, j < k /\ algo_metric j (PApp (ren_PTm shift u) (VarPTm var_zero)) a0. @@ -1203,7 +1186,7 @@ Proof. simpl in *. rewrite size_PTm_ren. lia. Qed. -Lemma algo_metric_neu_pair n k (a0 b0 : PTm n) u : +Lemma algo_metric_neu_pair k (a0 b0 : PTm) u : algo_metric k u (PPair a0 b0) -> ishne u -> exists j, j < k /\ algo_metric j (PProj PL u) a0 /\ algo_metric j (PProj PR u) b0. @@ -1224,7 +1207,7 @@ Proof. eapply DJoin.ejoin_pair_inj; hauto qb:on ctrs:rtc, ERed.R. Qed. -Lemma algo_metric_ind n k P0 (a0 : PTm n) b0 c0 P1 a1 b1 c1 : +Lemma algo_metric_ind k P0 (a0 : PTm ) b0 c0 P1 a1 b1 c1 : algo_metric k (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) -> ishne a0 -> ishne a1 -> @@ -1242,7 +1225,7 @@ Proof. hauto lq:on rew:off use:ne_nf b:on solve+:lia. Qed. -Lemma algo_metric_app n k (a0 b0 a1 b1 : PTm n) : +Lemma algo_metric_app k (a0 b0 a1 b1 : PTm) : algo_metric k (PApp a0 b0) (PApp a1 b1) -> ishne a0 -> ishne a1 -> @@ -1271,7 +1254,7 @@ Proof. repeat split => //=; sfirstorder b:on use:ne_nf. Qed. -Lemma algo_metric_suc n k (a0 a1 : PTm n) : +Lemma algo_metric_suc k (a0 a1 : PTm) : algo_metric k (PSuc a0) (PSuc a1) -> exists j, j < k /\ algo_metric j a0 a1. Proof. @@ -1286,7 +1269,7 @@ Proof. hauto lq:on rew:off use:EJoin.suc_inj solve+:lia. Qed. -Lemma algo_metric_bind n k p0 (A0 : PTm n) B0 p1 A1 B1 : +Lemma algo_metric_bind k p0 (A0 : PTm ) B0 p1 A1 B1 : algo_metric k (PBind p0 A0 B0) (PBind p1 A1 B1) -> p0 = p1 /\ exists j, j < k /\ algo_metric j A0 A1 /\ algo_metric j B0 B1. Proof. @@ -1306,15 +1289,15 @@ Proof. Qed. -Lemma coqeq_complete' n k (a b : PTm n) : +Lemma coqeq_complete' k (a b : PTm ) : algo_metric k 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). Proof. - move : k n a b. + move : k a b. elim /Wf_nat.lt_wf_ind. - move => n ih. - move => k a b /[dup] h /algo_metric_case. move : k a b h => [:hstepL]. + move => k ih. + move => a b /[dup] h /algo_metric_case. move : k a b h => [:hstepL]. move => k a b h. (* Cases where a and b can take steps *) case; cycle 1. diff --git a/theories/soundness.v b/theories/soundness.v index 8bfeedf..7f86852 100644 --- a/theories/soundness.v +++ b/theories/soundness.v @@ -3,13 +3,13 @@ Require Import fp_red logrel typing. From Hammer Require Import Tactics. Theorem fundamental_theorem : - (forall n (Γ : fin n -> PTm n), ⊢ Γ -> ⊨ Γ) /\ - (forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> Γ ⊨ a ∈ A) /\ - (forall n Γ (a b A : PTm n), Γ ⊢ a ≡ b ∈ A -> Γ ⊨ a ≡ b ∈ A) /\ - (forall n Γ (a b : PTm n), Γ ⊢ a ≲ b -> Γ ⊨ a ≲ b). + (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; [hauto l:on use:SE_Pair]. Unshelve. all : exact 0. Qed. -Lemma synsub_to_usub : forall n Γ (a b : PTm n), Γ ⊢ a ≲ b -> SN a /\ SN b /\ Sub.R a b. +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 index 10d6583..ccb4c6f 100644 --- a/theories/structural.v +++ b/theories/structural.v @@ -794,18 +794,17 @@ Proof. Unshelve. all: exact 0. Qed. -Lemma Var_Inv Γ (i : nat) B A : +Lemma Var_Inv Γ (i : nat) A : Γ ⊢ VarPTm i ∈ A -> - lookup i Γ B -> - ⊢ Γ /\ Γ ⊢ B ≲ 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. - repeat split => //=. - have ? : A = B by eauto using lookup_deter. subst. - have h : Γ ⊢ VarPTm i ∈ B by eauto using T_Var. + - 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. From 3a17548a7d0e7cfdc1a9e3f2d29e760ce7d0cbca Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 16:01:28 -0500 Subject: [PATCH 11/51] Minor --- theories/algorithmic.v | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index a52ac7e..bd0233c 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1296,18 +1296,18 @@ Lemma coqeq_complete' k (a b : PTm ) : Proof. move : k a b. elim /Wf_nat.lt_wf_ind. - move => k ih. - move => a b /[dup] h /algo_metric_case. move : k a b h => [:hstepL]. - move => k a b h. + move => n ih. + move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. + move => a b h. (* Cases where a and b can take steps *) case; cycle 1. - move : k a b h. + move : ih a b h. abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. move /algo_metric_sym /algo_metric_case : (h). case; cycle 1. move {ih}. move /algo_metric_sym : h. - move : hstepL => /[apply]. - hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. + move : hstepL; repeat move /[apply]. + best use:coqeq_symmetric_mutual, algo_metric_sym. (* Cases where a and b can't take wh steps *) move {hstepL}. move : k a b h. move => [:hnfneu]. From 5ac3b21331ff4d6b53c73e43944acb01fd12d589 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 21:09:03 -0500 Subject: [PATCH 12/51] Refactor the correctness proof of coquand's algorithm --- theories/algorithmic.v | 114 +++++++++++++++++++---------------------- 1 file changed, 54 insertions(+), 60 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index bd0233c..787adb1 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1305,13 +1305,15 @@ Proof. abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. move /algo_metric_sym /algo_metric_case : (h). case; cycle 1. - move {ih}. move /algo_metric_sym : h. - move : hstepL; repeat move /[apply]. - best use:coqeq_symmetric_mutual, algo_metric_sym. + move /algo_metric_sym : h. + move : hstepL ih => /[apply]/[apply]. + repeat move /[apply]. + move => hstepL. + hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. (* Cases where a and b can't take wh steps *) move {hstepL}. - move : k a b h. move => [:hnfneu]. - move => k a b h. + move : a b h. move => [:hnfneu]. + move => a b h. case => fb; case => fa. - split; last by sfirstorder use:hf_not_hne. move {hnfneu}. @@ -1397,11 +1399,9 @@ Proof. by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. - have {}hB0 : funcomp (ren_PTm shift) (scons A0 Γ) ⊢ - B0 ∈ PUniv (max i0 i1) + have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) by hauto lq:on use:T_Univ_Raise solve+:lia. - have {}hB1 : funcomp (ren_PTm shift) (scons A1 Γ) ⊢ - B1 ∈ PUniv (max i0 i1) + have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) by hauto lq:on use:T_Univ_Raise solve+:lia. have ihA : A0 ⇔ A1 by hauto l:on. @@ -1477,8 +1477,7 @@ Proof. move : ih h0 h2;do!move/[apply]. move => h. apply : CE_HRed; eauto using rtc_refl. by constructor. - - move : k a b h fb fa. abstract : hnfneu. - move => k. + - move : a b h fb fa. abstract : hnfneu. move => + b. case : b => //=. (* NeuAbs *) @@ -1491,14 +1490,14 @@ Proof. by hauto l:on use:regularity. have {i} [j {}hE] : exists j, Γ ⊢ A2 ∈ PUniv j by qauto l:on use:Bind_Inv. - have hΓ : ⊢ funcomp (ren_PTm shift) (scons A2 Γ) by eauto using Wff_Cons'. - set Δ := funcomp _ _ in hΓ. + 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. - by apply T_Var. - rewrite -/ren_PTm. by asimpl. + apply T_Var; eauto using here. + rewrite -/ren_PTm. by asimpl; rewrite subst_scons_id. move /Abs_Pi_Inv in ha. move /algo_metric_neu_abs /(_ nea) : halg. move => [j0][hj0]halg. @@ -1542,7 +1541,6 @@ Proof. hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. * move => >/algo_metric_join. clear. hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. - * sfirstorder use:T_Bot_Imp. * move => >/algo_metric_join. clear. move => h _ h2. exfalso. hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. @@ -1552,27 +1550,28 @@ Proof. * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. - * sfirstorder use:T_Bot_Imp. * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. - move {ih}. move /algo_metric_sym in h. qauto l:on use:coqeq_symmetric_mutual. - move {hnfneu}. - (* Clear out some trivial cases *) - suff : (forall (Γ : fin k -> PTm k) (A B : PTm k), Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C : PTm k, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). + suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). move => h0. split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. by firstorder. case : a h fb fa => //=. + case : b => //=; move => > /algo_metric_join. - * move /DJoin.var_inj => ?. subst. qauto l:on use:Var_Inv, T_Var,CE_VarCong. + * move /DJoin.var_inj => i _ _. subst. + move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. + move /Var_Inv => [_ [C0 [h2 h3]]]. + have ? : B0 = C0 by eauto using lookup_deter. subst. + sfirstorder use:T_Var. * clear => ? ? _. exfalso. hauto l:on use:REReds.var_inv, REReds.hne_app_inv. * clear => ? ? _. exfalso. hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. - * sfirstorder use:T_Bot_Imp. * clear => ? ? _. exfalso. hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. + case : b => //=; @@ -1629,7 +1628,6 @@ Proof. sfirstorder use:bind_inst. * clear => ? ? ?. exfalso. hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. - * sfirstorder use:T_Bot_Imp. * clear => ? ? ?. exfalso. hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. + case : b => //=. @@ -1691,10 +1689,8 @@ Proof. move /E_Symmetric in haE. move /regularity_sub0 in hSu21. sfirstorder use:bind_inst. - * sfirstorder use:T_Bot_Imp. * move => > /algo_metric_join; clear => ? ? ?. exfalso. hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. - + sfirstorder use:T_Bot_Imp. (* ind ind case *) + move => P a0 b0 c0. case : b => //=; @@ -1705,7 +1701,6 @@ Proof. * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. - * sfirstorder use:T_Bot_Imp. * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. move /(_ h1 h0). move => [j][hj][hP][ha][hb]hc Γ A B hL hR. @@ -1716,7 +1711,7 @@ Proof. move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. have {}ihP : P ⇔ P1 by qauto l:on. - set Δ := funcomp _ _ in wtP0, wtP1, wtc0, wtc1. + set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) by hauto l:on use:coqeq_sound_mutual. @@ -1730,7 +1725,7 @@ Proof. have {}ihb : b0 ⇔ b1 by hauto l:on. have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. set T := ren_PTm shift _ in wtc0. - have : funcomp (ren_PTm shift) (scons P Δ) ⊢ c1 ∈ T. + have : (cons P Δ) ⊢ c1 ∈ T. apply : T_Conv; eauto. apply : ctx_eq_subst_one; eauto with wt. apply : Su_Eq; eauto. subst T. apply : weakening_su; eauto. @@ -1738,9 +1733,8 @@ Proof. 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. - apply : renaming_shift; eauto. by apply morphing_id. - apply T_Suc. by apply T_Var. subst T => {}wtc1. + 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. @@ -1754,11 +1748,11 @@ Proof. move : hEInd. clear. hauto l:on use:regularity. Qed. -Lemma coqeq_sound : forall n Γ (a b : PTm n) A, +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 coqeq_complete n Γ (a b A : PTm n) : +Lemma coqeq_complete Γ (a b A : PTm) : Γ ⊢ a ≡ b ∈ A -> a ⇔ b. Proof. move => h. @@ -1766,7 +1760,7 @@ Proof. eapply fundamental_theorem in h. move /logrel.SemEq_SN_Join : h. move => h. - have : exists va vb : PTm n, + have : exists va vb : PTm, rtc LoRed.R a va /\ rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb by hauto l:on use:DJoin.standardization_lo. @@ -1780,7 +1774,7 @@ Qed. Reserved Notation "a ≪ b" (at level 70). Reserved Notation "a ⋖ b" (at level 70). -Inductive CoqLEq {n} : PTm n -> PTm n -> Prop := +Inductive CoqLEq : PTm -> PTm -> Prop := | CLE_UnivCong i j : i <= j -> (* -------------------------- *) @@ -1805,7 +1799,7 @@ Inductive CoqLEq {n} : PTm n -> PTm n -> Prop := a0 ∼ a1 -> a0 ⋖ a1 -with CoqLEq_R {n} : PTm n -> PTm n -> Prop := +with CoqLEq_R : PTm -> PTm -> Prop := | CLE_HRed a a' b b' : rtc HRed.R a a' -> rtc HRed.R b b' -> @@ -1819,10 +1813,10 @@ Scheme coqleq_ind := Induction for CoqLEq Sort Prop Combined Scheme coqleq_mutual from coqleq_ind, coqleq_r_ind. -Definition salgo_metric {n} k (a b : PTm n) := +Definition salgo_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 /\ ESub.R va vb /\ size_PTm va + size_PTm vb + i + j <= k. -Lemma salgo_metric_algo_metric n k (a b : PTm n) : +Lemma salgo_metric_algo_metric k (a b : PTm) : ishne a \/ ishne b -> salgo_metric k a b -> algo_metric k a b. @@ -1840,13 +1834,13 @@ Proof. hauto lq:on use:Sub1.hne_refl. Qed. -Lemma coqleq_sound_mutual : forall n, - (forall (a b : PTm n), a ⋖ b -> forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> Γ ⊢ a ≲ b ) /\ - (forall (a b : PTm n), a ≪ b -> forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> Γ ⊢ a ≲ b ). +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 => n A0 A1 B0 B1 hA ihA hB ihB Γ i. + - 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. @@ -1854,7 +1848,7 @@ Proof. 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 => n A0 A1 B0 B1 hA ihA hB ihB Γ i. + - 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. @@ -1864,14 +1858,14 @@ Proof. 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 => n a a' b b' ? ? ? ih Γ i ha hb. + - 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 salgo_metric_case n k (a b : PTm n) : +Lemma salgo_metric_case k (a b : PTm ) : salgo_metric k a b -> (ishf a \/ ishne a) \/ exists k' a', HRed.R a a' /\ salgo_metric k' a' b /\ k' < k. Proof. @@ -1899,7 +1893,7 @@ Proof. + sfirstorder use:ne_hne. Qed. -Lemma CLE_HRedL n (a a' b : PTm n) : +Lemma CLE_HRedL (a a' b : PTm ) : HRed.R a a' -> a' ≪ b -> a ≪ b. @@ -1907,7 +1901,7 @@ Proof. hauto lq:on ctrs:rtc, CoqLEq_R inv:CoqLEq_R. Qed. -Lemma CLE_HRedR n (a a' b : PTm n) : +Lemma CLE_HRedR (a a' b : PTm) : HRed.R a a' -> b ≪ a' -> b ≪ a. @@ -1916,7 +1910,7 @@ Proof. Qed. -Lemma algo_metric_caseR n k (a b : PTm n) : +Lemma algo_metric_caseR k (a b : PTm) : salgo_metric k a b -> (ishf b \/ ishne b) \/ exists k' b', HRed.R b b' /\ salgo_metric k' a b' /\ k' < k. Proof. @@ -1944,7 +1938,7 @@ Proof. + sfirstorder use:ne_hne. Qed. -Lemma salgo_metric_sub n k (a b : PTm n) : +Lemma salgo_metric_sub k (a b : PTm) : salgo_metric k a b -> Sub.R a b. Proof. @@ -1958,7 +1952,7 @@ Proof. rewrite /Sub.R. exists va', vb'. sfirstorder use:@relations.rtc_transitive. Qed. -Lemma salgo_metric_pi n k (A0 : PTm n) B0 A1 B1 : +Lemma salgo_metric_pi k (A0 : PTm) B0 A1 B1 : salgo_metric k (PBind PPi A0 B0) (PBind PPi A1 B1) -> exists j, j < k /\ salgo_metric j A1 A0 /\ salgo_metric j B0 B1. Proof. @@ -1971,7 +1965,7 @@ Proof. hauto qb:on solve+:lia. Qed. -Lemma salgo_metric_sig n k (A0 : PTm n) B0 A1 B1 : +Lemma salgo_metric_sig k (A0 : PTm) B0 A1 B1 : salgo_metric k (PBind PSig A0 B0) (PBind PSig A1 B1) -> exists j, j < k /\ salgo_metric j A0 A1 /\ salgo_metric j B0 B1. Proof. @@ -1984,16 +1978,16 @@ Proof. hauto qb:on solve+:lia. Qed. -Lemma coqleq_complete' n k (a b : PTm n) : +Lemma coqleq_complete' k (a b : PTm ) : salgo_metric k a b -> (forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> a ≪ b). Proof. - move : k n a b. + move : k a b. elim /Wf_nat.lt_wf_ind. move => n ih. - move => k a b /[dup] h /salgo_metric_case. + move => a b /[dup] h /salgo_metric_case. (* Cases where a and b can take steps *) case; cycle 1. - move : k a b h. + move : a b h. qauto l:on use:HRed.preservation, CLE_HRedL, hred_hne. case /algo_metric_caseR : (h); cycle 1. qauto l:on use:HRed.preservation, CLE_HRedR, hred_hne. @@ -2013,7 +2007,7 @@ Proof. have ihA : A0 ≪ A1 by hauto l:on. econstructor; eauto using E_Refl; constructor=> //. have ihA' : Γ ⊢ A0 ≲ A1 by hauto l:on use:coqleq_sound_mutual. - suff : funcomp (ren_PTm shift) (scons A0 Γ) ⊢ B1 ∈ PUniv i + suff : (cons A0 Γ) ⊢ B1 ∈ PUniv i by hauto l:on. eauto using ctx_eq_subst_one. ** move /salgo_metric_sig. @@ -2022,7 +2016,7 @@ Proof. have ihA : A1 ≪ A0 by hauto l:on. econstructor; eauto using E_Refl; constructor=> //. have ihA' : Γ ⊢ A1 ≲ A0 by hauto l:on use:coqleq_sound_mutual. - suff : funcomp (ren_PTm shift) (scons A1 Γ) ⊢ B0 ∈ PUniv i + suff : (cons A1 Γ) ⊢ B0 ∈ PUniv i by hauto l:on. eauto using ctx_eq_subst_one. * hauto lq:on use:salgo_metric_sub, Sub.bind_univ_noconf. @@ -2083,7 +2077,7 @@ Proof. eapply coqeq_complete'; eauto. Qed. -Lemma coqleq_complete n Γ (a b : PTm n) : +Lemma coqleq_complete Γ (a b : PTm) : Γ ⊢ a ≲ b -> a ≪ b. Proof. move => h. @@ -2091,7 +2085,7 @@ Proof. eapply fundamental_theorem in h. move /logrel.SemLEq_SN_Sub : h. move => h. - have : exists va vb : PTm n, + have : exists va vb : PTm , rtc LoRed.R a va /\ rtc LoRed.R b vb /\ nf va /\ nf vb /\ ESub.R va vb by hauto l:on use:Sub.standardization_lo. @@ -2102,10 +2096,10 @@ Proof. hauto lq:on solve+:lia. Qed. -Lemma coqleq_sound : forall n Γ (a b : PTm n) i j, +Lemma coqleq_sound : forall Γ (a b : PTm) i j, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv j -> a ≪ b -> Γ ⊢ a ≲ b. Proof. - move => n Γ a b i j. + 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. From 36d1f95d6524b7f7934172af76e8231b9b54496f Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 21:16:42 -0500 Subject: [PATCH 13/51] Move HRed to the common .v file --- theories/algorithmic.v | 25 ------------------------- theories/common.v | 27 +++++++++++++++++++++++++++ 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index 787adb1..8a9146a 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -8,31 +8,6 @@ Require Import Coq.Logic.FunctionalExtensionality. Require Import Cdcl.Itauto. 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). - Lemma ToRRed (a b : PTm) : HRed.R a b -> RRed.R a b. Proof. induction 1; hauto lq:on ctrs:RRed.R. Qed. diff --git a/theories/common.v b/theories/common.v index 5095fef..9c6b508 100644 --- a/theories/common.v +++ b/theories/common.v @@ -143,3 +143,30 @@ Proof. 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). +End HRed. From 87f6dcd870883f29892b1d9f81c9d57f1262dcc4 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 3 Mar 2025 23:46:41 -0500 Subject: [PATCH 14/51] Prove the soundness of the computable equality --- theories/common.v | 5 + theories/executable.v | 340 +++++++++++++++++++++++++++------- theories/executable_correct.v | 162 ++++++++++++++++ 3 files changed, 440 insertions(+), 67 deletions(-) create mode 100644 theories/executable_correct.v diff --git a/theories/common.v b/theories/common.v index 9c6b508..3ea15d6 100644 --- a/theories/common.v +++ b/theories/common.v @@ -1,4 +1,7 @@ Require Import Autosubst2.unscoped Autosubst2.syntax Autosubst2.core ssreflect. +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. @@ -169,4 +172,6 @@ Module HRed. | 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. diff --git a/theories/executable.v b/theories/executable.v index f773fa6..5de3355 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -1,58 +1,145 @@ From Equations Require Import Equations. -Require Import Autosubst2.core Autosubst2.fintype Autosubst2.syntax - common typing preservation admissible fp_red structural soundness. -Require Import algorithmic. -From stdpp Require Import relations (rtc(..), nsteps(..)). +Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. Require Import ssreflect ssrbool. +Import Logic (inspect). -Inductive algo_dom {n} : PTm n -> PTm n -> Prop := +Require Import ssreflect ssrbool. +From Hammer Require Import Tactics. + +Definition tm_nonconf (a b : PTm) : bool := + match a, b with + | PAbs _, _ => ishne b || isabs b + | _, PAbs _ => ishne a + | VarPTm _, VarPTm _ => true + | PPair _ _, _ => ishne b || ispair b + | _, PPair _ _ => ishne a + | PZero, PZero => true + | PSuc _, PSuc _ => true + | PApp _ _, PApp _ _ => ishne a && ishne b + | PProj _ _, PProj _ _ => ishne a && ishne b + | PInd _ _ _ _, PInd _ _ _ _ => ishne a && ishne b + | PNat, PNat => true + | PUniv _, PUniv _ => true + | PBind _ _ _, PBind _ _ _ => true + | _,_=> false + end. + +Definition tm_conf (a b : PTm) := ~~ tm_nonconf a b. + +Inductive eq_view : PTm -> PTm -> Type := +| V_AbsAbs a b : + eq_view (PAbs a) (PAbs b) +| V_AbsNeu a b : + ~~ isabs b -> + eq_view (PAbs a) b +| V_NeuAbs a b : + ~~ isabs a -> + eq_view a (PAbs b) +| V_VarVar i j : + eq_view (VarPTm i) (VarPTm j) +| V_PairPair a0 b0 a1 b1 : + eq_view (PPair a0 b0) (PPair a1 b1) +| V_PairNeu a0 b0 u : + ~~ ispair u -> + eq_view (PPair a0 b0) u +| V_NeuPair u a1 b1 : + ~~ ispair u -> + eq_view u (PPair a1 b1) +| V_ZeroZero : + eq_view PZero PZero +| V_SucSuc a b : + eq_view (PSuc a) (PSuc b) +| V_AppApp u0 b0 u1 b1 : + eq_view (PApp u0 b0) (PApp u1 b1) +| V_ProjProj p0 u0 p1 u1 : + eq_view (PProj p0 u0) (PProj p1 u1) +| V_IndInd P0 u0 b0 c0 P1 u1 b1 c1 : + eq_view (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) +| V_NatNat : + eq_view PNat PNat +| V_BindBind p0 A0 B0 p1 A1 B1 : + eq_view (PBind p0 A0 B0) (PBind p1 A1 B1) +| V_UnivUniv i j : + eq_view (PUniv i) (PUniv j) +| V_Others a b : + eq_view a b. + +Equations tm_to_eq_view (a b : PTm) : eq_view a b := + tm_to_eq_view (PAbs a) (PAbs b) := V_AbsAbs a b; + tm_to_eq_view (PAbs a) b := V_AbsNeu a b _; + tm_to_eq_view a (PAbs b) := V_NeuAbs a b _; + tm_to_eq_view (VarPTm i) (VarPTm j) := V_VarVar i j; + tm_to_eq_view (PPair a0 b0) (PPair a1 b1) := V_PairPair a0 b0 a1 b1; + tm_to_eq_view (PPair a0 b0) u := V_PairNeu a0 b0 u _; + tm_to_eq_view u (PPair a1 b1) := V_NeuPair u a1 b1 _; + tm_to_eq_view PZero PZero := V_ZeroZero; + tm_to_eq_view (PSuc a) (PSuc b) := V_SucSuc a b; + tm_to_eq_view (PApp a0 b0) (PApp a1 b1) := V_AppApp a0 b0 a1 b1; + tm_to_eq_view (PProj p0 b0) (PProj p1 b1) := V_ProjProj p0 b0 p1 b1; + tm_to_eq_view (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) := V_IndInd P0 u0 b0 c0 P1 u1 b1 c1; + tm_to_eq_view PNat PNat := V_NatNat; + tm_to_eq_view (PUniv i) (PUniv j) := V_UnivUniv i j; + tm_to_eq_view (PBind p0 A0 B0) (PBind p1 A1 B1) := V_BindBind p0 A0 B0 p1 A1 B1; + tm_to_eq_view a b := V_Others a b. + +Inductive algo_dom : PTm -> PTm -> Prop := | A_AbsAbs a b : - algo_dom a b -> + algo_dom_r a b -> (* --------------------- *) algo_dom (PAbs a) (PAbs b) | A_AbsNeu a u : ishne u -> - algo_dom a (PApp (ren_PTm shift u) (VarPTm var_zero)) -> + 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 (PApp (ren_PTm shift u) (VarPTm var_zero)) a -> + 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 a0 a1 -> - algo_dom 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 a0 (PProj PL u) -> - algo_dom a1 (PProj PR 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 (PProj PL u) a0 -> - algo_dom (PProj PR u) a1 -> + 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 A0 A1 -> - algo_dom 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) @@ -68,78 +155,197 @@ Inductive algo_dom {n} : PTm n -> PTm n -> Prop := ishne u0 -> ishne u1 -> algo_dom u0 u1 -> - algo_dom a0 a1 -> + algo_dom_r a0 a1 -> (* ------------------------- *) algo_dom (PApp u0 a0) (PApp u1 a1) +| 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) + +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 a' b -> + algo_dom_r a' b -> (* ----------------------- *) - algo_dom a b + algo_dom_r a b | A_HRedR a b b' : ishne a \/ ishf a -> HRed.R b b' -> - algo_dom a b' -> + algo_dom_r a b' -> (* ----------------------- *) - algo_dom a b. + algo_dom_r a b. - -Definition fin_eq {n} (i j : fin n) : bool. +Lemma algo_dom_hf_hne (a b : PTm) : + algo_dom a b -> + (ishf a \/ ishne a) /\ (ishf b \/ ishne b). Proof. - induction n. - - by exfalso. - - refine (match i , j with - | None, None => true - | Some i, Some j => IHn i j - | _, _ => false - end). + induction 1 =>//=; hauto lq:on. +Qed. + +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. + +Derive Signature for algo_dom algo_dom_r. + +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 fin_eq_dec {n} (i j : fin n) : - Bool.reflect (i = j) (fin_eq i j). -Proof. - revert i j. induction n. - - destruct i. - - destruct i; destruct j. - + specialize (IHn f f0). - inversion IHn; subst. - simpl. rewrite -H. - apply ReflectT. - reflexivity. - simpl. rewrite -H. - apply ReflectF. - injection. tauto. - + by apply ReflectF. - + by apply ReflectF. - + by apply ReflectT. -Defined. +Ltac check_equal_triv := + intros;subst; + lazymatch goal with + (* | [h : algo_dom (VarPTm _) (PAbs _) |- _] => idtac *) + | [h : algo_dom _ _ |- _] => try (inversion h; by subst) + | _ => idtac + end. +Ltac solve_check_equal := + try solve [intros *; + match goal with + | [|- _ = _] => sauto + | _ => idtac + end]. -Equations check_equal {n} (a b : PTm n) (h : algo_dom a b) : +Equations check_equal (a b : PTm) (h : algo_dom a b) : bool by struct h := - check_equal a b h with (@idP (ishne a || ishf a)) := { - | Bool.ReflectT _ _ => _ - | Bool.ReflectF _ _ => _ - }. + check_equal a b h with tm_to_eq_view a b := + check_equal _ _ h (V_VarVar i j) := nat_eqdec i j; + check_equal _ _ h (V_AbsAbs a b) := check_equal_r a b ltac:(check_equal_triv); + check_equal _ _ h (V_AbsNeu a b h') := check_equal_r a (PApp (ren_PTm shift b) (VarPTm var_zero)) ltac:(check_equal_triv); + check_equal _ _ h (V_NeuAbs a b _) := check_equal_r (PApp (ren_PTm shift a) (VarPTm var_zero)) b ltac:(check_equal_triv); + check_equal _ _ h (V_PairPair a0 b0 a1 b1) := + check_equal_r a0 a1 ltac:(check_equal_triv) && check_equal_r b0 b1 ltac:(check_equal_triv); + check_equal _ _ h (V_PairNeu a0 b0 u _) := + check_equal_r a0 (PProj PL u) ltac:(check_equal_triv) && check_equal_r b0 (PProj PR u) ltac:(check_equal_triv); + check_equal _ _ h (V_NeuPair u a1 b1 _) := + check_equal_r (PProj PL u) a1 ltac:(check_equal_triv) && check_equal_r (PProj PR u) b1 ltac:(check_equal_triv); + check_equal _ _ h V_NatNat := true; + check_equal _ _ h V_ZeroZero := true; + check_equal _ _ h (V_SucSuc a b) := check_equal_r a b ltac:(check_equal_triv); + check_equal _ _ h (V_ProjProj p0 a p1 b) := + PTag_eqdec p0 p1 && check_equal a b ltac:(check_equal_triv); + check_equal _ _ h (V_AppApp a0 b0 a1 b1) := + check_equal a0 a1 ltac:(check_equal_triv) && check_equal_r b0 b1 ltac:(check_equal_triv); + check_equal _ _ h (V_IndInd P0 u0 b0 c0 P1 u1 b1 c1) := + check_equal_r P0 P1 ltac:(check_equal_triv) && + check_equal u0 u1 ltac:(check_equal_triv) && + check_equal_r b0 b1 ltac:(check_equal_triv) && + check_equal_r c0 c1 ltac:(check_equal_triv); + check_equal _ _ h (V_UnivUniv i j) := nat_eqdec i j; + check_equal _ _ h (V_BindBind p0 A0 B0 p1 A1 B1) := + BTag_eqdec p0 p1 && check_equal_r A0 A1 ltac:(check_equal_triv) && check_equal_r B0 B1 ltac:(check_equal_triv); + check_equal _ _ _ _ := false + (* check_equal a b h := false; *) + with check_equal_r (a b : PTm) (h0 : algo_dom_r a b) : + bool by struct h0 := + check_equal_r a b h with (fancy_hred a) := + check_equal_r a b h (inr a') := check_equal_r (proj1_sig a') b _; + check_equal_r a b h (inl h') with (fancy_hred b) := + | inr b' := check_equal_r a (proj1_sig b') _; + | inl h'' := check_equal a b _. - (* check_equal (VarPTm i) (VarPTm j) h := fin_eq i j; *) - (* check_equal (PAbs a) (PAbs b) h := check_equal a b _; *) - (* check_equal (PPair a0 b0) (PPair a1 b1) h := *) - (* check_equal a0 b0 _ && check_equal a1 b1 _; *) - (* check_equal (PUniv i) (PUniv j) _ := _; *) Next Obligation. - simpl. - intros ih. -Admitted. + intros. + inversion h; subst => //=. + exfalso. hauto l:on use:hred_complete unfold:HRed.nf. + exfalso. hauto l:on use:hred_complete unfold:HRed.nf. +Defined. -Search (Bool.reflect (is_true _) _). -Check idP. +Next Obligation. + intros. + destruct h. + exfalso. apply algo_dom_hf_hne in H0. + destruct H0 as [h0 h1]. + sfirstorder use:hf_no_hred, hne_no_hred. + exfalso. sfirstorder. + assert ( b' = b'0)by eauto using hred_deter. subst. + apply h. +Defined. -Definition metric {n} k (a b : PTm n) := - 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. +Next Obligation. + simpl. intros. + inversion h; subst =>//=. + move {h}. hauto lq:on use:algo_dom_hf_hne, hf_no_hred, hne_no_hred, hred_sound. + assert (a' = a'0) by eauto using hred_deter, hred_sound. by subst. + exfalso. sfirstorder use:hne_no_hred, hf_no_hred. +Defined. -Search (nat -> nat -> bool). + + + +Next Obligation. + qauto inv:algo_dom, algo_dom_r. +Defined. diff --git a/theories/executable_correct.v b/theories/executable_correct.v new file mode 100644 index 0000000..603c91c --- /dev/null +++ b/theories/executable_correct.v @@ -0,0 +1,162 @@ +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. + +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. + +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' => //=; simp check_equal tm_to_eq_view. +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' => //=; simp check_equal tm_to_eq_view. +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. hauto lq:on. 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. hauto lq:on. 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. hauto lq:on. 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. hauto lq:on. Qed. + +Lemma hred_none a : HRed.nf a -> hred a = None. +Proof. + destruct (hred a) eqn:eq; + sfirstorder use:hred_complete, hred_sound. +Qed. + +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] : (ishf a \/ ishne a) /\ (ishf b \/ ishne b) by hauto l:on use:algo_dom_hf_hne. + have [h3 h4] : hred a = None /\ hred b = None by sfirstorder use:hf_no_hred, hne_no_hred, hred_none. + simp check_equal. + destruct (fancy_hred a). + simp check_equal. + destruct (fancy_hred b). + simp check_equal. hauto lq:on. + 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. + simp check_equal. + destruct (fancy_hred a). + - hauto q:on unfold:HRed.nf. + - simp check_equal. + destruct s as [x ?]. have ? : x = a' by eauto using hred_deter. subst. + simpl. + simp check_equal. + 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. + simp check_equal. + destruct (fancy_hred a). + - rewrite check_equal_r_clause_1_equation_1. + destruct (fancy_hred b) as [|[b'' hb']]. + + hauto lq:on unfold:HRed.nf. + + have ? : (b'' = b') by eauto using hred_deter. subst. + rewrite check_equal_r_clause_1_equation_1. simpl. + simp check_equal. destruct (fancy_hred a). simp check_equal. + f_equal; apply PropExtensionality.proof_irrelevance. + simp check_equal. exfalso. sfirstorder use:hne_no_hred, hf_no_hred. + - simp check_equal. exfalso. + sfirstorder use:hne_no_hred, hf_no_hred. +Qed. + +Lemma coqeq_neuneu u0 u1 : + ishne u0 -> ishne u1 -> u0 ↔ u1 -> u0 ∼ u1. +Proof. + inversion 3; subst => //=. +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 h1. + have {}h1 : check_equal_r a b h by hauto l:on rew:db:check_equal. + constructor. tauto. + - move => a u i h0 ih h. + apply CE_AbsNeu => //. + apply : ih. simp check_equal tm_to_eq_view in h. + have h1 : check_equal (PAbs a) u (A_AbsNeu a u i h0) = check_equal_r a (PApp (ren_PTm shift u) (VarPTm var_zero)) h0 by clear; case : u i h0 => //=. + hauto lq:on. + - move => a u i h ih h0. + apply CE_NeuAbs=>//. + apply ih. + case : u i h ih h0 => //=. + - move => a0 a1 b0 b1 a ha h. + move => h0 h1. constructor. apply ha. hauto lb:on rew:db:check_equal. + apply h0. hauto lb:on rew:db:check_equal. + - 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 => 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 => 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 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 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. From 0060d3fb8612e4c0aee439812fbbbb5f790057c9 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 00:27:42 -0500 Subject: [PATCH 15/51] Factor out the rewriting lemmas --- theories/executable_correct.v | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 603c91c..d520857 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -9,6 +9,20 @@ Scheme algo_ind := Induction for algo_dom Sort Prop Combined Scheme algo_dom_mutual from algo_ind, algor_ind. +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. hauto l:on rew:db:check_equal. 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. hauto l:on rew:db:check_equal. 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. @@ -105,8 +119,8 @@ Lemma check_equal_sound : Proof. apply algo_dom_mutual. - move => a b h. - move => h0 h1. - have {}h1 : check_equal_r a b h by hauto l:on rew:db:check_equal. + move => h0. + rewrite check_equal_abs_abs. constructor. tauto. - move => a u i h0 ih h. apply CE_AbsNeu => //. @@ -116,10 +130,11 @@ Proof. - move => a u i h ih h0. apply CE_NeuAbs=>//. apply ih. - case : u i h ih h0 => //=. + by rewrite check_equal_neu_abs in h0. - move => a0 a1 b0 b1 a ha h. - move => h0 h1. constructor. apply ha. hauto lb:on rew:db:check_equal. - apply h0. hauto lb:on rew:db:check_equal. + 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. From b9b6899764241ce6ce969c4e5e1b5c257a45c0b4 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 00:39:59 -0500 Subject: [PATCH 16/51] Half way done with check_equal_complete --- theories/executable_correct.v | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/theories/executable_correct.v b/theories/executable_correct.v index d520857..54566c8 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -107,6 +107,8 @@ Proof. sfirstorder use:hne_no_hred, hf_no_hred. 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 : ce_prop. + Lemma coqeq_neuneu u0 u1 : ishne u0 -> ishne u1 -> u0 ↔ u1 -> u0 ∼ u1. Proof. @@ -175,3 +177,28 @@ Proof. - move => a b b' hu r a0 ha hb. rewrite check_equal_hredr in hb. sauto lq:on rew:off. Qed. + +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. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - move => i j. + move => h0 h1. + have ? : i = j by sauto lq:on. subst. + simp check_equal in h0. + set x := (nat_eqdec j j). + destruct x as []. + sauto q:on. + sfirstorder. + - admit. + - sfirstorder. + - best. From dcd4465310d86d6de785f8cbff6a0e9d6cdf28c1 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 21:47:57 -0500 Subject: [PATCH 17/51] Finish the proof of completeness for the algorithm --- theories/executable_correct.v | 74 +++++++++++++++++++++++++++++++++-- 1 file changed, 71 insertions(+), 3 deletions(-) diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 54566c8..27092b1 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -62,6 +62,14 @@ Proof. sfirstorder use:hred_complete, hred_sound. Qed. +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 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] : (ishf a \/ ishne a) /\ (ishf b \/ ishne b) by hauto l:on use:algo_dom_hf_hne. @@ -178,6 +186,12 @@ Proof. sauto lq:on rew:off. Qed. +Lemma hreds_nf_refl a b : + HRed.nf a -> + rtc HRed.R a b -> + a = b. +Proof. inversion 2; sfirstorder. Qed. + 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). @@ -199,6 +213,60 @@ Proof. destruct x as []. sauto q:on. sfirstorder. - - admit. - - sfirstorder. - - best. + - 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. simp check_equal. + case : nat_eqdec => //=. sauto lq:on. + - 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 => 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 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. + - move => a b h ih. + rewrite check_equal_nfnf. + move : ih => /[apply]. + move => + h0. + move /algo_dom_hf_hne in h. + inversion h0; subst. + have {h} [? ?] : HRed.nf a /\ HRed.nf b by sfirstorder use:hf_no_hred, hne_no_hred. + 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. From 5087b8c6ce225d7e3f782769dd1cdf13e62639f4 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 22:20:12 -0500 Subject: [PATCH 18/51] Add new definition of eq_view --- theories/executable.v | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index 5de3355..3ffc695 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -30,20 +30,20 @@ Inductive eq_view : PTm -> PTm -> Type := | V_AbsAbs a b : eq_view (PAbs a) (PAbs b) | V_AbsNeu a b : - ~~ isabs b -> + ~~ ishf b -> eq_view (PAbs a) b | V_NeuAbs a b : - ~~ isabs a -> + ~~ ishf a -> eq_view a (PAbs b) | V_VarVar i j : eq_view (VarPTm i) (VarPTm j) | V_PairPair a0 b0 a1 b1 : eq_view (PPair a0 b0) (PPair a1 b1) | V_PairNeu a0 b0 u : - ~~ ispair u -> + ~~ ishf u -> eq_view (PPair a0 b0) u | V_NeuPair u a1 b1 : - ~~ ispair u -> + ~~ ishf u -> eq_view u (PPair a1 b1) | V_ZeroZero : eq_view PZero PZero @@ -62,16 +62,31 @@ Inductive eq_view : PTm -> PTm -> Type := | V_UnivUniv i j : eq_view (PUniv i) (PUniv j) | V_Others a b : + tm_conf a b -> eq_view a b. Equations tm_to_eq_view (a b : PTm) : eq_view a b := tm_to_eq_view (PAbs a) (PAbs b) := V_AbsAbs a b; - tm_to_eq_view (PAbs a) b := V_AbsNeu a b _; - tm_to_eq_view a (PAbs b) := V_NeuAbs a b _; + tm_to_eq_view (PAbs a) (PApp b0 b1) := V_AbsNeu a (PApp b0 b1) _; + tm_to_eq_view (PAbs a) (VarPTm i) := V_AbsNeu a (VarPTm i) _; + tm_to_eq_view (PAbs a) (PProj p b) := V_AbsNeu a (PProj p b) _; + tm_to_eq_view (PAbs a) (PInd P u b c) := V_AbsNeu a (PInd P u b c) _; + tm_to_eq_view (VarPTm i) (PAbs a) := V_NeuAbs (VarPTm i) a _; + tm_to_eq_view (PApp b0 b1) (PAbs b) := V_NeuAbs (PApp b0 b1) b _; + tm_to_eq_view (PProj p b) (PAbs a) := V_NeuAbs (PProj p b) a _; + tm_to_eq_view (PInd P u b c) (PAbs a) := V_NeuAbs (PInd P u b c) a _; tm_to_eq_view (VarPTm i) (VarPTm j) := V_VarVar i j; tm_to_eq_view (PPair a0 b0) (PPair a1 b1) := V_PairPair a0 b0 a1 b1; - tm_to_eq_view (PPair a0 b0) u := V_PairNeu a0 b0 u _; - tm_to_eq_view u (PPair a1 b1) := V_NeuPair u a1 b1 _; + (* tm_to_eq_view (PPair a0 b0) u := V_PairNeu a0 b0 u _; *) + tm_to_eq_view (PPair a0 b0) (VarPTm i) := V_PairNeu a0 b0 (VarPTm i) _; + tm_to_eq_view (PPair a0 b0) (PApp c0 c1) := V_PairNeu a0 b0 (PApp c0 c1) _; + tm_to_eq_view (PPair a0 b0) (PProj p c) := V_PairNeu a0 b0 (PProj p c) _; + tm_to_eq_view (PPair a0 b0) (PInd P t0 t1 t2) := V_PairNeu a0 b0 (PInd P t0 t1 t2) _; + (* tm_to_eq_view u (PPair a1 b1) := V_NeuPair u a1 b1 _; *) + tm_to_eq_view (VarPTm i) (PPair a1 b1) := V_NeuPair (VarPTm i) a1 b1 _; + tm_to_eq_view (PApp t0 t1) (PPair a1 b1) := V_NeuPair (PApp t0 t1) a1 b1 _; + tm_to_eq_view (PProj t0 t1) (PPair a1 b1) := V_NeuPair (PProj t0 t1) a1 b1 _; + tm_to_eq_view (PInd t0 t1 t2 t3) (PPair a1 b1) := V_NeuPair (PInd t0 t1 t2 t3) a1 b1 _; tm_to_eq_view PZero PZero := V_ZeroZero; tm_to_eq_view (PSuc a) (PSuc b) := V_SucSuc a b; tm_to_eq_view (PApp a0 b0) (PApp a1 b1) := V_AppApp a0 b0 a1 b1; @@ -80,7 +95,7 @@ Equations tm_to_eq_view (a b : PTm) : eq_view a b := tm_to_eq_view PNat PNat := V_NatNat; tm_to_eq_view (PUniv i) (PUniv j) := V_UnivUniv i j; tm_to_eq_view (PBind p0 A0 B0) (PBind p1 A1 B1) := V_BindBind p0 A0 B0 p1 A1 B1; - tm_to_eq_view a b := V_Others a b. + tm_to_eq_view a b := V_Others a b _. Inductive algo_dom : PTm -> PTm -> Prop := | A_AbsAbs a b : From a23be7f9b50da2d1c621628896be7e435a75d642 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 22:28:18 -0500 Subject: [PATCH 19/51] Simplify the definition of algo_dom --- theories/executable.v | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index 3ffc695..159f669 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -183,6 +183,10 @@ Inductive algo_dom : PTm -> PTm -> Prop := algo_dom_r c0 c1 -> algo_dom (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) +(* | A_Conf a b : *) +(* tm_conf a b -> *) +(* algo_dom a b *) + with algo_dom_r : PTm -> PTm -> Prop := | A_NfNf a b : algo_dom a b -> @@ -195,19 +199,12 @@ with algo_dom_r : PTm -> PTm -> Prop := algo_dom_r a b | A_HRedR a b b' : - ishne a \/ ishf a -> + HRed.nf a -> HRed.R b b' -> algo_dom_r a b' -> (* ----------------------- *) algo_dom_r a b. -Lemma algo_dom_hf_hne (a b : PTm) : - algo_dom a b -> - (ishf a \/ ishne a) /\ (ishf b \/ ishne b). -Proof. - induction 1 =>//=; hauto lq:on. -Qed. - Lemma hf_no_hred (a b : PTm) : ishf a -> HRed.R a b -> @@ -220,6 +217,13 @@ Lemma hne_no_hred (a b : PTm) : False. Proof. elim : a b => //=; hauto l:on inv:HRed.R. 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. + Derive Signature for algo_dom algo_dom_r. Fixpoint hred (a : PTm) : option (PTm) := @@ -342,9 +346,7 @@ Defined. Next Obligation. intros. destruct h. - exfalso. apply algo_dom_hf_hne in H0. - destruct H0 as [h0 h1]. - sfirstorder use:hf_no_hred, hne_no_hred. + exfalso. sfirstorder use: algo_dom_no_hred. exfalso. sfirstorder. assert ( b' = b'0)by eauto using hred_deter. subst. apply h. @@ -353,7 +355,8 @@ Defined. Next Obligation. simpl. intros. inversion h; subst =>//=. - move {h}. hauto lq:on use:algo_dom_hf_hne, hf_no_hred, hne_no_hred, hred_sound. + exfalso. sfirstorder use:algo_dom_no_hred. + move {h}. assert (a' = a'0) by eauto using hred_deter, hred_sound. by subst. exfalso. sfirstorder use:hne_no_hred, hf_no_hred. Defined. From 68cc482479519553e335f63f81e54d2ac106bbc6 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 22:30:21 -0500 Subject: [PATCH 20/51] Fix the correctness proof --- theories/executable_correct.v | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 27092b1..1464f44 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -72,7 +72,7 @@ Qed. 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] : (ishf a \/ ishne a) /\ (ishf b \/ ishne b) by hauto l:on use:algo_dom_hf_hne. + 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_equal. destruct (fancy_hred a). @@ -249,9 +249,8 @@ Proof. rewrite check_equal_nfnf. move : ih => /[apply]. move => + h0. - move /algo_dom_hf_hne in h. + have {h} [? ?] : HRed.nf a /\ HRed.nf b by sfirstorder use:algo_dom_no_hred. inversion h0; subst. - have {h} [? ?] : HRed.nf a /\ HRed.nf b by sfirstorder use:hf_no_hred, hne_no_hred. hauto l:on use:hreds_nf_refl. - move => a a' b h dom. simp ce_prop => /[apply]. From c05bd100166626c6c92c15e205a3db621d26dea5 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 22:43:30 -0500 Subject: [PATCH 21/51] Turn off auto equations generation because it produces poor lemmas --- theories/executable.v | 110 ++++++++++++++++++++++++++++++++-- theories/executable_correct.v | 98 ------------------------------ 2 files changed, 106 insertions(+), 102 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index 159f669..fa3f51a 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -1,5 +1,6 @@ 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). @@ -297,7 +298,7 @@ Ltac solve_check_equal := | _ => idtac end]. -Equations check_equal (a b : PTm) (h : algo_dom a b) : +#[derive(equations=no)]Equations check_equal (a b : PTm) (h : algo_dom a b) : bool by struct h := check_equal a b h with tm_to_eq_view a b := check_equal _ _ h (V_VarVar i j) := nat_eqdec i j; @@ -364,6 +365,107 @@ Defined. -Next Obligation. - qauto inv:algo_dom, algo_dom_r. -Defined. +(* Next Obligation. *) +(* qauto inv:algo_dom, algo_dom_r. *) +(* 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. + +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. + simpl. + rewrite /check_equal_r_functional. + destruct (fancy_hred a). + simpl. + 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. + rewrite /check_equal_r_functional. + destruct (fancy_hred a). + - hauto q:on unfold:HRed.nf. + - destruct s as [x ?]. + rewrite /check_equal_r_functional. + 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. rewrite /check_equal_r_functional. + 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. + +#[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 : ce_prop. diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 1464f44..1a28e23 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -9,58 +9,6 @@ Scheme algo_ind := Induction for algo_dom Sort Prop Combined Scheme algo_dom_mutual from algo_ind, algor_ind. -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. hauto l:on rew:db:check_equal. 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. hauto l:on rew:db:check_equal. 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' => //=; simp check_equal tm_to_eq_view. -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' => //=; simp check_equal tm_to_eq_view. -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. hauto lq:on. 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. hauto lq:on. 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. hauto lq:on. 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. hauto lq:on. Qed. - -Lemma hred_none a : HRed.nf a -> hred a = None. -Proof. - destruct (hred a) eqn:eq; - sfirstorder use:hred_complete, hred_sound. -Qed. Lemma coqeqr_no_hred a b : a ∼ b -> HRed.nf a /\ HRed.nf b. Proof. induction 1; sauto lq:on unfold:HRed.nf. Qed. @@ -70,52 +18,6 @@ Proof. induction 1; qauto inv:HRed.R use:coqeqr_no_hred, hne_no_hred unfold:HRed.nf. Qed. -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_equal. - destruct (fancy_hred a). - simp check_equal. - destruct (fancy_hred b). - simp check_equal. hauto lq:on. - 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. - simp check_equal. - destruct (fancy_hred a). - - hauto q:on unfold:HRed.nf. - - simp check_equal. - destruct s as [x ?]. have ? : x = a' by eauto using hred_deter. subst. - simpl. - simp check_equal. - 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. - simp check_equal. - destruct (fancy_hred a). - - rewrite check_equal_r_clause_1_equation_1. - destruct (fancy_hred b) as [|[b'' hb']]. - + hauto lq:on unfold:HRed.nf. - + have ? : (b'' = b') by eauto using hred_deter. subst. - rewrite check_equal_r_clause_1_equation_1. simpl. - simp check_equal. destruct (fancy_hred a). simp check_equal. - f_equal; apply PropExtensionality.proof_irrelevance. - simp check_equal. exfalso. sfirstorder use:hne_no_hred, hf_no_hred. - - simp check_equal. exfalso. - sfirstorder use:hne_no_hred, hf_no_hred. -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 : ce_prop. Lemma coqeq_neuneu u0 u1 : ishne u0 -> ishne u1 -> u0 ↔ u1 -> u0 ∼ u1. From c1ff0ae145017f0f7ef0b4c9edea096a3eb9cbee Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 23:22:41 -0500 Subject: [PATCH 22/51] Add check_equal_conf case --- theories/executable.v | 51 +++++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index fa3f51a..f7991b0 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -3,22 +3,26 @@ 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. Definition tm_nonconf (a b : PTm) : bool := match a, b with - | PAbs _, _ => ishne b || isabs b - | _, PAbs _ => ishne a + | PAbs _, _ => (~~ ishf b) || isabs b + | _, PAbs _ => ~~ ishf a | VarPTm _, VarPTm _ => true - | PPair _ _, _ => ishne b || ispair b - | _, PPair _ _ => ishne a + | PPair _ _, _ => (~~ ishf b) || ispair b + | _, PPair _ _ => ~~ ishf a | PZero, PZero => true | PSuc _, PSuc _ => true - | PApp _ _, PApp _ _ => ishne a && ishne b - | PProj _ _, PProj _ _ => ishne a && ishne b - | PInd _ _ _ _, PInd _ _ _ _ => ishne a && ishne b + | PApp _ _, PApp _ _ => (~~ ishf a) && (~~ ishf b) + | PProj _ _, PProj _ _ => (~~ ishf a) && (~~ ishf b) + | PInd _ _ _ _, PInd _ _ _ _ => (~~ ishf a) && (~~ ishf b) | PNat, PNat => true | PUniv _, PUniv _ => true | PBind _ _ _, PBind _ _ _ => true @@ -184,9 +188,11 @@ Inductive algo_dom : PTm -> PTm -> Prop := algo_dom_r c0 c1 -> algo_dom (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) -(* | A_Conf a b : *) -(* tm_conf a b -> *) -(* algo_dom a b *) +| A_Conf a b : + HRed.nf a -> + HRed.nf b -> + tm_conf a b -> + algo_dom a b with algo_dom_r : PTm -> PTm -> Prop := | A_NfNf a b : @@ -283,11 +289,19 @@ Definition fancy_hred (a : PTm) : HRed.nf a + {b | HRed.R a b}. left. move => b /hred_complete. congruence. Defined. +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; by subst) + | [h : algo_dom _ _ |- _] => try (inversion h; subst => //=; ltac2:(Control.enter destruct_algo)) | _ => idtac end. @@ -335,7 +349,8 @@ Ltac solve_check_equal := check_equal_r a b h (inr a') := check_equal_r (proj1_sig a') b _; check_equal_r a b h (inl h') with (fancy_hred b) := | inr b' := check_equal_r a (proj1_sig b') _; - | inl h'' := check_equal a b _. + | inl h'' := check_equal a b _. + Next Obligation. intros. @@ -363,12 +378,6 @@ Next Obligation. Defined. - - -(* Next Obligation. *) -(* qauto inv:algo_dom, algo_dom_r. *) -(* 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. @@ -468,4 +477,8 @@ Proof. sfirstorder use:hne_no_hred, hf_no_hred. 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 : ce_prop. +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. From c4f01d7dfc4fd4fa94b5c8760ad3c86741471fae Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 4 Mar 2025 23:48:42 -0500 Subject: [PATCH 23/51] Update the correctness proof of the computable function --- theories/executable.v | 4 ++++ theories/executable_correct.v | 44 ++++++++++++++++++++--------------- 2 files changed, 29 insertions(+), 19 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index f7991b0..0586a41 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -477,6 +477,10 @@ Proof. 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. diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 1a28e23..0720d03 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -37,8 +37,7 @@ Proof. - move => a u i h0 ih h. apply CE_AbsNeu => //. apply : ih. simp check_equal tm_to_eq_view in h. - have h1 : check_equal (PAbs a) u (A_AbsNeu a u i h0) = check_equal_r a (PApp (ren_PTm shift u) (VarPTm var_zero)) h0 by clear; case : u i h0 => //=. - hauto lq:on. + by rewrite check_equal_abs_neu in h. - move => a u i h ih h0. apply CE_NeuAbs=>//. apply ih. @@ -79,6 +78,7 @@ Proof. 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. @@ -94,27 +94,25 @@ Lemma hreds_nf_refl a b : a = b. Proof. inversion 2; sfirstorder. 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. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. - - hauto q:on inv:CoqEq, CoqEq_Neu b:on rew:db:ce_prop. + - ce_solv. + - ce_solv. + - ce_solv. + - ce_solv. + - ce_solv. + - ce_solv. + - ce_solv. + - ce_solv. - move => i j. - move => h0 h1. - have ? : i = j by sauto lq:on. subst. - simp check_equal in h0. - set x := (nat_eqdec j j). - destruct x as []. - sauto q:on. - sfirstorder. + 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. @@ -125,8 +123,8 @@ Proof. hauto qb:on inv:CoqEq,CoqEq_Neu. hauto qb:on inv:CoqEq,CoqEq_Neu. - simp check_equal. done. - - move => i j. simp check_equal. - case : nat_eqdec => //=. sauto lq:on. + - move => i j. move => h. have {h} : ~ nat_eqdec i j by done. + case : nat_eqdec => //=. ce_solv. - move => p0 p1 u0 u1 neu0 neu1 h ih. rewrite check_equal_proj_proj. move /negP /nandP. case. @@ -147,6 +145,14 @@ Proof. 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]. From b29d567ef034039eaaae5880e086a25afd9f6936 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 5 Mar 2025 00:18:28 -0500 Subject: [PATCH 24/51] Add termination --- theories/termination.v | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 theories/termination.v diff --git a/theories/termination.v b/theories/termination.v new file mode 100644 index 0000000..61f1e1d --- /dev/null +++ b/theories/termination.v @@ -0,0 +1,14 @@ +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 (..)). + +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_algo_dom : forall k a b, term_metric k a b -> algo_dom_r a b. +Proof. + elim /Wf_nat.lt_wf_ind. + move => n ih a b h. + case : (fancy_hred a); cycle 1. + move => [a' ha']. apply : A_HRedL; eauto. From 96b31397265910c301fe6fd10adeb6578be2ee3e Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 6 Mar 2025 15:39:27 -0500 Subject: [PATCH 25/51] Prove termination --- theories/algorithmic.v | 6 + theories/executable.v | 5 + theories/executable_correct.v | 13 -- theories/termination.v | 258 +++++++++++++++++++++++++++++++++- 4 files changed, 266 insertions(+), 16 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index 8a9146a..ab8fe97 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1050,6 +1050,12 @@ Proof. Qed. +Lemma hreds_nf_refl a b : + HRed.nf a -> + rtc HRed.R a b -> + a = b. +Proof. inversion 2; sfirstorder. Qed. + Lemma lored_nsteps_app_cong k (a0 a1 b : PTm) : nsteps LoRed.R k a0 a1 -> ishne a0 -> diff --git a/theories/executable.v b/theories/executable.v index 0586a41..156e691 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -486,3 +486,8 @@ Lemma check_equal_conf a b nfa nfb nfab : 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. + +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. diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 0720d03..fdfee5a 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -4,12 +4,6 @@ Require Import ssreflect ssrbool. From stdpp Require Import relations (rtc(..)). From Hammer Require Import Tactics. -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. - - Lemma coqeqr_no_hred a b : a ∼ b -> HRed.nf a /\ HRed.nf b. Proof. induction 1; sauto lq:on unfold:HRed.nf. Qed. @@ -18,7 +12,6 @@ Proof. induction 1; qauto inv:HRed.R use:coqeqr_no_hred, hne_no_hred unfold:HRed.nf. Qed. - Lemma coqeq_neuneu u0 u1 : ishne u0 -> ishne u1 -> u0 ↔ u1 -> u0 ∼ u1. Proof. @@ -88,12 +81,6 @@ Proof. sauto lq:on rew:off. Qed. -Lemma hreds_nf_refl a b : - HRed.nf a -> - rtc HRed.R a b -> - a = b. -Proof. inversion 2; sfirstorder. Qed. - Ltac ce_solv := move => *; simp ce_prop in *; hauto qb:on rew:off inv:CoqEq, CoqEq_Neu. Lemma check_equal_complete : diff --git a/theories/termination.v b/theories/termination.v index 61f1e1d..53474b6 100644 --- a/theories/termination.v +++ b/theories/termination.v @@ -1,14 +1,266 @@ 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 (..)). +From stdpp Require Import relations (nsteps (..), rtc(..)). +Import Psatz. + +Lemma tm_conf_sym a b : tm_conf a b = tm_conf b a. +Proof. case : a; case : b => //=. Qed. + +#[export]Hint Constructors algo_dom algo_dom_r : adom. + +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 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 db:adom. + move => a a' b hr h ih. + move /algo_dom_r_inv : ih => [a0][b0][ih0][ih1]ih2. + have nfa0 : HRed.nf a0 by sfirstorder use:algo_dom_no_hred. + sauto use:A_HRedsL, A_HRedsR. +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 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. + have {}ha : HRed.nf a by sfirstorder use:hf_no_hred, hne_no_hred. + have {}hb : HRed.nf b by sfirstorder use:hf_no_hred, hne_no_hred. + move => ?. + apply A_NfNf. + by apply A_Conf. +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. + move : hva => [?][?][?][?][?][?][?][?]?. + move : 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. + move : hva => [?][?][?][?][?][?][?][?]?. + move : 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 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. + 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 : (fancy_hred a); cycle 1. - move => [a' ha']. apply : A_HRedL; eauto. + 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_AppCong => //; eauto. + have {}nfa0 : HRed.nf a0 by sfirstorder use:hne_no_hred. + have {}nfb0 : HRed.nf a1 by sfirstorder use:hne_no_hred. + eauto using algo_dom_r_algo_dom. + + 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. From 6f154cc9c61961a896a260b2dede10b44bf7890b Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 6 Mar 2025 16:20:32 -0500 Subject: [PATCH 26/51] Add stub for check_sub --- theories/executable.v | 22 ++++++++++++++++++---- theories/termination.v | 16 ++++++++++++++++ 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index 156e691..a6fa438 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -212,6 +212,11 @@ with algo_dom_r : PTm -> PTm -> Prop := (* ----------------------- *) 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. + Lemma hf_no_hred (a b : PTm) : ishf a -> HRed.R a b -> @@ -351,7 +356,6 @@ Ltac solve_check_equal := | inr b' := check_equal_r a (proj1_sig b') _; | inl h'' := check_equal a b _. - Next Obligation. intros. inversion h; subst => //=. @@ -487,7 +491,17 @@ 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. -Scheme algo_ind := Induction for algo_dom Sort Prop - with algor_ind := Induction for algo_dom_r Sort Prop. +Obligation Tactic := solve [check_equal_triv | sfirstorder]. -Combined Scheme algo_dom_mutual from algo_ind, algor_ind. +Program Fixpoint check_sub (q : bool) (a b : PTm) (h : algo_dom a b) {struct h} := + match a, b with + | PBind PPi A0 B0, PBind PPi A1 B1 => + check_sub_r (negb q) A0 A1 _ && check_sub_r q B0 B1 _ + | PBind PSig A0 B0, PBind PSig A1 B1 => + check_sub_r q A0 A1 _ && check_sub_r q B0 B1 _ + | PUniv i, PUniv j => + if q then PeanoNat.Nat.leb i j else PeanoNat.Nat.leb j i + | PNat, PNat => true + | _ ,_ => ishne a && ishne b && check_equal a b h + end +with check_sub_r (q : bool) (a b : PTm) (h : algo_dom_r a b) {struct h} := false. diff --git a/theories/termination.v b/theories/termination.v index 53474b6..0f8314d 100644 --- a/theories/termination.v +++ b/theories/termination.v @@ -264,3 +264,19 @@ Proof. 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 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. From fe52d78ec5b96c6a5db5919b120c35db3091c9db Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 6 Mar 2025 19:20:54 -0500 Subject: [PATCH 27/51] Start the soundness proof for check_sub --- theories/executable.v | 101 +++++++++++++++++++++++++++++++++- theories/executable_correct.v | 23 ++++++++ 2 files changed, 122 insertions(+), 2 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index a6fa438..4ca9c5b 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -491,7 +491,7 @@ 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. -Obligation Tactic := solve [check_equal_triv | sfirstorder]. +Obligation Tactic := try solve [check_equal_triv | sfirstorder]. Program Fixpoint check_sub (q : bool) (a b : PTm) (h : algo_dom a b) {struct h} := match a, b with @@ -504,4 +504,101 @@ Program Fixpoint check_sub (q : bool) (a b : PTm) (h : algo_dom a b) {struct h} | PNat, PNat => true | _ ,_ => ishne a && ishne b && check_equal a b h end -with check_sub_r (q : bool) (a b : PTm) (h : algo_dom_r a b) {struct h} := false. +with check_sub_r (q : bool) (a b : PTm) (h : algo_dom_r a b) {struct h} := + match fancy_hred a with + | inr a' => check_sub_r q (proj1_sig a') b _ + | inl ha' => match fancy_hred b with + | inr b' => check_sub_r q a (proj1_sig b') _ + | inl hb' => check_sub q 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_sub_pi_pi q A0 B0 A1 B1 h0 h1 : + check_sub q (PBind PPi A0 B0) (PBind PPi A1 B1) (A_BindCong PPi PPi A0 A1 B0 B1 h0 h1) = + check_sub_r (~~ q) A0 A1 h0 && check_sub_r q B0 B1 h1. +Proof. reflexivity. Qed. + +Lemma check_sub_sig_sig q A0 B0 A1 B1 h0 h1 : + check_sub q (PBind PSig A0 B0) (PBind PSig A1 B1) (A_BindCong PSig PSig A0 A1 B0 B1 h0 h1) = + check_sub_r q A0 A1 h0 && check_sub_r q B0 B1 h1. + reflexivity. Qed. + +Lemma check_sub_univ_univ i j : + check_sub true (PUniv i) (PUniv j) (A_UnivCong i j) = PeanoNat.Nat.leb i j. +Proof. reflexivity. Qed. + +Lemma check_sub_univ_univ' i j : + check_sub false (PUniv i) (PUniv j) (A_UnivCong i j) = PeanoNat.Nat.leb j i. + reflexivity. Qed. + +Lemma check_sub_nfnf q a b dom : check_sub_r q a b (A_NfNf a b dom) = check_sub q 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. + 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 q a b a' ha doma : + check_sub_r q a b (A_HRedL a a' b ha doma) = check_sub_r q 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 q a b b' hu r a0 : + check_sub_r q a b (A_HRedR a b b' hu r a0) = + check_sub_r q 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. + +#[export]Hint Rewrite check_sub_hredl check_sub_hredr check_sub_nfnf check_sub_univ_univ' 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 index fdfee5a..3cc6233 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -164,3 +164,26 @@ Proof. sfirstorder unfold:HRed.nf. + sauto lq:on use:hred_deter. Qed. + +Ltac simp_sub := with_strategy opaque [check_equal] simpl. + +Lemma check_sub_sound : + (forall a b (h : algo_dom a b), forall q, check_sub q a b h -> if q then a ⋖ b else b ⋖ a) /\ + (forall a b (h : algo_dom_r a b), forall q, check_sub_r q a b h -> if q then a ≪ b else b ≪ a). +Proof. + apply algo_dom_mutual; try done. + - move => a [] //=; hauto qb:on. + - move => a0 a1 []//=; hauto qb:on. + - simpl. move => i j []; + sauto lq:on use:Reflect.Nat_leb_le. + - admit. + - hauto l:on. + - move => i j q h. + have {}h : nat_eqdec i j by sfirstorder. + case : nat_eqdec h => //=; sauto lq:on. + - simp_sub. + move => p0 p1 u0 u1 i i0 dom ihdom q. + move /andP => [/andP [h00 h01] h1]. + best use:check_sub_ + +best b:on use:check_equal_sound. From 437c97455e7d55255349d02b26071e831b1c2be3 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 6 Mar 2025 20:42:08 -0500 Subject: [PATCH 28/51] Finish the soundness and completeness proof of the subtyping algorithm --- theories/executable.v | 56 +++++++++++++++ theories/executable_correct.v | 125 ++++++++++++++++++++++++++++++++-- theories/termination.v | 8 +-- 3 files changed, 179 insertions(+), 10 deletions(-) diff --git a/theories/executable.v b/theories/executable.v index 4ca9c5b..44557f9 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -217,6 +217,62 @@ Scheme algo_ind := Induction for algo_dom Sort Prop Combined Scheme algo_dom_mutual from algo_ind, algor_ind. + +(* 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 : *) +(* ishne a -> *) +(* ishne b -> *) +(* algo_dom a b -> *) +(* (* ------------------- *) *) +(* salgo_dom *) + +(* | S_Conf a b : *) +(* HRed.nf a -> *) +(* HRed.nf b -> *) +(* tm_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. *) + +(* Scheme salgo_ind := Induction for salgo_dom Sort Prop *) +(* with algor_ind := Induction for salgo_dom_r Sort Prop. *) + + Lemma hf_no_hred (a b : PTm) : ishf a -> HRed.R a b -> diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 3cc6233..6ccee46 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -12,6 +12,11 @@ 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. @@ -165,8 +170,9 @@ Proof. + sauto lq:on use:hred_deter. Qed. -Ltac simp_sub := with_strategy opaque [check_equal] simpl. +Ltac simp_sub := with_strategy opaque [check_equal] simpl in *. +(* Reusing algo_dom results in an inefficient proof, but i'll brute force it so i can get the result more quickly *) Lemma check_sub_sound : (forall a b (h : algo_dom a b), forall q, check_sub q a b h -> if q then a ⋖ b else b ⋖ a) /\ (forall a b (h : algo_dom_r a b), forall q, check_sub_r q a b h -> if q then a ≪ b else b ≪ a). @@ -176,14 +182,121 @@ Proof. - move => a0 a1 []//=; hauto qb:on. - simpl. move => i j []; sauto lq:on use:Reflect.Nat_leb_le. - - admit. + - move => p0 p1 A0 A1 B0 B1 a iha b ihb q. + case : p0; case : p1; try done; simp ce_prop. + sauto lqb:on. + sauto lqb:on. - hauto l:on. - move => i j q h. have {}h : nat_eqdec i j by sfirstorder. case : nat_eqdec h => //=; sauto lq:on. - simp_sub. - move => p0 p1 u0 u1 i i0 dom ihdom q. - move /andP => [/andP [h00 h01] h1]. - best use:check_sub_ + sauto lqb:on use:coqeq_symmetric_mutual, coqeq_neuneu, check_equal_sound. + - simp_sub. + sauto lqb:on use:coqeq_symmetric_mutual, coqeq_neuneu, check_equal_sound. + - simp_sub. + sauto lqb:on use:coqeq_symmetric_mutual, coqeq_neuneu, check_equal_sound. + - move => a b n n0 i q h. + exfalso. + destruct a, b; try done; simp_sub; hauto lb:on use:check_equal_conf. + - move => a b doma ihdom q. + simp ce_prop. sauto lq:on. + - move => a a' b hr doma ihdom q. + simp ce_prop. move : ihdom => /[apply]. move {doma}. + sauto lq:on. + - move => a b b' n r dom ihdom q. + simp ce_prop. + move : ihdom => /[apply]. + move {dom}. + sauto lq:on rew:off. +Qed. -best b:on use:check_equal_sound. +Lemma check_sub_complete : + (forall a b (h : algo_dom a b), forall q, check_sub q a b h = false -> if q then ~ a ⋖ b else ~ b ⋖ a) /\ + (forall a b (h : algo_dom_r a b), forall q, check_sub_r q a b h = false -> if q then ~ a ≪ b else ~ b ≪ a). +Proof. + apply algo_dom_mutual; try first [done | hauto depth:4 lq:on inv:CoqLEq, CoqEq_Neu]. + - move => i j q /=. + sauto lq:on rew:off use:PeanoNat.Nat.leb_le. + - move => p0 p1 A0 A1 B0 B1 a iha b ihb []. + + move => + h. inversion h; subst; simp ce_prop. + * move /nandP. + case. + by move => /negbTE {}/iha. + by move => /negbTE {}/ihb. + * move /nandP. + case. + by move => /negbTE {}/iha. + by move => /negbTE {}/ihb. + * inversion H. + + move => + h. inversion h; subst; simp ce_prop. + * move /nandP. + case. + by move => /negbTE {}/iha. + by move => /negbTE {}/ihb. + * move /nandP. + case. + by move => /negbTE {}/iha. + by move => /negbTE {}/ihb. + * inversion H. + - simp_sub. + sauto lq:on use:check_equal_complete. + - simp_sub. + move => p0 p1 u0 u1 i i0 a iha q. + move /nandP. + case. + move /nandP. + case => //. + by move /negP. + by move /negP. + move /negP. + move => h. eapply check_equal_complete in h. + sauto use:coqeq_symmetric_mutual inv:CoqLEq lq:on. + - move => u0 u1 a0 a1 i i0 a hdom ihdom hdom' ihdom'. + simp_sub. + move /nandP. + case. + move/nandP. + case. + by move/negP. + by move/negP. + move /negP. + move => h. eapply check_equal_complete in h. + sauto use:coqeq_symmetric_mutual inv:CoqLEq lq:on. + - move => P0 P1 u0 u1 b0 b1 c0 c1 i i0 dom ihdom dom' ihdom' dom'' ihdom'' dom''' ihdom''' q. + move /nandP. + case. + move /nandP. + case => //=. + by move/negP. + by move/negP. + move /negP => h. eapply check_equal_complete in h. + sauto use:coqeq_symmetric_mutual inv:CoqLEq lq:on. + - move => a b h ih q. simp ce_prop => {}/ih. + case : q => h0; + inversion 1; subst; hauto l:on use:algo_dom_no_hred, hreds_nf_refl. + - move => a a' b r dom ihdom q. + simp ce_prop => {}/ihdom. + case : q => h0. + inversion 1; subst. + inversion H0; subst. sfirstorder use:coqleq_no_hred. + have ? : a' = y by eauto using hred_deter. subst. + sauto lq:on. + inversion 1; subst. + inversion H1; subst. sfirstorder use:coqleq_no_hred. + have ? : a' = y by eauto using hred_deter. subst. + sauto lq:on. + - move => a b b' n r hr ih q. + simp ce_prop => {}/ih. + case : q. + + move => h. inversion 1; subst. + inversion H1; subst. + sfirstorder use:coqleq_no_hred. + have ? : b' = y by eauto using hred_deter. subst. + sauto lq:on. + + move => h. inversion 1; subst. + inversion H0; subst. + sfirstorder use:coqleq_no_hred. + have ? : b' = y by eauto using hred_deter. subst. + sauto lq:on. +Qed. diff --git a/theories/termination.v b/theories/termination.v index 0f8314d..8afe24e 100644 --- a/theories/termination.v +++ b/theories/termination.v @@ -107,8 +107,8 @@ Lemma term_metric_pair : forall k a0 b0 a1 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. - move : hva => [?][?][?][?][?][?][?][?]?. - move : hvb => [?][?][?][?][?][?][?][?]?. subst. + decompose record hva => {hva}. + decompose record hvb => {hvb}. subst. simpl in *. exists (k - 1). hauto lqb:on solve+:lia. Qed. @@ -119,8 +119,8 @@ Lemma term_metric_bind : forall k p0 a0 b0 p1 a1 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. - move : hva => [?][?][?][?][?][?][?][?]?. - move : hvb => [?][?][?][?][?][?][?][?]?. subst. + decompose record hva => {hva}. + decompose record hvb => {hvb}. subst. simpl in *. exists (k - 1). hauto lqb:on solve+:lia. Qed. From 849d19708ee4d1e4eede8236123102e68a22db9c Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 14:30:36 -0400 Subject: [PATCH 29/51] Add new definition of algo_dom --- theories/algorithmic.v | 362 +++++++++++++++++++----------------- theories/common.v | 412 ++++++++++++++++++++++++++++++++++++++++- theories/executable.v | 212 --------------------- theories/termination.v | 261 -------------------------- 4 files changed, 599 insertions(+), 648 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index ab8fe97..dff32da 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -673,8 +673,12 @@ Proof. hauto lq:on use:HReds.ToEq, E_Symmetric, E_Transitive. Qed. -Definition algo_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 /\ EJoin.R va vb /\ size_PTm va + size_PTm vb + i + j <= k. +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. @@ -698,37 +702,58 @@ Proof. - hauto lq:on use:ne_hne. Qed. -Lemma algo_metric_case k (a b : PTm) : - algo_metric k a b -> - (ishf a \/ ishne a) \/ exists k' a', HRed.R a a' /\ algo_metric k' a' b /\ k' < k. +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][[v [h4 h5]]] h6. + 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:algo_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_metric solve+:lia. + + 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:algo_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_metric solve+:lia. + + 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:algo_metric solve+:lia. - + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. + + 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:algo_metric solve+:lia. + + 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 algo_metric_sym k (a b : PTm) : - algo_metric k a b -> algo_metric k b a. -Proof. hauto lq:on unfold:algo_metric solve+:lia. 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. + have {}ha : HRed.nf a by sfirstorder use:hf_no_hred, hne_no_hred. + have {}hb : HRed.nf b by sfirstorder use:hf_no_hred, hne_no_hred. + move => ?. + apply A_NfNf. + by apply A_Conf. +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 -> @@ -1028,28 +1053,6 @@ Proof. exists (S i), a1. hauto lq:on ctrs:nsteps solve+:lia. Qed. -Lemma algo_metric_proj k p0 p1 (a0 a1 : PTm) : - algo_metric k (PProj p0 a0) (PProj p1 a1) -> - ishne a0 -> - ishne a1 -> - p0 = p1 /\ exists j, j < k /\ algo_metric j a0 a1. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3][h4]h5 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. - simpl in *. - move /EJoin.hne_proj_inj : h4 => [h40 h41]. subst. - split => //. - exists (k - 1). split. simpl in *; lia. - rewrite/algo_metric. - do 4 eexists. repeat split; eauto. sfirstorder use:ne_nf. - sfirstorder use:ne_nf. - lia. -Qed. - - Lemma hreds_nf_refl a b : HRed.nf a -> rtc HRed.R a b -> @@ -1103,174 +1106,185 @@ Lemma lored_nsteps_pair_inv k (a0 b0 C : PTm ) : exists i, (S j), a1, b1. sauto lq:on solve+:lia. Qed. -Lemma algo_metric_join k (a b : PTm ) : - algo_metric k a b -> - DJoin.R a b. - rewrite /algo_metric. - move => [i][j][va][vb][h0][h1][h2][h3][[v [h40 h41]]]h5. - have {}h0 : rtc LoRed.R a va by hauto lq:on use:@relations.rtc_nsteps. - have {}h1 : rtc LoRed.R b vb by hauto lq:on use:@relations.rtc_nsteps. - apply REReds.FromEReds in h40,h41. - apply LoReds.ToRReds in h0,h1. - apply REReds.FromRReds in h0,h1. - rewrite /DJoin.R. exists v. sfirstorder use:@relations.rtc_transitive. -Qed. - -Lemma algo_metric_pair k (a0 b0 a1 b1 : PTm) : - SN (PPair a0 b0) -> - SN (PPair a1 b1) -> - algo_metric k (PPair a0 b0) (PPair a1 b1) -> - exists j, j < k /\ algo_metric j a0 a1 /\ algo_metric j b0 b1. - move => sn0 sn1 /[dup] /algo_metric_join hj. - move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. - move : lored_nsteps_pair_inv h0;repeat move/[apply]. - move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. - move : lored_nsteps_pair_inv h1;repeat move/[apply]. - move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. +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). - move /andP : h2 => [h20 h21]. - move /andP : h3 => [h30 h31]. - suff : EJoin.R a2 a3 /\ EJoin.R b2 b3 by hauto lq:on solve+:lia. - hauto l:on use:DJoin.ejoin_pair_inj. + hauto lq:on unfold:term_metric solve+:lia. 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). +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. - induction 1; hauto lq:on ctrs:nsteps use:LoRed.renaming. + 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 algo_metric_neu_abs k (a0 : PTm) u : - algo_metric k u (PAbs a0) -> +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 /\ algo_metric j (PApp (ren_PTm shift u) (VarPTm var_zero)) a0. + 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]h5 neu. - have neva : ne va by hauto lq:on use:hne_nf_ne, loreds_hne_preservation, @relations.rtc_nsteps. - move /lored_nsteps_abs_inv : h1 => [a1][h01]?. subst. - exists (k - 1). simpl in *. split. lia. - have {}h0 : nsteps LoRed.R i (ren_PTm shift u) (ren_PTm shift va) - by eauto using lored_nsteps_renaming. - have {}h0 : nsteps LoRed.R i (PApp (ren_PTm shift u) (VarPTm var_zero)) (PApp (ren_PTm shift va) (VarPTm var_zero)). - apply lored_nsteps_app_cong => //=. - scongruence use:ishne_ren. - do 4 eexists. repeat split; eauto. - hauto b:on use:ne_nf_ren. - have h : EJoin.R (PAbs (PApp (ren_PTm shift va) (VarPTm var_zero))) (PAbs a1) by hauto q:on ctrs:rtc,ERed.R. - apply DJoin.ejoin_abs_inj; eauto. - hauto b:on drew:off use:ne_nf_ren. - simpl in *. rewrite size_PTm_ren. lia. + 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 algo_metric_neu_pair k (a0 b0 : PTm) u : - algo_metric k u (PPair a0 b0) -> +Lemma term_metric_pair_neu k (a0 b0 : PTm) u : + term_metric k (PPair a0 b0) u -> ishne u -> - exists j, j < k /\ algo_metric j (PProj PL u) a0 /\ algo_metric j (PProj PR u) b0. + 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]h5 neu. - move /lored_nsteps_pair_inv : h1. - move => [i0][j0][a1][b1][hi][hj][?][ha01]hb01. subst. - simpl in *. - have ? : ishne va by - hauto lq:on use:loreds_hne_preservation, @relations.rtc_nsteps. - have ? : ne va by sfirstorder use:hne_nf_ne. - exists (k - 1). split. lia. - move :lored_nsteps_proj_cong (neu) h0; repeat move/[apply]. - move => h. have hL := h PL. have {h} hR := h PR. - suff [? ?] : EJoin.R (PProj PL va) a1 /\ EJoin.R (PProj PR va) b1. - rewrite /algo_metric. - split; do 4 eexists; repeat split;eauto; sfirstorder b:on solve+:lia. - eapply DJoin.ejoin_pair_inj; hauto qb:on ctrs:rtc, ERed.R. + 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 algo_metric_ind k P0 (a0 : PTm ) b0 c0 P1 a1 b1 c1 : - algo_metric k (PInd P0 a0 b0 c0) (PInd P1 a1 b1 c1) -> +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 /\ algo_metric j P0 P1 /\ algo_metric j a0 a1 /\ - algo_metric j b0 b1 /\ algo_metric j c0 c1. + 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]h5 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. - move /EJoin.ind_inj : h4. - move => [?][?][?]?. - exists (k -1). simpl in *. - hauto lq:on rew:off use:ne_nf b:on solve+:lia. -Qed. - -Lemma algo_metric_app k (a0 b0 a1 b1 : PTm) : - algo_metric k (PApp a0 b0) (PApp a1 b1) -> - ishne a0 -> - ishne a1 -> - exists j, j < k /\ algo_metric j a0 a1 /\ algo_metric j b0 b1. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. + 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). - move /andP : h2 => [h20 h21]. - move /andP : h3 => [h30 h31]. - move /EJoin.hne_app_inj : h4 => [h40 h41]. - split. lia. - split. - + rewrite /algo_metric. - exists i0,j0,a2,a3. - repeat split => //=. - sfirstorder b:on use:ne_nf. - sfirstorder b:on use:ne_nf. - lia. - + rewrite /algo_metric. - exists i1,j1,b2,b3. - repeat split => //=; sfirstorder b:on use:ne_nf. + simpl in *. exists (k - 1). hauto lqb:on use:lored_nsteps_app_cong, ne_nf unfold:term_metric solve+:lia. Qed. -Lemma algo_metric_suc k (a0 a1 : PTm) : - algo_metric k (PSuc a0) (PSuc a1) -> - exists j, j < k /\ algo_metric j a0 a1. +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]h5. - exists (k - 1). - move /lored_nsteps_suc_inv : h0. - move => [a0'][ha0]?. subst. - move /lored_nsteps_suc_inv : h1. - move => [b0'][hb0]?. subst. simpl in *. - split; first by lia. - rewrite /algo_metric. - hauto lq:on rew:off use:EJoin.suc_inj solve+:lia. + 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 algo_metric_bind k p0 (A0 : PTm ) B0 p1 A1 B1 : - algo_metric k (PBind p0 A0 B0) (PBind p1 A1 B1) -> - p0 = p1 /\ exists j, j < k /\ algo_metric j A0 A1 /\ algo_metric j B0 B1. +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]h5. - move : lored_nsteps_bind_inv h0 => /[apply]. - move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. - move : lored_nsteps_bind_inv h1 => /[apply]. - move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. - move /EJoin.bind_inj : h4 => [?][hEa]hEb. subst. - split => //. - exists (k - 1). split. simpl in *; lia. - simpl in *. - split. - - exists i0,j0,a2,a3. - repeat split => //=; sfirstorder b:on solve+:lia. - - exists i1,j1,b2,b3. sfirstorder b:on solve+:lia. + 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 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. + +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_AppCong => //; eauto. + have {}nfa0 : HRed.nf a0 by sfirstorder use:hne_no_hred. + have {}nfb0 : HRed.nf a1 by sfirstorder use:hne_no_hred. + eauto using algo_dom_r_algo_dom. + + 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 coqeq_complete' k (a b : PTm ) : + (forall a b, algo_dom a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b) + algo_metric k 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). diff --git a/theories/common.v b/theories/common.v index 3ea15d6..c14bbb3 100644 --- a/theories/common.v +++ b/theories/common.v @@ -1,4 +1,4 @@ -Require Import Autosubst2.unscoped Autosubst2.syntax Autosubst2.core ssreflect. +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. @@ -6,6 +6,7 @@ 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) @@ -119,6 +120,28 @@ Definition isabs (a : PTm) := | _ => 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 _ _ => (~~ ishf a) && (~~ ishf b) + | PProj _ _, PProj _ _ => (~~ ishf a) && (~~ ishf b) + | PInd _ _ _ _, PInd _ _ _ _ => (~~ ishf a) && (~~ ishf b) + | 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. @@ -175,3 +198,390 @@ Module HRed. 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_NeuNeu a b : + algo_dom_neu a b -> + algo_dom a b + +| A_Conf a b : + HRed.nf a -> + HRed.nf b -> + tm_conf a b -> + algo_dom a b + +with algo_dom_neu : PTm -> PTm -> Prop := +| A_VarCong i j : + (* -------------------------- *) + algo_dom_neu (VarPTm i) (VarPTm j) + +| A_AppCong u0 u1 a0 a1 : + ishne u0 -> + ishne u1 -> + algo_dom_neu u0 u1 -> + algo_dom_r a0 a1 -> + (* ------------------------- *) + algo_dom_neu (PApp u0 a0) (PApp u1 a1) + +| A_ProjCong p0 p1 u0 u1 : + ishne u0 -> + ishne u1 -> + algo_dom_neu u0 u1 -> + (* --------------------- *) + algo_dom_neu (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_neu u0 u1 -> + algo_dom_r b0 b1 -> + algo_dom_r c0 c1 -> + algo_dom_neu (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) + +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 algo_neu_ind := Induction for algo_dom_neu Sort Prop + with algor_ind := Induction for algo_dom_r Sort Prop. + +Combined Scheme algo_dom_mutual from algo_ind, algo_neu_ind, algor_ind. +#[export]Hint Constructors algo_dom algo_dom_neu 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 _ _ => (~~ ishf a) && (~~ ishf b) + | PProj _ _, PProj _ _ => (~~ ishf a) && (~~ ishf b) + | PInd _ _ _ _, PInd _ _ _ _ => (~~ ishf a) && (~~ ishf b) + | _, _ => 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 : + algo_dom_neu a b -> + salgo_dom a b + +| S_Conf a b : + HRed.nf a -> + HRed.nf 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. + +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 + | [h : 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_neu_hne (a b : PTm) : + algo_dom_neu a b -> + ishne a /\ ishne b. +Proof. inversion 1; subst => //=. 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 use:algo_dom_neu_hne 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, algo_dom_neu a b -> algo_dom_neu 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_neu_hne 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. + +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_neu a b -> True) /\ + (forall a b, algo_dom_r a b -> salgo_dom_r a b /\ salgo_dom_r b a). +Proof. + apply algo_dom_mutual => //=; + try hauto lq:on ctrs:salgo_dom, algo_dom_neu, salgo_dom_r use:S_Conf, hne_no_hred, algo_dom_sym, tm_stm_conf, S_HRedR' inv:HRed.R unfold:HRed.nf solve+:destruct_salgo. + - case;case; hauto lq:on ctrs:salgo_dom, algo_dom_neu, salgo_dom_r use:S_Conf, hne_no_hred, algo_dom_sym inv:HRed.R unfold:HRed.nf solve+:destruct_salgo. + - move => a b ha hb /[dup] /tm_stm_conf h. + rewrite tm_conf_sym => /tm_stm_conf h0. + hauto l:on use:S_Conf inv:HRed.R unfold:HRed.nf. +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. diff --git a/theories/executable.v b/theories/executable.v index 44557f9..fd03f2d 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -11,26 +11,6 @@ Set Default Proof Mode "Classic". Require Import ssreflect ssrbool. From Hammer Require Import Tactics. -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 _ _ => (~~ ishf a) && (~~ ishf b) - | PProj _ _, PProj _ _ => (~~ ishf a) && (~~ ishf b) - | PInd _ _ _ _, PInd _ _ _ _ => (~~ ishf a) && (~~ ishf b) - | PNat, PNat => true - | PUniv _, PUniv _ => true - | PBind _ _ _, PBind _ _ _ => true - | _,_=> false - end. - -Definition tm_conf (a b : PTm) := ~~ tm_nonconf a b. - Inductive eq_view : PTm -> PTm -> Type := | V_AbsAbs a b : eq_view (PAbs a) (PAbs b) @@ -102,121 +82,6 @@ Equations tm_to_eq_view (a b : PTm) : eq_view a b := tm_to_eq_view (PBind p0 A0 B0) (PBind p1 A1 B1) := V_BindBind p0 A0 B0 p1 A1 B1; tm_to_eq_view a b := V_Others a b _. -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_ProjCong p0 p1 u0 u1 : - ishne u0 -> - ishne u1 -> - algo_dom u0 u1 -> - (* --------------------- *) - algo_dom (PProj p0 u0) (PProj p1 u1) - -| 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_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 : - HRed.nf a -> - HRed.nf 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. - (* Inductive salgo_dom : PTm -> PTm -> Prop := *) (* | S_UnivCong i j : *) @@ -273,83 +138,6 @@ Combined Scheme algo_dom_mutual from algo_ind, algor_ind. (* with algor_ind := Induction for salgo_dom_r Sort Prop. *) -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. - -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. - -Derive Signature for algo_dom algo_dom_r. - -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. - Ltac2 destruct_algo () := lazy_match! goal with | [h : algo_dom ?a ?b |- _ ] => diff --git a/theories/termination.v b/theories/termination.v index 8afe24e..41400ef 100644 --- a/theories/termination.v +++ b/theories/termination.v @@ -4,267 +4,6 @@ Require Import ssreflect ssrbool. From stdpp Require Import relations (nsteps (..), rtc(..)). Import Psatz. -Lemma tm_conf_sym a b : tm_conf a b = tm_conf b a. -Proof. case : a; case : b => //=. Qed. - -#[export]Hint Constructors algo_dom algo_dom_r : adom. - -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 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 db:adom. - move => a a' b hr h ih. - move /algo_dom_r_inv : ih => [a0][b0][ih0][ih1]ih2. - have nfa0 : HRed.nf a0 by sfirstorder use:algo_dom_no_hred. - sauto use:A_HRedsL, A_HRedsR. -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 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. - have {}ha : HRed.nf a by sfirstorder use:hf_no_hred, hne_no_hred. - have {}hb : HRed.nf b by sfirstorder use:hf_no_hred, hne_no_hred. - move => ?. - apply A_NfNf. - by apply A_Conf. -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 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. - -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_AppCong => //; eauto. - have {}nfa0 : HRed.nf a0 by sfirstorder use:hne_no_hred. - have {}nfb0 : HRed.nf a1 by sfirstorder use:hne_no_hred. - eauto using algo_dom_r_algo_dom. - + 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 sn_term_metric (a b : PTm) : SN a -> SN b -> exists k, term_metric k a b. Proof. move /LoReds.FromSN => [va [ha0 ha1]]. From 4cbd2ac0fd5449b27ecc3c50b3aa11b9dbd7234b Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 15:35:43 -0400 Subject: [PATCH 30/51] Save --- theories/algorithmic.v | 16 +++++++++++----- theories/common.v | 18 +++++++++++------- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index dff32da..17868a0 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -737,8 +737,6 @@ Lemma A_Conf' a b : algo_dom_r a b. Proof. move => ha hb. - have {}ha : HRed.nf a by sfirstorder use:hf_no_hred, hne_no_hred. - have {}hb : HRed.nf b by sfirstorder use:hf_no_hred, hne_no_hred. move => ?. apply A_NfNf. by apply A_Conf. @@ -1234,6 +1232,11 @@ 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. +Lemma algo_dom_algo_dom_neu : forall a b, ishne a -> ishne b -> algo_dom a b -> algo_dom_neu a b \/ tm_conf a b. +Proof. + inversion 3; subst => //=; tauto. +Qed. + Lemma term_metric_algo_dom : forall k a b, term_metric k a b -> algo_dom_r a b. Proof. move => [:hneL]. @@ -1268,9 +1271,12 @@ Proof. 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_AppCong => //; eauto. - have {}nfa0 : HRed.nf a0 by sfirstorder use:hne_no_hred. - have {}nfb0 : HRed.nf a1 by sfirstorder use:hne_no_hred. + 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. + apply A_Conf. admit. admit. rewrite /tm_conf. simpl. eauto using algo_dom_r_algo_dom. + move => p0 A0 p1 A1 neA0 neA1. have {}nfa0 : HRed.nf A0 by sfirstorder use:hne_no_hred. diff --git a/theories/common.v b/theories/common.v index c14bbb3..b4867d2 100644 --- a/theories/common.v +++ b/theories/common.v @@ -129,9 +129,9 @@ Definition tm_nonconf (a b : PTm) : bool := | _, PPair _ _ => ~~ ishf a | PZero, PZero => true | PSuc _, PSuc _ => true - | PApp _ _, PApp _ _ => (~~ ishf a) && (~~ ishf b) - | PProj _ _, PProj _ _ => (~~ ishf a) && (~~ ishf b) - | PInd _ _ _ _, PInd _ _ _ _ => (~~ ishf a) && (~~ ishf b) + | PApp _ _, PApp _ _ => true + | PProj _ _, PProj _ _ => true + | PInd _ _ _ _, PInd _ _ _ _ => true | PNat, PNat => true | PUniv _, PUniv _ => true | PBind _ _ _, PBind _ _ _ => true @@ -140,8 +140,6 @@ Definition tm_nonconf (a b : PTm) : bool := 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. @@ -262,8 +260,8 @@ Inductive algo_dom : PTm -> PTm -> Prop := algo_dom a b | A_Conf a b : - HRed.nf a -> - HRed.nf b -> + ishf a -> + ishf b -> tm_conf a b -> algo_dom a b @@ -296,6 +294,12 @@ with algo_dom_neu : PTm -> PTm -> Prop := algo_dom_r c0 c1 -> algo_dom_neu (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) +| A_NeuConf a b : + ishne a -> + ishne b -> + tm_conf a b -> + algo_dom_neu a b + with algo_dom_r : PTm -> PTm -> Prop := | A_NfNf a b : algo_dom a b -> From e278c6eaefcfacd9a178b0c1d7fb4d1b681eb3a0 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 16:22:37 -0400 Subject: [PATCH 31/51] Define salgo_dom --- theories/common.v | 85 +++++++++++++++++++++++------------------------ 1 file changed, 41 insertions(+), 44 deletions(-) diff --git a/theories/common.v b/theories/common.v index b4867d2..76964a3 100644 --- a/theories/common.v +++ b/theories/common.v @@ -255,50 +255,39 @@ Inductive algo_dom : PTm -> PTm -> Prop := | A_NatCong : algo_dom PNat PNat -| A_NeuNeu a b : - algo_dom_neu a b -> - algo_dom a b - -| A_Conf a b : - ishf a -> - ishf b -> - tm_conf a b -> - algo_dom a b - -with algo_dom_neu : PTm -> PTm -> Prop := | A_VarCong i j : (* -------------------------- *) - algo_dom_neu (VarPTm i) (VarPTm j) + algo_dom (VarPTm i) (VarPTm j) | A_AppCong u0 u1 a0 a1 : ishne u0 -> ishne u1 -> - algo_dom_neu u0 u1 -> + algo_dom u0 u1 -> algo_dom_r a0 a1 -> (* ------------------------- *) - algo_dom_neu (PApp u0 a0) (PApp u1 a1) + algo_dom (PApp u0 a0) (PApp u1 a1) | A_ProjCong p0 p1 u0 u1 : ishne u0 -> ishne u1 -> - algo_dom_neu u0 u1 -> + algo_dom u0 u1 -> (* --------------------- *) - algo_dom_neu (PProj p0 u0) (PProj p1 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_neu u0 u1 -> + algo_dom u0 u1 -> algo_dom_r b0 b1 -> algo_dom_r c0 c1 -> - algo_dom_neu (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) + algo_dom (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) -| A_NeuConf a b : - ishne a -> - ishne b -> +| A_Conf a b : + HRed.nf a -> + HRed.nf b -> tm_conf a b -> - algo_dom_neu a b + algo_dom a b with algo_dom_r : PTm -> PTm -> Prop := | A_NfNf a b : @@ -319,11 +308,10 @@ with algo_dom_r : PTm -> PTm -> Prop := algo_dom_r a b. Scheme algo_ind := Induction for algo_dom Sort Prop - with algo_neu_ind := Induction for algo_dom_neu Sort Prop with algor_ind := Induction for algo_dom_r Sort Prop. -Combined Scheme algo_dom_mutual from algo_ind, algo_neu_ind, algor_ind. -#[export]Hint Constructors algo_dom algo_dom_neu algo_dom_r : adom. +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 @@ -332,9 +320,18 @@ Definition stm_nonconf a b := | PBind PSig _ _, PBind PSig _ _ => true | PNat, PNat => true | VarPTm _, VarPTm _ => true - | PApp _ _, PApp _ _ => (~~ ishf a) && (~~ ishf b) - | PProj _ _, PProj _ _ => (~~ ishf a) && (~~ ishf b) - | PInd _ _ _ _, PInd _ _ _ _ => (~~ ishf a) && (~~ ishf b) + | 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. @@ -374,7 +371,8 @@ Inductive salgo_dom : PTm -> PTm -> Prop := salgo_dom PNat PNat | S_NeuNeu a b : - algo_dom_neu a b -> + neuneu_nonconf a b -> + algo_dom a b -> salgo_dom a b | S_Conf a b : @@ -401,6 +399,8 @@ with salgo_dom_r : PTm -> PTm -> Prop := (* ----------------------- *) salgo_dom_r a b. +#[export]Hint Constructors salgo_dom salgo_dom_r : sdom. + Lemma hf_no_hred (a b : PTm) : ishf a -> HRed.R a b -> @@ -446,16 +446,11 @@ 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_neu_hne (a b : PTm) : - algo_dom_neu a b -> - ishne a /\ ishne b. -Proof. inversion 1; subst => //=. 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 use:algo_dom_neu_hne lq:on unfold:HRed.nf. + induction 1 =>//=; try hauto inv:HRed.R use:hne_no_hred, hf_no_hred lq:on unfold:HRed.nf. Qed. @@ -473,7 +468,6 @@ Qed. Lemma algo_dom_sym : (forall a b (h : algo_dom a b), algo_dom b a) /\ - (forall a b, algo_dom_neu a b -> algo_dom_neu 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. @@ -506,7 +500,7 @@ 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_neu_hne lq:on unfold:HRed.nf. + 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' : @@ -521,17 +515,20 @@ Proof. 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_neu a b -> True) /\ (forall a b, algo_dom_r a b -> salgo_dom_r a b /\ salgo_dom_r b a). Proof. - apply algo_dom_mutual => //=; - try hauto lq:on ctrs:salgo_dom, algo_dom_neu, salgo_dom_r use:S_Conf, hne_no_hred, algo_dom_sym, tm_stm_conf, S_HRedR' inv:HRed.R unfold:HRed.nf solve+:destruct_salgo. - - case;case; hauto lq:on ctrs:salgo_dom, algo_dom_neu, salgo_dom_r use:S_Conf, hne_no_hred, algo_dom_sym inv:HRed.R unfold:HRed.nf solve+:destruct_salgo. - - move => a b ha hb /[dup] /tm_stm_conf h. - rewrite tm_conf_sym => /tm_stm_conf h0. - hauto l:on use:S_Conf inv:HRed.R unfold:HRed.nf. + 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) := From 4021d05d99301b8befd9ab2125f1e136155948b8 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 18:18:42 -0400 Subject: [PATCH 32/51] Update executable to use salgo_dom for subtyping --- theories/algorithmic.v | 10 -- theories/common.v | 9 ++ theories/executable.v | 342 ++++++++++++++--------------------------- 3 files changed, 128 insertions(+), 233 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index 17868a0..cf64209 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1051,12 +1051,6 @@ Proof. exists (S i), a1. hauto lq:on ctrs:nsteps solve+:lia. Qed. -Lemma hreds_nf_refl a b : - HRed.nf a -> - rtc HRed.R a b -> - a = b. -Proof. inversion 2; sfirstorder. Qed. - Lemma lored_nsteps_app_cong k (a0 a1 b : PTm) : nsteps LoRed.R k a0 a1 -> ishne a0 -> @@ -1228,10 +1222,6 @@ Proof. hauto lq:on rew:off use:ne_nf b:on solve+:lia. 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. - Lemma algo_dom_algo_dom_neu : forall a b, ishne a -> ishne b -> algo_dom a b -> algo_dom_neu a b \/ tm_conf a b. Proof. inversion 3; subst => //=; tauto. diff --git a/theories/common.v b/theories/common.v index 76964a3..266d90a 100644 --- a/theories/common.v +++ b/theories/common.v @@ -586,3 +586,12 @@ Definition fancy_hred (a : PTm) : HRed.nf a + {b | HRed.R a b}. 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 index fd03f2d..238fe45 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -11,133 +11,6 @@ Set Default Proof Mode "Classic". Require Import ssreflect ssrbool. From Hammer Require Import Tactics. -Inductive eq_view : PTm -> PTm -> Type := -| V_AbsAbs a b : - eq_view (PAbs a) (PAbs b) -| V_AbsNeu a b : - ~~ ishf b -> - eq_view (PAbs a) b -| V_NeuAbs a b : - ~~ ishf a -> - eq_view a (PAbs b) -| V_VarVar i j : - eq_view (VarPTm i) (VarPTm j) -| V_PairPair a0 b0 a1 b1 : - eq_view (PPair a0 b0) (PPair a1 b1) -| V_PairNeu a0 b0 u : - ~~ ishf u -> - eq_view (PPair a0 b0) u -| V_NeuPair u a1 b1 : - ~~ ishf u -> - eq_view u (PPair a1 b1) -| V_ZeroZero : - eq_view PZero PZero -| V_SucSuc a b : - eq_view (PSuc a) (PSuc b) -| V_AppApp u0 b0 u1 b1 : - eq_view (PApp u0 b0) (PApp u1 b1) -| V_ProjProj p0 u0 p1 u1 : - eq_view (PProj p0 u0) (PProj p1 u1) -| V_IndInd P0 u0 b0 c0 P1 u1 b1 c1 : - eq_view (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) -| V_NatNat : - eq_view PNat PNat -| V_BindBind p0 A0 B0 p1 A1 B1 : - eq_view (PBind p0 A0 B0) (PBind p1 A1 B1) -| V_UnivUniv i j : - eq_view (PUniv i) (PUniv j) -| V_Others a b : - tm_conf a b -> - eq_view a b. - -Equations tm_to_eq_view (a b : PTm) : eq_view a b := - tm_to_eq_view (PAbs a) (PAbs b) := V_AbsAbs a b; - tm_to_eq_view (PAbs a) (PApp b0 b1) := V_AbsNeu a (PApp b0 b1) _; - tm_to_eq_view (PAbs a) (VarPTm i) := V_AbsNeu a (VarPTm i) _; - tm_to_eq_view (PAbs a) (PProj p b) := V_AbsNeu a (PProj p b) _; - tm_to_eq_view (PAbs a) (PInd P u b c) := V_AbsNeu a (PInd P u b c) _; - tm_to_eq_view (VarPTm i) (PAbs a) := V_NeuAbs (VarPTm i) a _; - tm_to_eq_view (PApp b0 b1) (PAbs b) := V_NeuAbs (PApp b0 b1) b _; - tm_to_eq_view (PProj p b) (PAbs a) := V_NeuAbs (PProj p b) a _; - tm_to_eq_view (PInd P u b c) (PAbs a) := V_NeuAbs (PInd P u b c) a _; - tm_to_eq_view (VarPTm i) (VarPTm j) := V_VarVar i j; - tm_to_eq_view (PPair a0 b0) (PPair a1 b1) := V_PairPair a0 b0 a1 b1; - (* tm_to_eq_view (PPair a0 b0) u := V_PairNeu a0 b0 u _; *) - tm_to_eq_view (PPair a0 b0) (VarPTm i) := V_PairNeu a0 b0 (VarPTm i) _; - tm_to_eq_view (PPair a0 b0) (PApp c0 c1) := V_PairNeu a0 b0 (PApp c0 c1) _; - tm_to_eq_view (PPair a0 b0) (PProj p c) := V_PairNeu a0 b0 (PProj p c) _; - tm_to_eq_view (PPair a0 b0) (PInd P t0 t1 t2) := V_PairNeu a0 b0 (PInd P t0 t1 t2) _; - (* tm_to_eq_view u (PPair a1 b1) := V_NeuPair u a1 b1 _; *) - tm_to_eq_view (VarPTm i) (PPair a1 b1) := V_NeuPair (VarPTm i) a1 b1 _; - tm_to_eq_view (PApp t0 t1) (PPair a1 b1) := V_NeuPair (PApp t0 t1) a1 b1 _; - tm_to_eq_view (PProj t0 t1) (PPair a1 b1) := V_NeuPair (PProj t0 t1) a1 b1 _; - tm_to_eq_view (PInd t0 t1 t2 t3) (PPair a1 b1) := V_NeuPair (PInd t0 t1 t2 t3) a1 b1 _; - tm_to_eq_view PZero PZero := V_ZeroZero; - tm_to_eq_view (PSuc a) (PSuc b) := V_SucSuc a b; - tm_to_eq_view (PApp a0 b0) (PApp a1 b1) := V_AppApp a0 b0 a1 b1; - tm_to_eq_view (PProj p0 b0) (PProj p1 b1) := V_ProjProj p0 b0 p1 b1; - tm_to_eq_view (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) := V_IndInd P0 u0 b0 c0 P1 u1 b1 c1; - tm_to_eq_view PNat PNat := V_NatNat; - tm_to_eq_view (PUniv i) (PUniv j) := V_UnivUniv i j; - tm_to_eq_view (PBind p0 A0 B0) (PBind p1 A1 B1) := V_BindBind p0 A0 B0 p1 A1 B1; - tm_to_eq_view a b := V_Others a b _. - - -(* 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 : *) -(* ishne a -> *) -(* ishne b -> *) -(* algo_dom a b -> *) -(* (* ------------------- *) *) -(* salgo_dom *) - -(* | S_Conf a b : *) -(* HRed.nf a -> *) -(* HRed.nf b -> *) -(* tm_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. *) - -(* Scheme salgo_ind := Induction for salgo_dom Sort Prop *) -(* with algor_ind := Induction for salgo_dom_r Sort Prop. *) - - Ltac2 destruct_algo () := lazy_match! goal with | [h : algo_dom ?a ?b |- _ ] => @@ -161,70 +34,79 @@ Ltac solve_check_equal := | _ => idtac end]. -#[derive(equations=no)]Equations check_equal (a b : PTm) (h : algo_dom a b) : - bool by struct h := - check_equal a b h with tm_to_eq_view a b := - check_equal _ _ h (V_VarVar i j) := nat_eqdec i j; - check_equal _ _ h (V_AbsAbs a b) := check_equal_r a b ltac:(check_equal_triv); - check_equal _ _ h (V_AbsNeu a b h') := check_equal_r a (PApp (ren_PTm shift b) (VarPTm var_zero)) ltac:(check_equal_triv); - check_equal _ _ h (V_NeuAbs a b _) := check_equal_r (PApp (ren_PTm shift a) (VarPTm var_zero)) b ltac:(check_equal_triv); - check_equal _ _ h (V_PairPair a0 b0 a1 b1) := - check_equal_r a0 a1 ltac:(check_equal_triv) && check_equal_r b0 b1 ltac:(check_equal_triv); - check_equal _ _ h (V_PairNeu a0 b0 u _) := - check_equal_r a0 (PProj PL u) ltac:(check_equal_triv) && check_equal_r b0 (PProj PR u) ltac:(check_equal_triv); - check_equal _ _ h (V_NeuPair u a1 b1 _) := - check_equal_r (PProj PL u) a1 ltac:(check_equal_triv) && check_equal_r (PProj PR u) b1 ltac:(check_equal_triv); - check_equal _ _ h V_NatNat := true; - check_equal _ _ h V_ZeroZero := true; - check_equal _ _ h (V_SucSuc a b) := check_equal_r a b ltac:(check_equal_triv); - check_equal _ _ h (V_ProjProj p0 a p1 b) := - PTag_eqdec p0 p1 && check_equal a b ltac:(check_equal_triv); - check_equal _ _ h (V_AppApp a0 b0 a1 b1) := - check_equal a0 a1 ltac:(check_equal_triv) && check_equal_r b0 b1 ltac:(check_equal_triv); - check_equal _ _ h (V_IndInd P0 u0 b0 c0 P1 u1 b1 c1) := - check_equal_r P0 P1 ltac:(check_equal_triv) && - check_equal u0 u1 ltac:(check_equal_triv) && - check_equal_r b0 b1 ltac:(check_equal_triv) && - check_equal_r c0 c1 ltac:(check_equal_triv); - check_equal _ _ h (V_UnivUniv i j) := nat_eqdec i j; - check_equal _ _ h (V_BindBind p0 A0 B0 p1 A1 B1) := - BTag_eqdec p0 p1 && check_equal_r A0 A1 ltac:(check_equal_triv) && check_equal_r B0 B1 ltac:(check_equal_triv); - check_equal _ _ _ _ := false +Global Set Transparent Obligations. - (* check_equal a b h := false; *) - with check_equal_r (a b : PTm) (h0 : algo_dom_r a b) : - bool by struct h0 := - check_equal_r a b h with (fancy_hred a) := - check_equal_r a b h (inr a') := check_equal_r (proj1_sig a') b _; - check_equal_r a b h (inl h') with (fancy_hred b) := - | inr b' := check_equal_r a (proj1_sig b') _; - | inl h'' := check_equal a b _. +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. - intros. + simpl. intros. clear Heq_anonymous. destruct a' as [a' ha']. simpl. inversion h; subst => //=. - exfalso. hauto l:on use:hred_complete unfold:HRed.nf. - exfalso. hauto l:on use:hred_complete unfold:HRed.nf. -Defined. - -Next Obligation. - intros. - destruct h. - exfalso. sfirstorder use: algo_dom_no_hred. - exfalso. sfirstorder. - assert ( b' = b'0)by eauto using hred_deter. subst. - apply h. -Defined. - -Next Obligation. - simpl. intros. - inversion h; subst =>//=. exfalso. sfirstorder use:algo_dom_no_hred. - move {h}. - assert (a' = a'0) by eauto using hred_deter, hred_sound. by subst. - exfalso. sfirstorder use:hne_no_hred, hf_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. @@ -279,14 +161,14 @@ Proof. 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. - simpl. - rewrite /check_equal_r_functional. + simp_check_r. destruct (fancy_hred a). - simpl. destruct (fancy_hred b). reflexivity. exfalso. hauto l:on use:hred_complete. @@ -297,11 +179,9 @@ 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. - rewrite /check_equal_r_functional. destruct (fancy_hred a). - hauto q:on unfold:HRed.nf. - destruct s as [x ?]. - rewrite /check_equal_r_functional. have ? : x = a' by eauto using hred_deter. subst. simpl. f_equal. @@ -312,7 +192,7 @@ 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. rewrite /check_equal_r_functional. + simpl. destruct (fancy_hred a). - simpl. destruct (fancy_hred b) as [|[b'' hb']]. @@ -335,31 +215,51 @@ 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. -Obligation Tactic := try solve [check_equal_triv | sfirstorder]. +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. -Program Fixpoint check_sub (q : bool) (a b : PTm) (h : algo_dom a b) {struct h} := +Ltac check_sub_triv := + intros;subst; + lazymatch goal with + (* | [h : algo_dom (VarPTm _) (PAbs _) |- _] => idtac *) + | [h : 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 (negb q) A0 A1 _ && check_sub_r q B0 B1 _ + check_sub_r A1 A0 _ && check_sub_r B0 B1 _ | PBind PSig A0 B0, PBind PSig A1 B1 => - check_sub_r q A0 A1 _ && check_sub_r q B0 B1 _ + check_sub_r A0 A1 _ && check_sub_r B0 B1 _ | PUniv i, PUniv j => - if q then PeanoNat.Nat.leb i j else PeanoNat.Nat.leb j i + PeanoNat.Nat.leb i j | PNat, PNat => true - | _ ,_ => ishne a && ishne b && check_equal a b h + | 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 (q : bool) (a b : PTm) (h : algo_dom_r a b) {struct h} := +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 q (proj1_sig a') b _ + | inr a' => check_sub_r (proj1_sig a') b _ | inl ha' => match fancy_hred b with - | inr b' => check_sub_r q a (proj1_sig b') _ - | inl hb' => check_sub q a b _ + | 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:algo_dom_no_hred. + exfalso. sfirstorder use:salgo_dom_no_hred. assert (a' = a'0) by eauto using hred_deter. by subst. exfalso. sfirstorder. Defined. @@ -369,7 +269,7 @@ Next Obligation. destruct b' as [b' hb']. simpl. inversion h; subst. - exfalso. - sfirstorder use:algo_dom_no_hred. + sfirstorder use:salgo_dom_no_hred. - exfalso. sfirstorder. - assert (b' = b'0) by eauto using hred_deter. by subst. @@ -377,34 +277,30 @@ Defined. (* Need to avoid ssreflect tactics since they generate terms that make the termination checker upset *) Next Obligation. - move => _ /= a b hdom ha _ hb _. + move => /= a b hdom ha _ hb _. inversion hdom; subst. - assumption. - exfalso; sfirstorder. - exfalso; sfirstorder. Defined. -Lemma check_sub_pi_pi q A0 B0 A1 B1 h0 h1 : - check_sub q (PBind PPi A0 B0) (PBind PPi A1 B1) (A_BindCong PPi PPi A0 A1 B0 B1 h0 h1) = - check_sub_r (~~ q) A0 A1 h0 && check_sub_r q B0 B1 h1. +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 q A0 B0 A1 B1 h0 h1 : - check_sub q (PBind PSig A0 B0) (PBind PSig A1 B1) (A_BindCong PSig PSig A0 A1 B0 B1 h0 h1) = - check_sub_r q A0 A1 h0 && check_sub_r q B0 B1 h1. - 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 true (PUniv i) (PUniv j) (A_UnivCong i j) = PeanoNat.Nat.leb i j. + check_sub (PUniv i) (PUniv j) (S_UnivCong i j) = PeanoNat.Nat.leb i j. Proof. reflexivity. Qed. -Lemma check_sub_univ_univ' i j : - check_sub false (PUniv i) (PUniv j) (A_UnivCong i j) = PeanoNat.Nat.leb j i. - reflexivity. Qed. - -Lemma check_sub_nfnf q a b dom : check_sub_r q a b (A_NfNf a b dom) = check_sub q a b dom. +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:algo_dom_no_hred. + 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)=>//=. @@ -415,8 +311,8 @@ Proof. hauto l:on use:hred_complete. Qed. -Lemma check_sub_hredl q a b a' ha doma : - check_sub_r q a b (A_HRedL a a' b ha doma) = check_sub_r q a' b doma. +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). @@ -428,9 +324,9 @@ Proof. apply PropExtensionality.proof_irrelevance. Qed. -Lemma check_sub_hredr q a b b' hu r a0 : - check_sub_r q a b (A_HRedR a b b' hu r a0) = - check_sub_r q a b' a0. +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). @@ -445,4 +341,4 @@ Proof. sfirstorder use:hne_no_hred, hf_no_hred. Qed. -#[export]Hint Rewrite check_sub_hredl check_sub_hredr check_sub_nfnf check_sub_univ_univ' check_sub_univ_univ check_sub_pi_pi check_sub_sig_sig : ce_prop. +#[export]Hint Rewrite check_sub_hredl check_sub_hredr check_sub_nfnf check_sub_univ_univ check_sub_pi_pi check_sub_sig_sig : ce_prop. From 030dccb3261e8ee8d3bfde3e4a455b85b936c0c9 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 19:02:51 -0400 Subject: [PATCH 33/51] Finish the refactored executable_correct --- theories/algorithmic.v | 1522 ++++++++++++++++----------------- theories/common.v | 2 + theories/executable_correct.v | 203 ++--- 3 files changed, 847 insertions(+), 880 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index cf64209..de58fd4 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -739,7 +739,7 @@ Proof. move => ha hb. move => ?. apply A_NfNf. - by apply A_Conf. + apply A_Conf; sfirstorder use:hf_no_hred, hne_no_hred. Qed. Lemma hne_nf_ne (a : PTm ) : @@ -1222,11 +1222,6 @@ Proof. hauto lq:on rew:off use:ne_nf b:on solve+:lia. Qed. -Lemma algo_dom_algo_dom_neu : forall a b, ishne a -> ishne b -> algo_dom a b -> algo_dom_neu a b \/ tm_conf a b. -Proof. - inversion 3; subst => //=; tauto. -Qed. - Lemma term_metric_algo_dom : forall k a b, term_metric k a b -> algo_dom_r a b. Proof. move => [:hneL]. @@ -1266,8 +1261,7 @@ Proof. 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. - apply A_Conf. admit. admit. rewrite /tm_conf. simpl. - 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. @@ -1278,489 +1272,489 @@ Proof. hauto lq:on use:term_metric_ind, algo_dom_r_algo_dom db:adom. Qed. -Lemma coqeq_complete' k (a b : PTm ) : - (forall a b, algo_dom a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b) +(* Lemma coqeq_complete' k (a b : PTm ) : *) +(* (forall a b, algo_dom a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b) *) - algo_metric k 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). -Proof. - move : k a b. - elim /Wf_nat.lt_wf_ind. - move => n ih. - move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. - move => a b h. - (* Cases where a and b can take steps *) - case; cycle 1. - move : ih a b h. - abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. - move /algo_metric_sym /algo_metric_case : (h). - case; cycle 1. - move /algo_metric_sym : h. - move : hstepL ih => /[apply]/[apply]. - repeat move /[apply]. - move => hstepL. - hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. - (* Cases where a and b can't take wh steps *) - move {hstepL}. - move : a b h. move => [:hnfneu]. - move => a b h. - case => fb; case => fa. - - split; last by sfirstorder use:hf_not_hne. - move {hnfneu}. - case : a h fb fa => //=. - + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_AbsBind_Imp, T_AbsUniv_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_AbsNat_Imp. - move => a0 a1 ha0 _ _ Γ A wt0 wt1. - move : T_Abs_Inv wt0 wt1; repeat move/[apply]. move => [Δ [V [wt1 wt0]]]. - apply : CE_HRed; eauto using rtc_refl. - apply CE_AbsAbs. - suff [l [h0 h1]] : exists l, l < n /\ algo_metric l a1 a0 by eapply ih; eauto. - have ? : n > 0 by sauto solve+:lia. - exists (n - 1). split; first by lia. - move : (ha0). rewrite /algo_metric. - move => [i][j][va][vb][hr0][hr1][nfva][nfvb][[v [hr0' hr1']]] har. - apply lored_nsteps_abs_inv in hr0, hr1. - move : hr0 => [va' [hr00 hr01]]. - move : hr1 => [vb' [hr10 hr11]]. move {ih}. - exists i,j,va',vb'. subst. - suff [v0 [hv00 hv01]] : exists v0, rtc ERed.R va' v0 /\ rtc ERed.R vb' v0. - repeat split =>//=. sfirstorder. - simpl in *; by lia. - move /algo_metric_join /DJoin.symmetric : ha0. - have : SN a0 /\ SN a1 by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. - move => /[dup] [[ha00 ha10]] []. - move : DJoin.abs_inj; repeat move/[apply]. - move : DJoin.standardization ha00 ha10; repeat move/[apply]. - (* this is awful *) - move => [vb][va][h' [h'' [h''' [h'''' h'''''']]]]. - have /LoReds.ToRReds {}hr00 : rtc LoRed.R a1 va' - by hauto lq:on use:@relations.rtc_nsteps. - have /LoReds.ToRReds {}hr10 : rtc LoRed.R a0 vb' - by hauto lq:on use:@relations.rtc_nsteps. - simpl in *. - have [*] : va' = va /\ vb' = vb by eauto using red_uniquenf. subst. - sfirstorder. - + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_PairBind_Imp, T_PairUniv_Imp, T_PairNat_Imp, T_PairSuc_Imp, T_PairZero_Imp. - move => a1 b1 a0 b0 h _ _ Γ A hu0 hu1. - have [sn0 sn1] : SN (PPair a0 b0) /\ SN (PPair a1 b1) - by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. - apply : CE_HRed; eauto using rtc_refl. - move /Pair_Inv : hu0 => [A0][B0][ha0][hb0]hSu0. - move /Pair_Inv : hu1 => [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 /algo_metric_pair : h sn0 sn1; repeat move/[apply]. - move => [j][hj][ih0 ih1]. - have haE : a0 ⇔ a1 by hauto l:on. - 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 ih; 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. - + case : b => //=. - * hauto lq:on use:T_AbsBind_Imp. - * hauto lq:on rew:off use:T_PairBind_Imp. - * move => p1 A1 B1 p0 A0 B0. - move /algo_metric_bind. - move => [?][j [ih0 [ih1 ih2]]]_ _. subst. - move => Γ A hU0 hU1. - move /Bind_Inv : hU0 => [i0 [hA0 [hB0 hS0]]]. - move /Bind_Inv : hU1 => [i1 [hA1 [hB1 hS1]]]. - have ? : Γ ⊢ PUniv i0 ≲ PUniv (max i0 i1) - by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. - have ? : Γ ⊢ PUniv i1 ≲ PUniv (max i0 i1) - by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. - have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. - have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. - have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) - by hauto lq:on use:T_Univ_Raise solve+:lia. - have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) - by hauto lq:on use:T_Univ_Raise solve+:lia. +(* algo_metric k 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). *) +(* Proof. *) +(* move : k a b. *) +(* elim /Wf_nat.lt_wf_ind. *) +(* move => n ih. *) +(* move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. *) +(* move => a b h. *) +(* (* Cases where a and b can take steps *) *) +(* case; cycle 1. *) +(* move : ih a b h. *) +(* abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. *) +(* move /algo_metric_sym /algo_metric_case : (h). *) +(* case; cycle 1. *) +(* move /algo_metric_sym : h. *) +(* move : hstepL ih => /[apply]/[apply]. *) +(* repeat move /[apply]. *) +(* move => hstepL. *) +(* hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. *) +(* (* Cases where a and b can't take wh steps *) *) +(* move {hstepL}. *) +(* move : a b h. move => [:hnfneu]. *) +(* move => a b h. *) +(* case => fb; case => fa. *) +(* - split; last by sfirstorder use:hf_not_hne. *) +(* move {hnfneu}. *) +(* case : a h fb fa => //=. *) +(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_AbsBind_Imp, T_AbsUniv_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_AbsNat_Imp. *) +(* move => a0 a1 ha0 _ _ Γ A wt0 wt1. *) +(* move : T_Abs_Inv wt0 wt1; repeat move/[apply]. move => [Δ [V [wt1 wt0]]]. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* apply CE_AbsAbs. *) +(* suff [l [h0 h1]] : exists l, l < n /\ algo_metric l a1 a0 by eapply ih; eauto. *) +(* have ? : n > 0 by sauto solve+:lia. *) +(* exists (n - 1). split; first by lia. *) +(* move : (ha0). rewrite /algo_metric. *) +(* move => [i][j][va][vb][hr0][hr1][nfva][nfvb][[v [hr0' hr1']]] har. *) +(* apply lored_nsteps_abs_inv in hr0, hr1. *) +(* move : hr0 => [va' [hr00 hr01]]. *) +(* move : hr1 => [vb' [hr10 hr11]]. move {ih}. *) +(* exists i,j,va',vb'. subst. *) +(* suff [v0 [hv00 hv01]] : exists v0, rtc ERed.R va' v0 /\ rtc ERed.R vb' v0. *) +(* repeat split =>//=. sfirstorder. *) +(* simpl in *; by lia. *) +(* move /algo_metric_join /DJoin.symmetric : ha0. *) +(* have : SN a0 /\ SN a1 by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) +(* move => /[dup] [[ha00 ha10]] []. *) +(* move : DJoin.abs_inj; repeat move/[apply]. *) +(* move : DJoin.standardization ha00 ha10; repeat move/[apply]. *) +(* (* this is awful *) *) +(* move => [vb][va][h' [h'' [h''' [h'''' h'''''']]]]. *) +(* have /LoReds.ToRReds {}hr00 : rtc LoRed.R a1 va' *) +(* by hauto lq:on use:@relations.rtc_nsteps. *) +(* have /LoReds.ToRReds {}hr10 : rtc LoRed.R a0 vb' *) +(* by hauto lq:on use:@relations.rtc_nsteps. *) +(* simpl in *. *) +(* have [*] : va' = va /\ vb' = vb by eauto using red_uniquenf. subst. *) +(* sfirstorder. *) +(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_PairBind_Imp, T_PairUniv_Imp, T_PairNat_Imp, T_PairSuc_Imp, T_PairZero_Imp. *) +(* move => a1 b1 a0 b0 h _ _ Γ A hu0 hu1. *) +(* have [sn0 sn1] : SN (PPair a0 b0) /\ SN (PPair a1 b1) *) +(* by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* move /Pair_Inv : hu0 => [A0][B0][ha0][hb0]hSu0. *) +(* move /Pair_Inv : hu1 => [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 /algo_metric_pair : h sn0 sn1; repeat move/[apply]. *) +(* move => [j][hj][ih0 ih1]. *) +(* have haE : a0 ⇔ a1 by hauto l:on. *) +(* 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 ih; 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. *) +(* + case : b => //=. *) +(* * hauto lq:on use:T_AbsBind_Imp. *) +(* * hauto lq:on rew:off use:T_PairBind_Imp. *) +(* * move => p1 A1 B1 p0 A0 B0. *) +(* move /algo_metric_bind. *) +(* move => [?][j [ih0 [ih1 ih2]]]_ _. subst. *) +(* move => Γ A hU0 hU1. *) +(* move /Bind_Inv : hU0 => [i0 [hA0 [hB0 hS0]]]. *) +(* move /Bind_Inv : hU1 => [i1 [hA1 [hB1 hS1]]]. *) +(* have ? : Γ ⊢ PUniv i0 ≲ PUniv (max i0 i1) *) +(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) +(* have ? : Γ ⊢ PUniv i1 ≲ PUniv (max i0 i1) *) +(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) +(* have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) +(* have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) +(* have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) *) +(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) +(* have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) *) +(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) - have ihA : A0 ⇔ A1 by hauto l:on. - have hAE : Γ ⊢ A0 ≡ A1 ∈ PUniv (Nat.max i0 i1) - by hauto l:on use:coqeq_sound_mutual. - apply : CE_HRed; eauto using rtc_refl. - constructor => //. +(* have ihA : A0 ⇔ A1 by hauto l:on. *) +(* have hAE : Γ ⊢ A0 ≡ A1 ∈ PUniv (Nat.max i0 i1) *) +(* by hauto l:on use:coqeq_sound_mutual. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* constructor => //. *) - eapply ih; eauto. - apply : ctx_eq_subst_one; eauto. - eauto using Su_Eq. - * move => > /algo_metric_join. - hauto lq:on use:DJoin.bind_univ_noconf. - * move => > /algo_metric_join. - hauto lq:on use:Sub.nat_bind_noconf, Sub.FromJoin. - * move => > /algo_metric_join. - clear. hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. - * move => > /algo_metric_join. clear. - hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv. - + case : b => //=. - * hauto lq:on use:T_AbsUniv_Imp. - * hauto lq:on use:T_PairUniv_Imp. - * qauto l:on use:algo_metric_join, DJoin.bind_univ_noconf, DJoin.symmetric. - * move => i j /algo_metric_join /DJoin.univ_inj ? _ _ Γ A hi hj. - subst. - hauto l:on. - * move => > /algo_metric_join. - hauto lq:on use:Sub.nat_univ_noconf, Sub.FromJoin. - * move => > /algo_metric_join. - clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. - * move => > /algo_metric_join. - clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.suc_inv. - + case : b => //=. - * qauto l:on use:T_AbsNat_Imp. - * qauto l:on use:T_PairNat_Imp. - * move => > /algo_metric_join /Sub.FromJoin. hauto l:on use:Sub.bind_nat_noconf. - * move => > /algo_metric_join /Sub.FromJoin. hauto lq:on use:Sub.univ_nat_noconf. - * hauto l:on. - * move /algo_metric_join. - hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. - (* Zero *) - + case : b => //=. - * hauto lq:on rew:off use:T_AbsZero_Imp. - * hauto lq: on use: T_PairZero_Imp. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.bind_inv. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. - * hauto l:on. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. - (* Suc *) - + case : b => //=. - * hauto lq:on rew:off use:T_AbsSuc_Imp. - * hauto lq:on use:T_PairSuc_Imp. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. - * move => a0 a1 h _ _. - move /algo_metric_suc : h => [j [h4 h5]]. - move => Γ A /Suc_Inv [h0 h1] /Suc_Inv [h2 h3]. - move : ih h4 h5;do!move/[apply]. - move => [ih _]. - move : ih h0 h2;do!move/[apply]. - move => h. apply : CE_HRed; eauto using rtc_refl. - by constructor. - - move : a b h fb fa. abstract : hnfneu. - move => + b. - case : b => //=. - (* NeuAbs *) - + move => a u halg _ nea. split => // Γ A hu /[dup] ha. - move /Abs_Inv => [A0][B0][_]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. - move /Abs_Pi_Inv in ha. - move /algo_metric_neu_abs /(_ nea) : halg. - move => [j0][hj0]halg. - apply : CE_HRed; eauto using rtc_refl. - eapply CE_NeuAbs => //=. - eapply ih; eauto. - (* NeuPair *) - + move => a0 b0 u halg _ neu. - split => // Γ A hu /[dup] wt. - move /Pair_Inv => [A0][B0][ha0][hb0]hU. - 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. - move /algo_metric_neu_pair /(_ neu) : halg => [j [hj [hL hR]]]. - have heL : PProj PL u ⇔ a0 by hauto l:on. - eapply CE_HRed; eauto using rtc_refl. - apply CE_NeuPair; eauto. - eapply ih; eauto. - apply : T_Conv; eauto. - have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i - by hauto l:on use:regularity. - have /E_Symmetric : Γ ⊢ PProj PL u ≡ a0 ∈ A2 by - hauto l:on use:coqeq_sound_mutual. - hauto l:on use:bind_inst. - (* NeuBind: Impossible *) - + move => b p p0 a /algo_metric_join h _ h0. exfalso. - move : h h0. clear. - move /Sub.FromJoin. - hauto l:on use:Sub.hne_bind_noconf. - (* NeuUniv: Impossible *) - + hauto lq:on rew:off use:DJoin.hne_univ_noconf, algo_metric_join. - + hauto lq:on rew:off use:DJoin.hne_nat_noconf, algo_metric_join. - (* Zero *) - + case => //=. - * move => i /algo_metric_join. clear. - hauto lq:on rew:off use:REReds.var_inv, REReds.zero_inv. - * move => >/algo_metric_join. clear. - hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. - * move => >/algo_metric_join. clear. - hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. - * move => >/algo_metric_join. clear. - move => h _ h2. exfalso. - hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. - (* Suc *) - + move => a0. - case => //=; move => >/algo_metric_join; clear. - * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. - * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. - * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. - * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. - - move {ih}. - move /algo_metric_sym in h. - qauto l:on use:coqeq_symmetric_mutual. - - move {hnfneu}. - (* Clear out some trivial cases *) - suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). - move => h0. - split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. - by firstorder. +(* eapply ih; eauto. *) +(* apply : ctx_eq_subst_one; eauto. *) +(* eauto using Su_Eq. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on use:DJoin.bind_univ_noconf. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on use:Sub.nat_bind_noconf, Sub.FromJoin. *) +(* * move => > /algo_metric_join. *) +(* clear. hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. *) +(* * move => > /algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv. *) +(* + case : b => //=. *) +(* * hauto lq:on use:T_AbsUniv_Imp. *) +(* * hauto lq:on use:T_PairUniv_Imp. *) +(* * qauto l:on use:algo_metric_join, DJoin.bind_univ_noconf, DJoin.symmetric. *) +(* * move => i j /algo_metric_join /DJoin.univ_inj ? _ _ Γ A hi hj. *) +(* subst. *) +(* hauto l:on. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on use:Sub.nat_univ_noconf, Sub.FromJoin. *) +(* * move => > /algo_metric_join. *) +(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. *) +(* * move => > /algo_metric_join. *) +(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.suc_inv. *) +(* + case : b => //=. *) +(* * qauto l:on use:T_AbsNat_Imp. *) +(* * qauto l:on use:T_PairNat_Imp. *) +(* * move => > /algo_metric_join /Sub.FromJoin. hauto l:on use:Sub.bind_nat_noconf. *) +(* * move => > /algo_metric_join /Sub.FromJoin. hauto lq:on use:Sub.univ_nat_noconf. *) +(* * hauto l:on. *) +(* * move /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. *) +(* (* Zero *) *) +(* + case : b => //=. *) +(* * hauto lq:on rew:off use:T_AbsZero_Imp. *) +(* * hauto lq: on use: T_PairZero_Imp. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.bind_inv. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. *) +(* * hauto l:on. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. *) +(* (* Suc *) *) +(* + case : b => //=. *) +(* * hauto lq:on rew:off use:T_AbsSuc_Imp. *) +(* * hauto lq:on use:T_PairSuc_Imp. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. *) +(* * move => a0 a1 h _ _. *) +(* move /algo_metric_suc : h => [j [h4 h5]]. *) +(* move => Γ A /Suc_Inv [h0 h1] /Suc_Inv [h2 h3]. *) +(* move : ih h4 h5;do!move/[apply]. *) +(* move => [ih _]. *) +(* move : ih h0 h2;do!move/[apply]. *) +(* move => h. apply : CE_HRed; eauto using rtc_refl. *) +(* by constructor. *) +(* - move : a b h fb fa. abstract : hnfneu. *) +(* move => + b. *) +(* case : b => //=. *) +(* (* NeuAbs *) *) +(* + move => a u halg _ nea. split => // Γ A hu /[dup] ha. *) +(* move /Abs_Inv => [A0][B0][_]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. *) +(* move /Abs_Pi_Inv in ha. *) +(* move /algo_metric_neu_abs /(_ nea) : halg. *) +(* move => [j0][hj0]halg. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* eapply CE_NeuAbs => //=. *) +(* eapply ih; eauto. *) +(* (* NeuPair *) *) +(* + move => a0 b0 u halg _ neu. *) +(* split => // Γ A hu /[dup] wt. *) +(* move /Pair_Inv => [A0][B0][ha0][hb0]hU. *) +(* 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. *) +(* move /algo_metric_neu_pair /(_ neu) : halg => [j [hj [hL hR]]]. *) +(* have heL : PProj PL u ⇔ a0 by hauto l:on. *) +(* eapply CE_HRed; eauto using rtc_refl. *) +(* apply CE_NeuPair; eauto. *) +(* eapply ih; eauto. *) +(* apply : T_Conv; eauto. *) +(* have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i *) +(* by hauto l:on use:regularity. *) +(* have /E_Symmetric : Γ ⊢ PProj PL u ≡ a0 ∈ A2 by *) +(* hauto l:on use:coqeq_sound_mutual. *) +(* hauto l:on use:bind_inst. *) +(* (* NeuBind: Impossible *) *) +(* + move => b p p0 a /algo_metric_join h _ h0. exfalso. *) +(* move : h h0. clear. *) +(* move /Sub.FromJoin. *) +(* hauto l:on use:Sub.hne_bind_noconf. *) +(* (* NeuUniv: Impossible *) *) +(* + hauto lq:on rew:off use:DJoin.hne_univ_noconf, algo_metric_join. *) +(* + hauto lq:on rew:off use:DJoin.hne_nat_noconf, algo_metric_join. *) +(* (* Zero *) *) +(* + case => //=. *) +(* * move => i /algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.var_inv, REReds.zero_inv. *) +(* * move => >/algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. *) +(* * move => >/algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. *) +(* * move => >/algo_metric_join. clear. *) +(* move => h _ h2. exfalso. *) +(* hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. *) +(* (* Suc *) *) +(* + move => a0. *) +(* case => //=; move => >/algo_metric_join; clear. *) +(* * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. *) +(* * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. *) +(* * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. *) +(* - move {ih}. *) +(* move /algo_metric_sym in h. *) +(* qauto l:on use:coqeq_symmetric_mutual. *) +(* - move {hnfneu}. *) +(* (* Clear out some trivial cases *) *) +(* suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). *) +(* move => h0. *) +(* split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. *) +(* by firstorder. *) - case : a h fb fa => //=. - + case : b => //=; move => > /algo_metric_join. - * move /DJoin.var_inj => i _ _. subst. - move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. - move /Var_Inv => [_ [C0 [h2 h3]]]. - have ? : B0 = C0 by eauto using lookup_deter. subst. - sfirstorder use:T_Var. - * clear => ? ? _. exfalso. - hauto l:on use:REReds.var_inv, REReds.hne_app_inv. - * clear => ? ? _. exfalso. - hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. - * clear => ? ? _. exfalso. - hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. - + case : b => //=; - lazymatch goal with - | [|- context[algo_metric _ (PApp _ _) (PApp _ _)]] => idtac - | _ => move => > /algo_metric_join - end. - * clear => *. exfalso. - hauto lq:on rew:off use:REReds.hne_app_inv, REReds.var_inv. - (* real case *) - * move => b1 a1 b0 a0 halg hne1 hne0 Γ A B wtA wtB. - move /App_Inv : wtA => [A0][B0][hb0][ha0]hS0. - move /App_Inv : wtB => [A1][B1][hb1][ha1]hS1. - move : algo_metric_app (hne0) (hne1) halg. repeat move/[apply]. - move => [j [hj [hal0 hal1]]]. - have /ih := hal0. - move /(_ hj). - move => [_ ihb]. - move : ihb (hne0) (hne1) 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 : ih (hj) hal1. repeat move/[apply]. - move => [ih _]. - move : ih (ha0') (ha1'); repeat move/[apply]. - move => iha. - split. qblast. - 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. - * clear => ? ? ?. exfalso. - hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. - * clear => ? ? ?. exfalso. - hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. - + case : b => //=. - * move => i p h /algo_metric_join. clear => ? _ ?. exfalso. - hauto l:on use:REReds.hne_proj_inv, REReds.var_inv. - * move => > /algo_metric_join. clear => ? ? ?. exfalso. - hauto l:on use:REReds.hne_proj_inv, REReds.hne_app_inv. - (* real case *) - * move => p1 a1 p0 a0 /algo_metric_proj ha hne1 hne0. - move : ha (hne0) (hne1); repeat move/[apply]. - move => [? [j []]]. subst. - move : ih; repeat move/[apply]. - move => [_ ih]. - case : p1. - ** move => Γ A B 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 => Γ A B 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 => > /algo_metric_join; clear => ? ? ?. exfalso. - hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. - (* ind ind case *) - + move => P a0 b0 c0. - case : b => //=; - lazymatch goal with - | [|- context[algo_metric _ (PInd _ _ _ _) (PInd _ _ _ _)]] => idtac - | _ => move => > /algo_metric_join; clear => *; exfalso - end. - * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. - * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. - * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. - * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. - move /(_ h1 h0). - move => [j][hj][hP][ha][hb]hc Γ A B hL hR. - move /Ind_Inv : hL => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. - move /Ind_Inv : hR => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. - have {}iha : a0 ∼ a1 by qauto l:on. - have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. - move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. - move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. - have {}ihP : P ⇔ P1 by qauto l:on. - set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. - have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. - have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) - by hauto l:on use:coqeq_sound_mutual. - have haE : Γ ⊢ a0 ≡ a1 ∈ 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) P ≡ 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) P - by eauto using T_Conv_E. - have {}ihb : b0 ⇔ b1 by hauto l:on. - have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. - set T := ren_PTm shift _ in wtc0. - have : (cons P Δ) ⊢ 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. - have hEInd : Γ ⊢ PInd P a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P by hfcrush use:coqeq_sound_mutual. - exists (subst_PTm (scons a0 VarPTm) P). - 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. -Qed. +(* case : a h fb fa => //=. *) +(* + case : b => //=; move => > /algo_metric_join. *) +(* * move /DJoin.var_inj => i _ _. subst. *) +(* move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. *) +(* move /Var_Inv => [_ [C0 [h2 h3]]]. *) +(* have ? : B0 = C0 by eauto using lookup_deter. subst. *) +(* sfirstorder use:T_Var. *) +(* * clear => ? ? _. exfalso. *) +(* hauto l:on use:REReds.var_inv, REReds.hne_app_inv. *) +(* * clear => ? ? _. exfalso. *) +(* hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. *) +(* * clear => ? ? _. exfalso. *) +(* hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. *) +(* + case : b => //=; *) +(* lazymatch goal with *) +(* | [|- context[algo_metric _ (PApp _ _) (PApp _ _)]] => idtac *) +(* | _ => move => > /algo_metric_join *) +(* end. *) +(* * clear => *. exfalso. *) +(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.var_inv. *) +(* (* real case *) *) +(* * move => b1 a1 b0 a0 halg hne1 hne0 Γ A B wtA wtB. *) +(* move /App_Inv : wtA => [A0][B0][hb0][ha0]hS0. *) +(* move /App_Inv : wtB => [A1][B1][hb1][ha1]hS1. *) +(* move : algo_metric_app (hne0) (hne1) halg. repeat move/[apply]. *) +(* move => [j [hj [hal0 hal1]]]. *) +(* have /ih := hal0. *) +(* move /(_ hj). *) +(* move => [_ ihb]. *) +(* move : ihb (hne0) (hne1) 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 : ih (hj) hal1. repeat move/[apply]. *) +(* move => [ih _]. *) +(* move : ih (ha0') (ha1'); repeat move/[apply]. *) +(* move => iha. *) +(* split. qblast. *) +(* 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. *) +(* * clear => ? ? ?. exfalso. *) +(* hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. *) +(* * clear => ? ? ?. exfalso. *) +(* hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. *) +(* + case : b => //=. *) +(* * move => i p h /algo_metric_join. clear => ? _ ?. exfalso. *) +(* hauto l:on use:REReds.hne_proj_inv, REReds.var_inv. *) +(* * move => > /algo_metric_join. clear => ? ? ?. exfalso. *) +(* hauto l:on use:REReds.hne_proj_inv, REReds.hne_app_inv. *) +(* (* real case *) *) +(* * move => p1 a1 p0 a0 /algo_metric_proj ha hne1 hne0. *) +(* move : ha (hne0) (hne1); repeat move/[apply]. *) +(* move => [? [j []]]. subst. *) +(* move : ih; repeat move/[apply]. *) +(* move => [_ ih]. *) +(* case : p1. *) +(* ** move => Γ A B 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 => Γ A B 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 => > /algo_metric_join; clear => ? ? ?. exfalso. *) +(* hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. *) +(* (* ind ind case *) *) +(* + move => P a0 b0 c0. *) +(* case : b => //=; *) +(* lazymatch goal with *) +(* | [|- context[algo_metric _ (PInd _ _ _ _) (PInd _ _ _ _)]] => idtac *) +(* | _ => move => > /algo_metric_join; clear => *; exfalso *) +(* end. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. *) +(* * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. *) +(* move /(_ h1 h0). *) +(* move => [j][hj][hP][ha][hb]hc Γ A B hL hR. *) +(* move /Ind_Inv : hL => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. *) +(* move /Ind_Inv : hR => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. *) +(* have {}iha : a0 ∼ a1 by qauto l:on. *) +(* have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. *) +(* move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. *) +(* move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. *) +(* have {}ihP : P ⇔ P1 by qauto l:on. *) +(* set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. *) +(* have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. *) +(* have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) *) +(* by hauto l:on use:coqeq_sound_mutual. *) +(* have haE : Γ ⊢ a0 ≡ a1 ∈ 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) P ≡ 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) P *) +(* by eauto using T_Conv_E. *) +(* have {}ihb : b0 ⇔ b1 by hauto l:on. *) +(* have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. *) +(* set T := ren_PTm shift _ in wtc0. *) +(* have : (cons P Δ) ⊢ 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. *) +(* have hEInd : Γ ⊢ PInd P a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P by hfcrush use:coqeq_sound_mutual. *) +(* exists (subst_PTm (scons a0 VarPTm) P). *) +(* 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. *) +(* 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 coqeq_sound : forall Γ (a b : PTm) A, *) +(* Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b -> Γ ⊢ a ≡ b ∈ A. *) +(* Proof. sfirstorder use:coqeq_sound_mutual. Qed. *) -Lemma coqeq_complete Γ (a b A : PTm) : - Γ ⊢ a ≡ b ∈ A -> a ⇔ b. -Proof. - move => h. - suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. - eapply fundamental_theorem in h. - move /logrel.SemEq_SN_Join : h. - move => h. - have : exists va vb : PTm, - rtc LoRed.R a va /\ - rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb - by hauto l:on use:DJoin.standardization_lo. - move => [va][vb][hva][hvb][nva][nvb]hj. - move /relations.rtc_nsteps : hva => [i hva]. - move /relations.rtc_nsteps : hvb => [j hvb]. - exists (i + j + size_PTm va + size_PTm vb). - hauto lq:on solve+:lia. -Qed. +(* Lemma coqeq_complete Γ (a b A : PTm) : *) +(* Γ ⊢ a ≡ b ∈ A -> a ⇔ b. *) +(* Proof. *) +(* move => h. *) +(* suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. *) +(* eapply fundamental_theorem in h. *) +(* move /logrel.SemEq_SN_Join : h. *) +(* move => h. *) +(* have : exists va vb : PTm, *) +(* rtc LoRed.R a va /\ *) +(* rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb *) +(* by hauto l:on use:DJoin.standardization_lo. *) +(* move => [va][vb][hva][hvb][nva][nvb]hj. *) +(* move /relations.rtc_nsteps : hva => [i hva]. *) +(* move /relations.rtc_nsteps : hvb => [j hvb]. *) +(* exists (i + j + size_PTm va + size_PTm vb). *) +(* hauto lq:on solve+:lia. *) +(* Qed. *) Reserved Notation "a ≪ b" (at level 70). @@ -1804,295 +1798,295 @@ Scheme coqleq_ind := Induction for CoqLEq Sort Prop Combined Scheme coqleq_mutual from coqleq_ind, coqleq_r_ind. -Definition salgo_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 /\ ESub.R va vb /\ size_PTm va + size_PTm vb + i + j <= k. +(* Definition salgo_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 /\ ESub.R va vb /\ size_PTm va + size_PTm vb + i + j <= k. *) -Lemma salgo_metric_algo_metric k (a b : PTm) : - ishne a \/ ishne b -> - salgo_metric k a b -> - algo_metric k a b. -Proof. - move => h. - move => [i][j][va][vb][hva][hvb][nva][nvb][hS]sz. - rewrite/ESub.R in hS. - move : hS => [va'][vb'][h0][h1]h2. - suff : va' = vb' by sauto lq:on. - have {}hva : rtc RERed.R a va by hauto lq:on use:@relations.rtc_nsteps, REReds.FromRReds, LoReds.ToRReds. - have {}hvb : rtc RERed.R b vb by hauto lq:on use:@relations.rtc_nsteps, REReds.FromRReds, LoReds.ToRReds. - apply REReds.FromEReds in h0, h1. - have : ishne va' \/ ishne vb' by - hauto lq:on rew:off use:@relations.rtc_transitive, REReds.hne_preservation. - hauto lq:on use:Sub1.hne_refl. -Qed. +(* Lemma salgo_metric_algo_metric k (a b : PTm) : *) +(* ishne a \/ ishne b -> *) +(* salgo_metric k a b -> *) +(* algo_metric k a b. *) +(* Proof. *) +(* move => h. *) +(* move => [i][j][va][vb][hva][hvb][nva][nvb][hS]sz. *) +(* rewrite/ESub.R in hS. *) +(* move : hS => [va'][vb'][h0][h1]h2. *) +(* suff : va' = vb' by sauto lq:on. *) +(* have {}hva : rtc RERed.R a va by hauto lq:on use:@relations.rtc_nsteps, REReds.FromRReds, LoReds.ToRReds. *) +(* have {}hvb : rtc RERed.R b vb by hauto lq:on use:@relations.rtc_nsteps, REReds.FromRReds, LoReds.ToRReds. *) +(* apply REReds.FromEReds in h0, h1. *) +(* have : ishne va' \/ ishne vb' by *) +(* hauto lq:on rew:off use:@relations.rtc_transitive, REReds.hne_preservation. *) +(* hauto lq:on use:Sub1.hne_refl. *) +(* Qed. *) -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 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 salgo_metric_case k (a b : PTm ) : - salgo_metric k a b -> - (ishf a \/ ishne a) \/ exists k' a', HRed.R a a' /\ salgo_metric k' a' b /\ k' < k. -Proof. - move=>[i][j][va][vb][h0] [h1][h2][h3][[v [h4 h5]]] h6. - 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:algo_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_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:algo_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_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:algo_metric solve+:lia. - + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. - + sfirstorder use:ne_hne. - + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. - + sfirstorder use:ne_hne. - + sfirstorder use:ne_hne. -Qed. +(* Lemma salgo_metric_case k (a b : PTm ) : *) +(* salgo_metric k a b -> *) +(* (ishf a \/ ishne a) \/ exists k' a', HRed.R a a' /\ salgo_metric k' a' b /\ k' < k. *) +(* Proof. *) +(* move=>[i][j][va][vb][h0] [h1][h2][h3][[v [h4 h5]]] h6. *) +(* 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:algo_metric solve+:lia. *) +(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_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:algo_metric solve+:lia. *) +(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_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:algo_metric solve+:lia. *) +(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) +(* + sfirstorder use:ne_hne. *) +(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) +(* + sfirstorder use:ne_hne. *) +(* + sfirstorder use:ne_hne. *) +(* 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_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 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 algo_metric_caseR k (a b : PTm) : - salgo_metric k a b -> - (ishf b \/ ishne b) \/ exists k' b', HRed.R b b' /\ salgo_metric k' a b' /\ k' < k. -Proof. - move=>[i][j][va][vb][h0] [h1][h2][h3][[v [h4 h5]]] h6. - case : b h1 => //=; try by firstorder. - - inversion 1 as [|A B C D E F]; subst. - hauto qb:on use:ne_hne. - inversion E; subst => /=. - + hauto q:on use:HRed.AppAbs unfold:salgo_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:salgo_metric solve+:lia. - + sfirstorder qb:on use:ne_hne. - - inversion 1 as [|A B C D E F]; subst. - hauto qb:on use:ne_hne. - inversion E; subst => /=. - + hauto lq:on use:HRed.ProjPair unfold:algo_metric solve+:lia. - + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_metric solve+:lia. - - inversion 1 as [|A B C D E F]; subst. - hauto qb:on use:ne_hne. - inversion E; subst => /=. - + hauto lq:on use:HRed.IndZero unfold:algo_metric solve+:lia. - + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. - + sfirstorder use:ne_hne. - + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. - + sfirstorder use:ne_hne. - + sfirstorder use:ne_hne. -Qed. +(* Lemma algo_metric_caseR k (a b : PTm) : *) +(* salgo_metric k a b -> *) +(* (ishf b \/ ishne b) \/ exists k' b', HRed.R b b' /\ salgo_metric k' a b' /\ k' < k. *) +(* Proof. *) +(* move=>[i][j][va][vb][h0] [h1][h2][h3][[v [h4 h5]]] h6. *) +(* case : b h1 => //=; try by firstorder. *) +(* - inversion 1 as [|A B C D E F]; subst. *) +(* hauto qb:on use:ne_hne. *) +(* inversion E; subst => /=. *) +(* + hauto q:on use:HRed.AppAbs unfold:salgo_metric solve+:lia. *) +(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:salgo_metric solve+:lia. *) +(* + sfirstorder qb:on use:ne_hne. *) +(* - inversion 1 as [|A B C D E F]; subst. *) +(* hauto qb:on use:ne_hne. *) +(* inversion E; subst => /=. *) +(* + hauto lq:on use:HRed.ProjPair unfold:algo_metric solve+:lia. *) +(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_metric solve+:lia. *) +(* - inversion 1 as [|A B C D E F]; subst. *) +(* hauto qb:on use:ne_hne. *) +(* inversion E; subst => /=. *) +(* + hauto lq:on use:HRed.IndZero unfold:algo_metric solve+:lia. *) +(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) +(* + sfirstorder use:ne_hne. *) +(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) +(* + sfirstorder use:ne_hne. *) +(* + sfirstorder use:ne_hne. *) +(* Qed. *) -Lemma salgo_metric_sub k (a b : PTm) : - salgo_metric k a b -> - Sub.R a b. -Proof. - rewrite /algo_metric. - move => [i][j][va][vb][h0][h1][h2][h3][[va' [vb' [hva [hvb hS]]]]]h5. - have {}h0 : rtc LoRed.R a va by hauto lq:on use:@relations.rtc_nsteps. - have {}h1 : rtc LoRed.R b vb by hauto lq:on use:@relations.rtc_nsteps. - apply REReds.FromEReds in hva,hvb. - apply LoReds.ToRReds in h0,h1. - apply REReds.FromRReds in h0,h1. - rewrite /Sub.R. exists va', vb'. sfirstorder use:@relations.rtc_transitive. -Qed. +(* Lemma salgo_metric_sub k (a b : PTm) : *) +(* salgo_metric k a b -> *) +(* Sub.R a b. *) +(* Proof. *) +(* rewrite /algo_metric. *) +(* move => [i][j][va][vb][h0][h1][h2][h3][[va' [vb' [hva [hvb hS]]]]]h5. *) +(* have {}h0 : rtc LoRed.R a va by hauto lq:on use:@relations.rtc_nsteps. *) +(* have {}h1 : rtc LoRed.R b vb by hauto lq:on use:@relations.rtc_nsteps. *) +(* apply REReds.FromEReds in hva,hvb. *) +(* apply LoReds.ToRReds in h0,h1. *) +(* apply REReds.FromRReds in h0,h1. *) +(* rewrite /Sub.R. exists va', vb'. sfirstorder use:@relations.rtc_transitive. *) +(* Qed. *) -Lemma salgo_metric_pi k (A0 : PTm) B0 A1 B1 : - salgo_metric k (PBind PPi A0 B0) (PBind PPi A1 B1) -> - exists j, j < k /\ salgo_metric j A1 A0 /\ salgo_metric j B0 B1. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. - move : lored_nsteps_bind_inv h0 => /[apply]. - move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. - move : lored_nsteps_bind_inv h1 => /[apply]. - move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. - move /ESub.pi_inj : h4 => [? ?]. - hauto qb:on solve+:lia. -Qed. +(* Lemma salgo_metric_pi k (A0 : PTm) B0 A1 B1 : *) +(* salgo_metric k (PBind PPi A0 B0) (PBind PPi A1 B1) -> *) +(* exists j, j < k /\ salgo_metric j A1 A0 /\ salgo_metric j B0 B1. *) +(* Proof. *) +(* move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. *) +(* move : lored_nsteps_bind_inv h0 => /[apply]. *) +(* move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. *) +(* move : lored_nsteps_bind_inv h1 => /[apply]. *) +(* move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. *) +(* move /ESub.pi_inj : h4 => [? ?]. *) +(* hauto qb:on solve+:lia. *) +(* Qed. *) -Lemma salgo_metric_sig k (A0 : PTm) B0 A1 B1 : - salgo_metric k (PBind PSig A0 B0) (PBind PSig A1 B1) -> - exists j, j < k /\ salgo_metric j A0 A1 /\ salgo_metric j B0 B1. -Proof. - move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. - move : lored_nsteps_bind_inv h0 => /[apply]. - move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. - move : lored_nsteps_bind_inv h1 => /[apply]. - move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. - move /ESub.sig_inj : h4 => [? ?]. - hauto qb:on solve+:lia. -Qed. +(* Lemma salgo_metric_sig k (A0 : PTm) B0 A1 B1 : *) +(* salgo_metric k (PBind PSig A0 B0) (PBind PSig A1 B1) -> *) +(* exists j, j < k /\ salgo_metric j A0 A1 /\ salgo_metric j B0 B1. *) +(* Proof. *) +(* move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. *) +(* move : lored_nsteps_bind_inv h0 => /[apply]. *) +(* move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. *) +(* move : lored_nsteps_bind_inv h1 => /[apply]. *) +(* move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. *) +(* move /ESub.sig_inj : h4 => [? ?]. *) +(* hauto qb:on solve+:lia. *) +(* Qed. *) -Lemma coqleq_complete' k (a b : PTm ) : - salgo_metric k a b -> (forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> a ≪ b). -Proof. - move : k a b. - elim /Wf_nat.lt_wf_ind. - move => n ih. - move => a b /[dup] h /salgo_metric_case. - (* Cases where a and b can take steps *) - case; cycle 1. - move : a b h. - qauto l:on use:HRed.preservation, CLE_HRedL, hred_hne. - case /algo_metric_caseR : (h); cycle 1. - qauto l:on use:HRed.preservation, CLE_HRedR, hred_hne. - (* Cases where neither a nor b can take steps *) - case => fb; case => fa. - - case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - * move => p0 A0 B0 _ p1 A1 B1 _. - move => h. - have ? : p1 = p0 by - hauto lq:on rew:off use:salgo_metric_sub, Sub.bind_inj. - subst. - case : p0 h => //=. - ** move /salgo_metric_pi. - move => [j [hj [hA hB]]] Γ i. - move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. - have ihA : A0 ≪ A1 by hauto l:on. - econstructor; eauto using E_Refl; 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. - ** move /salgo_metric_sig. - move => [j [hj [hA hB]]] Γ i. - move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. - have ihA : A1 ≪ A0 by hauto l:on. - econstructor; eauto using E_Refl; 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. - * hauto lq:on use:salgo_metric_sub, Sub.bind_univ_noconf. - * hauto lq:on use:salgo_metric_sub, Sub.nat_bind_noconf. - * move => _ > _ /salgo_metric_sub. - hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv inv:Sub1.R. - * hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. - + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - * hauto lq:on use:salgo_metric_sub, Sub.univ_bind_noconf. - * move => *. econstructor; eauto using rtc_refl. - hauto lq:on use:salgo_metric_sub, Sub.univ_inj, CLE_UnivCong. - * hauto lq:on rew:off use:REReds.univ_inv, REReds.nat_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. - (* Both cases are impossible *) - + case : b fb => //=. - * hauto lq:on use:T_AbsNat_Imp. - * hauto lq:on use:T_PairNat_Imp. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.bind_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. - * hauto l:on. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. - + move => ? ? Γ i /Zero_Inv. - clear. - move /synsub_to_usub => [_ [_ ]]. - hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. - + move => ? _ _ Γ i /Suc_Inv => [[_]]. - move /synsub_to_usub. - hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. - - have {}h : DJoin.R a b by - hauto lq:on use:salgo_metric_algo_metric, algo_metric_join. - case : b fb h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - + hauto lq:on use:DJoin.hne_bind_noconf. - + hauto lq:on use:DJoin.hne_univ_noconf. - + hauto lq:on use:DJoin.hne_nat_noconf. - + move => _ _ Γ i _. - move /Zero_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - + move => p _ _ Γ i _ /Suc_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - - have {}h : DJoin.R b a by - hauto lq:on use:salgo_metric_algo_metric, algo_metric_join, DJoin.symmetric. - case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - + hauto lq:on use:DJoin.hne_bind_noconf. - + hauto lq:on use:DJoin.hne_univ_noconf. - + hauto lq:on use:DJoin.hne_nat_noconf. - + move => _ _ Γ i. - move /Zero_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - + move => p _ _ Γ i /Suc_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - - move => Γ i ha hb. - econstructor; eauto using rtc_refl. - apply CLE_NeuNeu. move {ih}. - have {}h : algo_metric n a b by - hauto lq:on use:salgo_metric_algo_metric. - eapply coqeq_complete'; eauto. -Qed. +(* Lemma coqleq_complete' k (a b : PTm ) : *) +(* salgo_metric k a b -> (forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> a ≪ b). *) +(* Proof. *) +(* move : k a b. *) +(* elim /Wf_nat.lt_wf_ind. *) +(* move => n ih. *) +(* move => a b /[dup] h /salgo_metric_case. *) +(* (* Cases where a and b can take steps *) *) +(* case; cycle 1. *) +(* move : a b h. *) +(* qauto l:on use:HRed.preservation, CLE_HRedL, hred_hne. *) +(* case /algo_metric_caseR : (h); cycle 1. *) +(* qauto l:on use:HRed.preservation, CLE_HRedR, hred_hne. *) +(* (* Cases where neither a nor b can take steps *) *) +(* case => fb; case => fa. *) +(* - case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) +(* + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) +(* * move => p0 A0 B0 _ p1 A1 B1 _. *) +(* move => h. *) +(* have ? : p1 = p0 by *) +(* hauto lq:on rew:off use:salgo_metric_sub, Sub.bind_inj. *) +(* subst. *) +(* case : p0 h => //=. *) +(* ** move /salgo_metric_pi. *) +(* move => [j [hj [hA hB]]] Γ i. *) +(* move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. *) +(* have ihA : A0 ≪ A1 by hauto l:on. *) +(* econstructor; eauto using E_Refl; 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. *) +(* ** move /salgo_metric_sig. *) +(* move => [j [hj [hA hB]]] Γ i. *) +(* move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. *) +(* have ihA : A1 ≪ A0 by hauto l:on. *) +(* econstructor; eauto using E_Refl; 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. *) +(* * hauto lq:on use:salgo_metric_sub, Sub.bind_univ_noconf. *) +(* * hauto lq:on use:salgo_metric_sub, Sub.nat_bind_noconf. *) +(* * move => _ > _ /salgo_metric_sub. *) +(* hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv inv:Sub1.R. *) +(* * hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. *) +(* + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) +(* * hauto lq:on use:salgo_metric_sub, Sub.univ_bind_noconf. *) +(* * move => *. econstructor; eauto using rtc_refl. *) +(* hauto lq:on use:salgo_metric_sub, Sub.univ_inj, CLE_UnivCong. *) +(* * hauto lq:on rew:off use:REReds.univ_inv, REReds.nat_inv, salgo_metric_sub inv:Sub1.R. *) +(* * hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. *) +(* * hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. *) +(* (* Both cases are impossible *) *) +(* + case : b fb => //=. *) +(* * hauto lq:on use:T_AbsNat_Imp. *) +(* * hauto lq:on use:T_PairNat_Imp. *) +(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.bind_inv, salgo_metric_sub inv:Sub1.R. *) +(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. *) +(* * hauto l:on. *) +(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. *) +(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. *) +(* + move => ? ? Γ i /Zero_Inv. *) +(* clear. *) +(* move /synsub_to_usub => [_ [_ ]]. *) +(* hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. *) +(* + move => ? _ _ Γ i /Suc_Inv => [[_]]. *) +(* move /synsub_to_usub. *) +(* hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. *) +(* - have {}h : DJoin.R a b by *) +(* hauto lq:on use:salgo_metric_algo_metric, algo_metric_join. *) +(* case : b fb h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) +(* + hauto lq:on use:DJoin.hne_bind_noconf. *) +(* + hauto lq:on use:DJoin.hne_univ_noconf. *) +(* + hauto lq:on use:DJoin.hne_nat_noconf. *) +(* + move => _ _ Γ i _. *) +(* move /Zero_Inv. *) +(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) +(* + move => p _ _ Γ i _ /Suc_Inv. *) +(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) +(* - have {}h : DJoin.R b a by *) +(* hauto lq:on use:salgo_metric_algo_metric, algo_metric_join, DJoin.symmetric. *) +(* case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) +(* + hauto lq:on use:DJoin.hne_bind_noconf. *) +(* + hauto lq:on use:DJoin.hne_univ_noconf. *) +(* + hauto lq:on use:DJoin.hne_nat_noconf. *) +(* + move => _ _ Γ i. *) +(* move /Zero_Inv. *) +(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) +(* + move => p _ _ Γ i /Suc_Inv. *) +(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) +(* - move => Γ i ha hb. *) +(* econstructor; eauto using rtc_refl. *) +(* apply CLE_NeuNeu. move {ih}. *) +(* have {}h : algo_metric n a b by *) +(* hauto lq:on use:salgo_metric_algo_metric. *) +(* eapply coqeq_complete'; eauto. *) +(* Qed. *) -Lemma coqleq_complete Γ (a b : PTm) : - Γ ⊢ a ≲ b -> a ≪ b. -Proof. - move => h. - suff : exists k, salgo_metric k a b by hauto lq:on use:coqleq_complete', regularity. - eapply fundamental_theorem in h. - move /logrel.SemLEq_SN_Sub : h. - move => h. - have : exists va vb : PTm , - rtc LoRed.R a va /\ - rtc LoRed.R b vb /\ nf va /\ nf vb /\ ESub.R va vb - by hauto l:on use:Sub.standardization_lo. - move => [va][vb][hva][hvb][nva][nvb]hj. - move /relations.rtc_nsteps : hva => [i hva]. - move /relations.rtc_nsteps : hvb => [j hvb]. - exists (i + j + size_PTm va + size_PTm vb). - hauto lq:on solve+:lia. -Qed. +(* Lemma coqleq_complete Γ (a b : PTm) : *) +(* Γ ⊢ a ≲ b -> a ≪ b. *) +(* Proof. *) +(* move => h. *) +(* suff : exists k, salgo_metric k a b by hauto lq:on use:coqleq_complete', regularity. *) +(* eapply fundamental_theorem in h. *) +(* move /logrel.SemLEq_SN_Sub : h. *) +(* move => h. *) +(* have : exists va vb : PTm , *) +(* rtc LoRed.R a va /\ *) +(* rtc LoRed.R b vb /\ nf va /\ nf vb /\ ESub.R va vb *) +(* by hauto l:on use:Sub.standardization_lo. *) +(* move => [va][vb][hva][hvb][nva][nvb]hj. *) +(* move /relations.rtc_nsteps : hva => [i hva]. *) +(* move /relations.rtc_nsteps : hvb => [j hvb]. *) +(* exists (i + j + size_PTm va + size_PTm vb). *) +(* hauto lq:on solve+:lia. *) +(* 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. +(* 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 index 266d90a..18f4dfb 100644 --- a/theories/common.v +++ b/theories/common.v @@ -400,6 +400,8 @@ with salgo_dom_r : PTm -> PTm -> Prop := 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. Lemma hf_no_hred (a b : PTm) : ishf a -> diff --git a/theories/executable_correct.v b/theories/executable_correct.v index 6ccee46..d51af9d 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -23,6 +23,14 @@ 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). @@ -63,15 +71,15 @@ Proof. - 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 => 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 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]. @@ -117,14 +125,14 @@ Proof. - 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 => 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 b0 b1 c0 c1 neu0 neu1 domP ihP domu ihu domb ihb domc ihc. rewrite check_equal_ind_ind. move => + h. @@ -172,39 +180,42 @@ Qed. Ltac simp_sub := with_strategy opaque [check_equal] simpl in *. +Combined Scheme salgo_dom_mutual from salgo_ind, salgor_ind. + (* Reusing algo_dom results in an inefficient proof, but i'll brute force it so i can get the result more quickly *) +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. + +Hint Rewrite check_sub_neuneu check_sub_conf : ce_prop. + Lemma check_sub_sound : - (forall a b (h : algo_dom a b), forall q, check_sub q a b h -> if q then a ⋖ b else b ⋖ a) /\ - (forall a b (h : algo_dom_r a b), forall q, check_sub_r q a b h -> if q then a ≪ b else b ≪ a). + (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 algo_dom_mutual; try done. - - move => a [] //=; hauto qb:on. - - move => a0 a1 []//=; hauto qb:on. + apply salgo_dom_mutual; try done. - simpl. move => i j []; sauto lq:on use:Reflect.Nat_leb_le. - - move => p0 p1 A0 A1 B0 B1 a iha b ihb q. - case : p0; case : p1; try done; simp ce_prop. - sauto lqb:on. - sauto lqb:on. - - hauto l:on. - - move => i j q h. - have {}h : nat_eqdec i j by sfirstorder. - case : nat_eqdec h => //=; sauto lq:on. - - simp_sub. - sauto lqb:on use:coqeq_symmetric_mutual, coqeq_neuneu, check_equal_sound. - - simp_sub. - sauto lqb:on use:coqeq_symmetric_mutual, coqeq_neuneu, check_equal_sound. - - simp_sub. - sauto lqb:on use:coqeq_symmetric_mutual, coqeq_neuneu, check_equal_sound. - - move => a b n n0 i q h. - exfalso. - destruct a, b; try done; simp_sub; hauto lb:on use:check_equal_conf. - - move => a b doma ihdom q. - simp ce_prop. sauto lq:on. - - move => a a' b hr doma ihdom q. - simp ce_prop. move : ihdom => /[apply]. move {doma}. - sauto lq:on. - - move => a b b' n r dom ihdom q. + - 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}. @@ -212,91 +223,51 @@ Proof. Qed. Lemma check_sub_complete : - (forall a b (h : algo_dom a b), forall q, check_sub q a b h = false -> if q then ~ a ⋖ b else ~ b ⋖ a) /\ - (forall a b (h : algo_dom_r a b), forall q, check_sub_r q a b h = false -> if q then ~ a ≪ b else ~ b ≪ a). + (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 algo_dom_mutual; try first [done | hauto depth:4 lq:on inv:CoqLEq, CoqEq_Neu]. - - move => i j q /=. - sauto lq:on rew:off use:PeanoNat.Nat.leb_le. - - move => p0 p1 A0 A1 B0 B1 a iha b ihb []. - + move => + h. inversion h; subst; simp ce_prop. - * move /nandP. - case. - by move => /negbTE {}/iha. - by move => /negbTE {}/ihb. - * move /nandP. - case. - by move => /negbTE {}/iha. - by move => /negbTE {}/ihb. - * inversion H. - + move => + h. inversion h; subst; simp ce_prop. - * move /nandP. - case. - by move => /negbTE {}/iha. - by move => /negbTE {}/ihb. - * move /nandP. - case. - by move => /negbTE {}/iha. - by move => /negbTE {}/ihb. - * inversion H. - - simp_sub. - sauto lq:on use:check_equal_complete. - - simp_sub. - move => p0 p1 u0 u1 i i0 a iha q. + 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 /nandP. - case => //. - by move /negP. - by move /negP. - move /negP. - move => h. eapply check_equal_complete in h. - sauto use:coqeq_symmetric_mutual inv:CoqLEq lq:on. - - move => u0 u1 a0 a1 i i0 a hdom ihdom hdom' ihdom'. - simp_sub. + 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/nandP. - case. - by move/negP. - by move/negP. - move /negP. - move => h. eapply check_equal_complete in h. - sauto use:coqeq_symmetric_mutual inv:CoqLEq lq:on. - - move => P0 P1 u0 u1 b0 b1 c0 c1 i i0 dom ihdom dom' ihdom' dom'' ihdom'' dom''' ihdom''' q. - move /nandP. - case. - move /nandP. - case => //=. - by move/negP. - by move/negP. - move /negP => h. eapply check_equal_complete in h. - sauto use:coqeq_symmetric_mutual inv:CoqLEq lq:on. - - move => a b h ih q. simp ce_prop => {}/ih. - case : q => h0; - inversion 1; subst; hauto l:on use:algo_dom_no_hred, hreds_nf_refl. - - move => a a' b r dom ihdom q. - simp ce_prop => {}/ihdom. - case : q => h0. - inversion 1; subst. - inversion H0; subst. sfirstorder use:coqleq_no_hred. - have ? : a' = y by eauto using hred_deter. subst. - sauto lq:on. - inversion 1; subst. - inversion H1; subst. sfirstorder use:coqleq_no_hred. - have ? : a' = y by eauto using hred_deter. subst. - sauto lq:on. - - move => a b b' n r hr ih q. - simp ce_prop => {}/ih. - case : q. - + move => h. inversion 1; subst. - inversion H1; subst. - sfirstorder use:coqleq_no_hred. - have ? : b' = y by eauto using hred_deter. subst. - sauto lq:on. - + move => h. inversion 1; subst. - inversion H0; subst. - sfirstorder use:coqleq_no_hred. - have ? : b' = y by eauto using hred_deter. subst. + 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 i0 i1 j. simp ce_prop. + move => _ h. inversion h; subst => //=. + hauto lq:on inv:CoqEq_Neu unfold:stm_conf. + - 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. From 30caf750020c28a5b4e55d68c0354ddbdd5c22bb Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 19:58:19 -0400 Subject: [PATCH 34/51] Make progress on the refactored lemma --- theories/algorithmic.v | 1055 +++++++++++++++++++++------------------- 1 file changed, 562 insertions(+), 493 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index de58fd4..ace67ac 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -252,22 +252,6 @@ Proof. apply : ctx_eq_subst_one; eauto. 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 Abs_Pi_Inv Γ (a : PTm) A B : Γ ⊢ PAbs a ∈ PBind PPi A B -> (cons A Γ) ⊢ a ∈ B. @@ -288,6 +272,48 @@ Proof. 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. @@ -422,6 +448,10 @@ 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 @@ -1272,489 +1302,528 @@ Proof. hauto lq:on use:term_metric_ind, algo_dom_r_algo_dom db:adom. Qed. -(* Lemma coqeq_complete' k (a b : PTm ) : *) -(* (forall a b, algo_dom a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b) *) +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 => [: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}. + admit. + - move {hhAbsNeu}. abstract : hhPairNeu. + admit. + - 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 => p0 p1 A0 A1 B0 B1. -(* algo_metric k 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). *) -(* Proof. *) -(* move : k a b. *) -(* elim /Wf_nat.lt_wf_ind. *) -(* move => n ih. *) -(* move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. *) -(* move => a b h. *) -(* (* Cases where a and b can take steps *) *) -(* case; cycle 1. *) -(* move : ih a b h. *) -(* abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. *) -(* move /algo_metric_sym /algo_metric_case : (h). *) -(* case; cycle 1. *) -(* move /algo_metric_sym : h. *) -(* move : hstepL ih => /[apply]/[apply]. *) -(* repeat move /[apply]. *) -(* move => hstepL. *) -(* hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. *) -(* (* Cases where a and b can't take wh steps *) *) -(* move {hstepL}. *) -(* move : a b h. move => [:hnfneu]. *) -(* move => a b h. *) -(* case => fb; case => fa. *) -(* - split; last by sfirstorder use:hf_not_hne. *) -(* move {hnfneu}. *) -(* case : a h fb fa => //=. *) -(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_AbsBind_Imp, T_AbsUniv_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_AbsNat_Imp. *) -(* move => a0 a1 ha0 _ _ Γ A wt0 wt1. *) -(* move : T_Abs_Inv wt0 wt1; repeat move/[apply]. move => [Δ [V [wt1 wt0]]]. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* apply CE_AbsAbs. *) -(* suff [l [h0 h1]] : exists l, l < n /\ algo_metric l a1 a0 by eapply ih; eauto. *) -(* have ? : n > 0 by sauto solve+:lia. *) -(* exists (n - 1). split; first by lia. *) -(* move : (ha0). rewrite /algo_metric. *) -(* move => [i][j][va][vb][hr0][hr1][nfva][nfvb][[v [hr0' hr1']]] har. *) -(* apply lored_nsteps_abs_inv in hr0, hr1. *) -(* move : hr0 => [va' [hr00 hr01]]. *) -(* move : hr1 => [vb' [hr10 hr11]]. move {ih}. *) -(* exists i,j,va',vb'. subst. *) -(* suff [v0 [hv00 hv01]] : exists v0, rtc ERed.R va' v0 /\ rtc ERed.R vb' v0. *) -(* repeat split =>//=. sfirstorder. *) -(* simpl in *; by lia. *) -(* move /algo_metric_join /DJoin.symmetric : ha0. *) -(* have : SN a0 /\ SN a1 by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) -(* move => /[dup] [[ha00 ha10]] []. *) -(* move : DJoin.abs_inj; repeat move/[apply]. *) -(* move : DJoin.standardization ha00 ha10; repeat move/[apply]. *) -(* (* this is awful *) *) -(* move => [vb][va][h' [h'' [h''' [h'''' h'''''']]]]. *) -(* have /LoReds.ToRReds {}hr00 : rtc LoRed.R a1 va' *) -(* by hauto lq:on use:@relations.rtc_nsteps. *) -(* have /LoReds.ToRReds {}hr10 : rtc LoRed.R a0 vb' *) -(* by hauto lq:on use:@relations.rtc_nsteps. *) -(* simpl in *. *) -(* have [*] : va' = va /\ vb' = vb by eauto using red_uniquenf. subst. *) -(* sfirstorder. *) -(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_PairBind_Imp, T_PairUniv_Imp, T_PairNat_Imp, T_PairSuc_Imp, T_PairZero_Imp. *) -(* move => a1 b1 a0 b0 h _ _ Γ A hu0 hu1. *) -(* have [sn0 sn1] : SN (PPair a0 b0) /\ SN (PPair a1 b1) *) -(* by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* move /Pair_Inv : hu0 => [A0][B0][ha0][hb0]hSu0. *) -(* move /Pair_Inv : hu1 => [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 /algo_metric_pair : h sn0 sn1; repeat move/[apply]. *) -(* move => [j][hj][ih0 ih1]. *) -(* have haE : a0 ⇔ a1 by hauto l:on. *) -(* 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 ih; 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. *) -(* + case : b => //=. *) -(* * hauto lq:on use:T_AbsBind_Imp. *) -(* * hauto lq:on rew:off use:T_PairBind_Imp. *) -(* * move => p1 A1 B1 p0 A0 B0. *) -(* move /algo_metric_bind. *) -(* move => [?][j [ih0 [ih1 ih2]]]_ _. subst. *) -(* move => Γ A hU0 hU1. *) -(* move /Bind_Inv : hU0 => [i0 [hA0 [hB0 hS0]]]. *) -(* move /Bind_Inv : hU1 => [i1 [hA1 [hB1 hS1]]]. *) -(* have ? : Γ ⊢ PUniv i0 ≲ PUniv (max i0 i1) *) -(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) -(* have ? : Γ ⊢ PUniv i1 ≲ PUniv (max i0 i1) *) -(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) -(* have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) -(* have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) -(* have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) *) -(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) -(* have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) *) -(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) -(* have ihA : A0 ⇔ A1 by hauto l:on. *) -(* have hAE : Γ ⊢ A0 ≡ A1 ∈ PUniv (Nat.max i0 i1) *) -(* by hauto l:on use:coqeq_sound_mutual. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* constructor => //. *) + algo_metric k 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). +Proof. + move : k a b. + elim /Wf_nat.lt_wf_ind. + move => n ih. + move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. + move => a b h. + (* Cases where a and b can take steps *) + case; cycle 1. + move : ih a b h. + abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. + move /algo_metric_sym /algo_metric_case : (h). + case; cycle 1. + move /algo_metric_sym : h. + move : hstepL ih => /[apply]/[apply]. + repeat move /[apply]. + move => hstepL. + hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. + (* Cases where a and b can't take wh steps *) + move {hstepL}. + move : a b h. move => [:hnfneu]. + move => a b h. + case => fb; case => fa. + - split; last by sfirstorder use:hf_not_hne. + move {hnfneu}. + case : a h fb fa => //=. + + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_AbsBind_Imp, T_AbsUniv_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_AbsNat_Imp. + move => a0 a1 ha0 _ _ Γ A wt0 wt1. + move : T_Abs_Inv wt0 wt1; repeat move/[apply]. move => [Δ [V [wt1 wt0]]]. + apply : CE_HRed; eauto using rtc_refl. + apply CE_AbsAbs. + suff [l [h0 h1]] : exists l, l < n /\ algo_metric l a1 a0 by eapply ih; eauto. + have ? : n > 0 by sauto solve+:lia. + exists (n - 1). split; first by lia. + move : (ha0). rewrite /algo_metric. + move => [i][j][va][vb][hr0][hr1][nfva][nfvb][[v [hr0' hr1']]] har. + apply lored_nsteps_abs_inv in hr0, hr1. + move : hr0 => [va' [hr00 hr01]]. + move : hr1 => [vb' [hr10 hr11]]. move {ih}. + exists i,j,va',vb'. subst. + suff [v0 [hv00 hv01]] : exists v0, rtc ERed.R va' v0 /\ rtc ERed.R vb' v0. + repeat split =>//=. sfirstorder. + simpl in *; by lia. + move /algo_metric_join /DJoin.symmetric : ha0. + have : SN a0 /\ SN a1 by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. + move => /[dup] [[ha00 ha10]] []. + move : DJoin.abs_inj; repeat move/[apply]. + move : DJoin.standardization ha00 ha10; repeat move/[apply]. + (* this is awful *) + move => [vb][va][h' [h'' [h''' [h'''' h'''''']]]]. + have /LoReds.ToRReds {}hr00 : rtc LoRed.R a1 va' + by hauto lq:on use:@relations.rtc_nsteps. + have /LoReds.ToRReds {}hr10 : rtc LoRed.R a0 vb' + by hauto lq:on use:@relations.rtc_nsteps. + simpl in *. + have [*] : va' = va /\ vb' = vb by eauto using red_uniquenf. subst. + sfirstorder. + + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_PairBind_Imp, T_PairUniv_Imp, T_PairNat_Imp, T_PairSuc_Imp, T_PairZero_Imp. + move => a1 b1 a0 b0 h _ _ Γ A hu0 hu1. + have [sn0 sn1] : SN (PPair a0 b0) /\ SN (PPair a1 b1) + by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. + apply : CE_HRed; eauto using rtc_refl. + move /Pair_Inv : hu0 => [A0][B0][ha0][hb0]hSu0. + move /Pair_Inv : hu1 => [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 /algo_metric_pair : h sn0 sn1; repeat move/[apply]. + move => [j][hj][ih0 ih1]. + have haE : a0 ⇔ a1 by hauto l:on. + 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 ih; 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. + + case : b => //=. + * hauto lq:on use:T_AbsBind_Imp. + * hauto lq:on rew:off use:T_PairBind_Imp. + * move => p1 A1 B1 p0 A0 B0. + move /algo_metric_bind. + move => [?][j [ih0 [ih1 ih2]]]_ _. subst. + move => Γ A hU0 hU1. + move /Bind_Inv : hU0 => [i0 [hA0 [hB0 hS0]]]. + move /Bind_Inv : hU1 => [i1 [hA1 [hB1 hS1]]]. + have ? : Γ ⊢ PUniv i0 ≲ PUniv (max i0 i1) + by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. + have ? : Γ ⊢ PUniv i1 ≲ PUniv (max i0 i1) + by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. + have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. + have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. + have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) + by hauto lq:on use:T_Univ_Raise solve+:lia. + have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) + by hauto lq:on use:T_Univ_Raise solve+:lia. -(* eapply ih; eauto. *) -(* apply : ctx_eq_subst_one; eauto. *) -(* eauto using Su_Eq. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on use:DJoin.bind_univ_noconf. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on use:Sub.nat_bind_noconf, Sub.FromJoin. *) -(* * move => > /algo_metric_join. *) -(* clear. hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. *) -(* * move => > /algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv. *) -(* + case : b => //=. *) -(* * hauto lq:on use:T_AbsUniv_Imp. *) -(* * hauto lq:on use:T_PairUniv_Imp. *) -(* * qauto l:on use:algo_metric_join, DJoin.bind_univ_noconf, DJoin.symmetric. *) -(* * move => i j /algo_metric_join /DJoin.univ_inj ? _ _ Γ A hi hj. *) -(* subst. *) -(* hauto l:on. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on use:Sub.nat_univ_noconf, Sub.FromJoin. *) -(* * move => > /algo_metric_join. *) -(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. *) -(* * move => > /algo_metric_join. *) -(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.suc_inv. *) -(* + case : b => //=. *) -(* * qauto l:on use:T_AbsNat_Imp. *) -(* * qauto l:on use:T_PairNat_Imp. *) -(* * move => > /algo_metric_join /Sub.FromJoin. hauto l:on use:Sub.bind_nat_noconf. *) -(* * move => > /algo_metric_join /Sub.FromJoin. hauto lq:on use:Sub.univ_nat_noconf. *) -(* * hauto l:on. *) -(* * move /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. *) -(* (* Zero *) *) -(* + case : b => //=. *) -(* * hauto lq:on rew:off use:T_AbsZero_Imp. *) -(* * hauto lq: on use: T_PairZero_Imp. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.bind_inv. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. *) -(* * hauto l:on. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. *) -(* (* Suc *) *) -(* + case : b => //=. *) -(* * hauto lq:on rew:off use:T_AbsSuc_Imp. *) -(* * hauto lq:on use:T_PairSuc_Imp. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. *) -(* * move => a0 a1 h _ _. *) -(* move /algo_metric_suc : h => [j [h4 h5]]. *) -(* move => Γ A /Suc_Inv [h0 h1] /Suc_Inv [h2 h3]. *) -(* move : ih h4 h5;do!move/[apply]. *) -(* move => [ih _]. *) -(* move : ih h0 h2;do!move/[apply]. *) -(* move => h. apply : CE_HRed; eauto using rtc_refl. *) -(* by constructor. *) -(* - move : a b h fb fa. abstract : hnfneu. *) -(* move => + b. *) -(* case : b => //=. *) -(* (* NeuAbs *) *) -(* + move => a u halg _ nea. split => // Γ A hu /[dup] ha. *) -(* move /Abs_Inv => [A0][B0][_]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. *) -(* move /Abs_Pi_Inv in ha. *) -(* move /algo_metric_neu_abs /(_ nea) : halg. *) -(* move => [j0][hj0]halg. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* eapply CE_NeuAbs => //=. *) -(* eapply ih; eauto. *) -(* (* NeuPair *) *) -(* + move => a0 b0 u halg _ neu. *) -(* split => // Γ A hu /[dup] wt. *) -(* move /Pair_Inv => [A0][B0][ha0][hb0]hU. *) -(* 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. *) -(* move /algo_metric_neu_pair /(_ neu) : halg => [j [hj [hL hR]]]. *) -(* have heL : PProj PL u ⇔ a0 by hauto l:on. *) -(* eapply CE_HRed; eauto using rtc_refl. *) -(* apply CE_NeuPair; eauto. *) -(* eapply ih; eauto. *) -(* apply : T_Conv; eauto. *) -(* have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i *) -(* by hauto l:on use:regularity. *) -(* have /E_Symmetric : Γ ⊢ PProj PL u ≡ a0 ∈ A2 by *) -(* hauto l:on use:coqeq_sound_mutual. *) -(* hauto l:on use:bind_inst. *) -(* (* NeuBind: Impossible *) *) -(* + move => b p p0 a /algo_metric_join h _ h0. exfalso. *) -(* move : h h0. clear. *) -(* move /Sub.FromJoin. *) -(* hauto l:on use:Sub.hne_bind_noconf. *) -(* (* NeuUniv: Impossible *) *) -(* + hauto lq:on rew:off use:DJoin.hne_univ_noconf, algo_metric_join. *) -(* + hauto lq:on rew:off use:DJoin.hne_nat_noconf, algo_metric_join. *) -(* (* Zero *) *) -(* + case => //=. *) -(* * move => i /algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.var_inv, REReds.zero_inv. *) -(* * move => >/algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. *) -(* * move => >/algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. *) -(* * move => >/algo_metric_join. clear. *) -(* move => h _ h2. exfalso. *) -(* hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. *) -(* (* Suc *) *) -(* + move => a0. *) -(* case => //=; move => >/algo_metric_join; clear. *) -(* * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. *) -(* * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. *) -(* * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. *) -(* - move {ih}. *) -(* move /algo_metric_sym in h. *) -(* qauto l:on use:coqeq_symmetric_mutual. *) -(* - move {hnfneu}. *) -(* (* Clear out some trivial cases *) *) -(* suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). *) -(* move => h0. *) -(* split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. *) -(* by firstorder. *) + have ihA : A0 ⇔ A1 by hauto l:on. + have hAE : Γ ⊢ A0 ≡ A1 ∈ PUniv (Nat.max i0 i1) + by hauto l:on use:coqeq_sound_mutual. + apply : CE_HRed; eauto using rtc_refl. + constructor => //. -(* case : a h fb fa => //=. *) -(* + case : b => //=; move => > /algo_metric_join. *) -(* * move /DJoin.var_inj => i _ _. subst. *) -(* move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. *) -(* move /Var_Inv => [_ [C0 [h2 h3]]]. *) -(* have ? : B0 = C0 by eauto using lookup_deter. subst. *) -(* sfirstorder use:T_Var. *) -(* * clear => ? ? _. exfalso. *) -(* hauto l:on use:REReds.var_inv, REReds.hne_app_inv. *) -(* * clear => ? ? _. exfalso. *) -(* hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. *) -(* * clear => ? ? _. exfalso. *) -(* hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. *) -(* + case : b => //=; *) -(* lazymatch goal with *) -(* | [|- context[algo_metric _ (PApp _ _) (PApp _ _)]] => idtac *) -(* | _ => move => > /algo_metric_join *) -(* end. *) -(* * clear => *. exfalso. *) -(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.var_inv. *) -(* (* real case *) *) -(* * move => b1 a1 b0 a0 halg hne1 hne0 Γ A B wtA wtB. *) -(* move /App_Inv : wtA => [A0][B0][hb0][ha0]hS0. *) -(* move /App_Inv : wtB => [A1][B1][hb1][ha1]hS1. *) -(* move : algo_metric_app (hne0) (hne1) halg. repeat move/[apply]. *) -(* move => [j [hj [hal0 hal1]]]. *) -(* have /ih := hal0. *) -(* move /(_ hj). *) -(* move => [_ ihb]. *) -(* move : ihb (hne0) (hne1) 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 : ih (hj) hal1. repeat move/[apply]. *) -(* move => [ih _]. *) -(* move : ih (ha0') (ha1'); repeat move/[apply]. *) -(* move => iha. *) -(* split. qblast. *) -(* 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. *) -(* * clear => ? ? ?. exfalso. *) -(* hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. *) -(* * clear => ? ? ?. exfalso. *) -(* hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. *) -(* + case : b => //=. *) -(* * move => i p h /algo_metric_join. clear => ? _ ?. exfalso. *) -(* hauto l:on use:REReds.hne_proj_inv, REReds.var_inv. *) -(* * move => > /algo_metric_join. clear => ? ? ?. exfalso. *) -(* hauto l:on use:REReds.hne_proj_inv, REReds.hne_app_inv. *) -(* (* real case *) *) -(* * move => p1 a1 p0 a0 /algo_metric_proj ha hne1 hne0. *) -(* move : ha (hne0) (hne1); repeat move/[apply]. *) -(* move => [? [j []]]. subst. *) -(* move : ih; repeat move/[apply]. *) -(* move => [_ ih]. *) -(* case : p1. *) -(* ** move => Γ A B 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 => Γ A B 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 => > /algo_metric_join; clear => ? ? ?. exfalso. *) -(* hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. *) -(* (* ind ind case *) *) -(* + move => P a0 b0 c0. *) -(* case : b => //=; *) -(* lazymatch goal with *) -(* | [|- context[algo_metric _ (PInd _ _ _ _) (PInd _ _ _ _)]] => idtac *) -(* | _ => move => > /algo_metric_join; clear => *; exfalso *) -(* end. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. *) -(* * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. *) -(* move /(_ h1 h0). *) -(* move => [j][hj][hP][ha][hb]hc Γ A B hL hR. *) -(* move /Ind_Inv : hL => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. *) -(* move /Ind_Inv : hR => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. *) -(* have {}iha : a0 ∼ a1 by qauto l:on. *) -(* have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. *) -(* move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. *) -(* move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. *) -(* have {}ihP : P ⇔ P1 by qauto l:on. *) -(* set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. *) -(* have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. *) -(* have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) *) -(* by hauto l:on use:coqeq_sound_mutual. *) -(* have haE : Γ ⊢ a0 ≡ a1 ∈ 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) P ≡ 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) P *) -(* by eauto using T_Conv_E. *) -(* have {}ihb : b0 ⇔ b1 by hauto l:on. *) -(* have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. *) -(* set T := ren_PTm shift _ in wtc0. *) -(* have : (cons P Δ) ⊢ 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. *) -(* have hEInd : Γ ⊢ PInd P a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P by hfcrush use:coqeq_sound_mutual. *) -(* exists (subst_PTm (scons a0 VarPTm) P). *) -(* 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. *) -(* Qed. *) + eapply ih; eauto. + apply : ctx_eq_subst_one; eauto. + eauto using Su_Eq. + * move => > /algo_metric_join. + hauto lq:on use:DJoin.bind_univ_noconf. + * move => > /algo_metric_join. + hauto lq:on use:Sub.nat_bind_noconf, Sub.FromJoin. + * move => > /algo_metric_join. + clear. hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. + * move => > /algo_metric_join. clear. + hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv. + + case : b => //=. + * hauto lq:on use:T_AbsUniv_Imp. + * hauto lq:on use:T_PairUniv_Imp. + * qauto l:on use:algo_metric_join, DJoin.bind_univ_noconf, DJoin.symmetric. + * move => i j /algo_metric_join /DJoin.univ_inj ? _ _ Γ A hi hj. + subst. + hauto l:on. + * move => > /algo_metric_join. + hauto lq:on use:Sub.nat_univ_noconf, Sub.FromJoin. + * move => > /algo_metric_join. + clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. + * move => > /algo_metric_join. + clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.suc_inv. + + case : b => //=. + * qauto l:on use:T_AbsNat_Imp. + * qauto l:on use:T_PairNat_Imp. + * move => > /algo_metric_join /Sub.FromJoin. hauto l:on use:Sub.bind_nat_noconf. + * move => > /algo_metric_join /Sub.FromJoin. hauto lq:on use:Sub.univ_nat_noconf. + * hauto l:on. + * move /algo_metric_join. + hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. + * move => > /algo_metric_join. + hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. + (* Zero *) + + case : b => //=. + * hauto lq:on rew:off use:T_AbsZero_Imp. + * hauto lq: on use: T_PairZero_Imp. + * move =>> /algo_metric_join. + hauto lq:on rew:off use:REReds.zero_inv, REReds.bind_inv. + * move =>> /algo_metric_join. + hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. + * move =>> /algo_metric_join. + hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. + * hauto l:on. + * move =>> /algo_metric_join. + hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. + (* Suc *) + + case : b => //=. + * hauto lq:on rew:off use:T_AbsSuc_Imp. + * hauto lq:on use:T_PairSuc_Imp. + * move => > /algo_metric_join. + hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. + * move => > /algo_metric_join. + hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. + * move => > /algo_metric_join. + hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. + * move => > /algo_metric_join. + hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. + * move => a0 a1 h _ _. + move /algo_metric_suc : h => [j [h4 h5]]. + move => Γ A /Suc_Inv [h0 h1] /Suc_Inv [h2 h3]. + move : ih h4 h5;do!move/[apply]. + move => [ih _]. + move : ih h0 h2;do!move/[apply]. + move => h. apply : CE_HRed; eauto using rtc_refl. + by constructor. + - move : a b h fb fa. abstract : hnfneu. + move => + b. + case : b => //=. + (* NeuAbs *) + + move => a u halg _ nea. split => // Γ A hu /[dup] ha. + move /Abs_Inv => [A0][B0][_]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. + move /Abs_Pi_Inv in ha. + move /algo_metric_neu_abs /(_ nea) : halg. + move => [j0][hj0]halg. + apply : CE_HRed; eauto using rtc_refl. + eapply CE_NeuAbs => //=. + eapply ih; eauto. + (* NeuPair *) + + move => a0 b0 u halg _ neu. + split => // Γ A hu /[dup] wt. + move /Pair_Inv => [A0][B0][ha0][hb0]hU. + 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. + move /algo_metric_neu_pair /(_ neu) : halg => [j [hj [hL hR]]]. + have heL : PProj PL u ⇔ a0 by hauto l:on. + eapply CE_HRed; eauto using rtc_refl. + apply CE_NeuPair; eauto. + eapply ih; eauto. + apply : T_Conv; eauto. + have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i + by hauto l:on use:regularity. + have /E_Symmetric : Γ ⊢ PProj PL u ≡ a0 ∈ A2 by + hauto l:on use:coqeq_sound_mutual. + hauto l:on use:bind_inst. + (* NeuBind: Impossible *) + + move => b p p0 a /algo_metric_join h _ h0. exfalso. + move : h h0. clear. + move /Sub.FromJoin. + hauto l:on use:Sub.hne_bind_noconf. + (* NeuUniv: Impossible *) + + hauto lq:on rew:off use:DJoin.hne_univ_noconf, algo_metric_join. + + hauto lq:on rew:off use:DJoin.hne_nat_noconf, algo_metric_join. + (* Zero *) + + case => //=. + * move => i /algo_metric_join. clear. + hauto lq:on rew:off use:REReds.var_inv, REReds.zero_inv. + * move => >/algo_metric_join. clear. + hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. + * move => >/algo_metric_join. clear. + hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. + * move => >/algo_metric_join. clear. + move => h _ h2. exfalso. + hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. + (* Suc *) + + move => a0. + case => //=; move => >/algo_metric_join; clear. + * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. + * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. + * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. + * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. + - move {ih}. + move /algo_metric_sym in h. + qauto l:on use:coqeq_symmetric_mutual. + - move {hnfneu}. + (* Clear out some trivial cases *) + suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). + move => h0. + split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. + by firstorder. -(* Lemma coqeq_sound : forall Γ (a b : PTm) A, *) -(* Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⇔ b -> Γ ⊢ a ≡ b ∈ A. *) -(* Proof. sfirstorder use:coqeq_sound_mutual. Qed. *) + case : a h fb fa => //=. + + case : b => //=; move => > /algo_metric_join. + * move /DJoin.var_inj => i _ _. subst. + move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. + move /Var_Inv => [_ [C0 [h2 h3]]]. + have ? : B0 = C0 by eauto using lookup_deter. subst. + sfirstorder use:T_Var. + * clear => ? ? _. exfalso. + hauto l:on use:REReds.var_inv, REReds.hne_app_inv. + * clear => ? ? _. exfalso. + hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. + * clear => ? ? _. exfalso. + hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. + + case : b => //=; + lazymatch goal with + | [|- context[algo_metric _ (PApp _ _) (PApp _ _)]] => idtac + | _ => move => > /algo_metric_join + end. + * clear => *. exfalso. + hauto lq:on rew:off use:REReds.hne_app_inv, REReds.var_inv. + (* real case *) + * move => b1 a1 b0 a0 halg hne1 hne0 Γ A B wtA wtB. + move /App_Inv : wtA => [A0][B0][hb0][ha0]hS0. + move /App_Inv : wtB => [A1][B1][hb1][ha1]hS1. + move : algo_metric_app (hne0) (hne1) halg. repeat move/[apply]. + move => [j [hj [hal0 hal1]]]. + have /ih := hal0. + move /(_ hj). + move => [_ ihb]. + move : ihb (hne0) (hne1) 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 : ih (hj) hal1. repeat move/[apply]. + move => [ih _]. + move : ih (ha0') (ha1'); repeat move/[apply]. + move => iha. + split. qblast. + 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. + * clear => ? ? ?. exfalso. + hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. + * clear => ? ? ?. exfalso. + hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. + + case : b => //=. + * move => i p h /algo_metric_join. clear => ? _ ?. exfalso. + hauto l:on use:REReds.hne_proj_inv, REReds.var_inv. + * move => > /algo_metric_join. clear => ? ? ?. exfalso. + hauto l:on use:REReds.hne_proj_inv, REReds.hne_app_inv. + (* real case *) + * move => p1 a1 p0 a0 /algo_metric_proj ha hne1 hne0. + move : ha (hne0) (hne1); repeat move/[apply]. + move => [? [j []]]. subst. + move : ih; repeat move/[apply]. + move => [_ ih]. + case : p1. + ** move => Γ A B 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 => Γ A B 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 => > /algo_metric_join; clear => ? ? ?. exfalso. + hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. + (* ind ind case *) + + move => P a0 b0 c0. + case : b => //=; + lazymatch goal with + | [|- context[algo_metric _ (PInd _ _ _ _) (PInd _ _ _ _)]] => idtac + | _ => move => > /algo_metric_join; clear => *; exfalso + end. + * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. + * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. + * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. + * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. + move /(_ h1 h0). + move => [j][hj][hP][ha][hb]hc Γ A B hL hR. + move /Ind_Inv : hL => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. + move /Ind_Inv : hR => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. + have {}iha : a0 ∼ a1 by qauto l:on. + have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. + move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. + move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. + have {}ihP : P ⇔ P1 by qauto l:on. + set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. + have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. + have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) + by hauto l:on use:coqeq_sound_mutual. + have haE : Γ ⊢ a0 ≡ a1 ∈ 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) P ≡ 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) P + by eauto using T_Conv_E. + have {}ihb : b0 ⇔ b1 by hauto l:on. + have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. + set T := ren_PTm shift _ in wtc0. + have : (cons P Δ) ⊢ 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. + have hEInd : Γ ⊢ PInd P a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P by hfcrush use:coqeq_sound_mutual. + exists (subst_PTm (scons a0 VarPTm) P). + 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. +Qed. -(* Lemma coqeq_complete Γ (a b A : PTm) : *) -(* Γ ⊢ a ≡ b ∈ A -> a ⇔ b. *) -(* Proof. *) -(* move => h. *) -(* suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. *) -(* eapply fundamental_theorem in h. *) -(* move /logrel.SemEq_SN_Join : h. *) -(* move => h. *) -(* have : exists va vb : PTm, *) -(* rtc LoRed.R a va /\ *) -(* rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb *) -(* by hauto l:on use:DJoin.standardization_lo. *) -(* move => [va][vb][hva][hvb][nva][nvb]hj. *) -(* move /relations.rtc_nsteps : hva => [i hva]. *) -(* move /relations.rtc_nsteps : hvb => [j hvb]. *) -(* exists (i + j + size_PTm va + size_PTm vb). *) -(* hauto lq:on solve+:lia. *) -(* 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 coqeq_complete Γ (a b A : PTm) : + Γ ⊢ a ≡ b ∈ A -> a ⇔ b. +Proof. + move => h. + suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. + eapply fundamental_theorem in h. + move /logrel.SemEq_SN_Join : h. + move => h. + have : exists va vb : PTm, + rtc LoRed.R a va /\ + rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb + by hauto l:on use:DJoin.standardization_lo. + move => [va][vb][hva][hvb][nva][nvb]hj. + move /relations.rtc_nsteps : hva => [i hva]. + move /relations.rtc_nsteps : hvb => [j hvb]. + exists (i + j + size_PTm va + size_PTm vb). + hauto lq:on solve+:lia. +Qed. Reserved Notation "a ≪ b" (at level 70). From d1771adc48b3ec0da063990e7db22834194f5fc3 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 22:44:42 -0400 Subject: [PATCH 35/51] Use hne and hf instead HRed.nf --- theories/algorithmic.v | 1122 +++++++++++++++++++-------------- theories/common.v | 10 +- theories/executable.v | 2 +- theories/executable_correct.v | 3 - 4 files changed, 655 insertions(+), 482 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index ace67ac..eb93263 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1302,6 +1302,17 @@ Proof. 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). @@ -1341,489 +1352,654 @@ Lemma coqeq_complete' : 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 => p0 p1 A0 A1 B0 B1. + - 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}. +Admitted. - algo_metric k 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). -Proof. - move : k a b. - elim /Wf_nat.lt_wf_ind. - move => n ih. - move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. - move => a b h. - (* Cases where a and b can take steps *) - case; cycle 1. - move : ih a b h. - abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. - move /algo_metric_sym /algo_metric_case : (h). - case; cycle 1. - move /algo_metric_sym : h. - move : hstepL ih => /[apply]/[apply]. - repeat move /[apply]. - move => hstepL. - hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. - (* Cases where a and b can't take wh steps *) - move {hstepL}. - move : a b h. move => [:hnfneu]. - move => a b h. - case => fb; case => fa. - - split; last by sfirstorder use:hf_not_hne. - move {hnfneu}. - case : a h fb fa => //=. - + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_AbsBind_Imp, T_AbsUniv_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_AbsNat_Imp. - move => a0 a1 ha0 _ _ Γ A wt0 wt1. - move : T_Abs_Inv wt0 wt1; repeat move/[apply]. move => [Δ [V [wt1 wt0]]]. - apply : CE_HRed; eauto using rtc_refl. - apply CE_AbsAbs. - suff [l [h0 h1]] : exists l, l < n /\ algo_metric l a1 a0 by eapply ih; eauto. - have ? : n > 0 by sauto solve+:lia. - exists (n - 1). split; first by lia. - move : (ha0). rewrite /algo_metric. - move => [i][j][va][vb][hr0][hr1][nfva][nfvb][[v [hr0' hr1']]] har. - apply lored_nsteps_abs_inv in hr0, hr1. - move : hr0 => [va' [hr00 hr01]]. - move : hr1 => [vb' [hr10 hr11]]. move {ih}. - exists i,j,va',vb'. subst. - suff [v0 [hv00 hv01]] : exists v0, rtc ERed.R va' v0 /\ rtc ERed.R vb' v0. - repeat split =>//=. sfirstorder. - simpl in *; by lia. - move /algo_metric_join /DJoin.symmetric : ha0. - have : SN a0 /\ SN a1 by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. - move => /[dup] [[ha00 ha10]] []. - move : DJoin.abs_inj; repeat move/[apply]. - move : DJoin.standardization ha00 ha10; repeat move/[apply]. - (* this is awful *) - move => [vb][va][h' [h'' [h''' [h'''' h'''''']]]]. - have /LoReds.ToRReds {}hr00 : rtc LoRed.R a1 va' - by hauto lq:on use:@relations.rtc_nsteps. - have /LoReds.ToRReds {}hr10 : rtc LoRed.R a0 vb' - by hauto lq:on use:@relations.rtc_nsteps. - simpl in *. - have [*] : va' = va /\ vb' = vb by eauto using red_uniquenf. subst. - sfirstorder. - + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_PairBind_Imp, T_PairUniv_Imp, T_PairNat_Imp, T_PairSuc_Imp, T_PairZero_Imp. - move => a1 b1 a0 b0 h _ _ Γ A hu0 hu1. - have [sn0 sn1] : SN (PPair a0 b0) /\ SN (PPair a1 b1) - by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. - apply : CE_HRed; eauto using rtc_refl. - move /Pair_Inv : hu0 => [A0][B0][ha0][hb0]hSu0. - move /Pair_Inv : hu1 => [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 /algo_metric_pair : h sn0 sn1; repeat move/[apply]. - move => [j][hj][ih0 ih1]. - have haE : a0 ⇔ a1 by hauto l:on. - 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 ih; 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. - + case : b => //=. - * hauto lq:on use:T_AbsBind_Imp. - * hauto lq:on rew:off use:T_PairBind_Imp. - * move => p1 A1 B1 p0 A0 B0. - move /algo_metric_bind. - move => [?][j [ih0 [ih1 ih2]]]_ _. subst. - move => Γ A hU0 hU1. - move /Bind_Inv : hU0 => [i0 [hA0 [hB0 hS0]]]. - move /Bind_Inv : hU1 => [i1 [hA1 [hB1 hS1]]]. - have ? : Γ ⊢ PUniv i0 ≲ PUniv (max i0 i1) - by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. - have ? : Γ ⊢ PUniv i1 ≲ PUniv (max i0 i1) - by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. - have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. - have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. - have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) - by hauto lq:on use:T_Univ_Raise solve+:lia. - have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) - by hauto lq:on use:T_Univ_Raise solve+:lia. - have ihA : A0 ⇔ A1 by hauto l:on. - have hAE : Γ ⊢ A0 ≡ A1 ∈ PUniv (Nat.max i0 i1) - by hauto l:on use:coqeq_sound_mutual. - apply : CE_HRed; eauto using rtc_refl. - constructor => //. +(* algo_metric k 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). *) +(* Proof. *) +(* move : k a b. *) +(* elim /Wf_nat.lt_wf_ind. *) +(* move => n ih. *) +(* move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. *) +(* move => a b h. *) +(* (* Cases where a and b can take steps *) *) +(* case; cycle 1. *) +(* move : ih a b h. *) +(* abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. *) +(* move /algo_metric_sym /algo_metric_case : (h). *) +(* case; cycle 1. *) +(* move /algo_metric_sym : h. *) +(* move : hstepL ih => /[apply]/[apply]. *) +(* repeat move /[apply]. *) +(* move => hstepL. *) +(* hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. *) +(* (* Cases where a and b can't take wh steps *) *) +(* move {hstepL}. *) +(* move : a b h. move => [:hnfneu]. *) +(* move => a b h. *) +(* case => fb; case => fa. *) +(* - split; last by sfirstorder use:hf_not_hne. *) +(* move {hnfneu}. *) +(* case : a h fb fa => //=. *) +(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_AbsBind_Imp, T_AbsUniv_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_AbsNat_Imp. *) +(* move => a0 a1 ha0 _ _ Γ A wt0 wt1. *) +(* move : T_Abs_Inv wt0 wt1; repeat move/[apply]. move => [Δ [V [wt1 wt0]]]. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* apply CE_AbsAbs. *) +(* suff [l [h0 h1]] : exists l, l < n /\ algo_metric l a1 a0 by eapply ih; eauto. *) +(* have ? : n > 0 by sauto solve+:lia. *) +(* exists (n - 1). split; first by lia. *) +(* move : (ha0). rewrite /algo_metric. *) +(* move => [i][j][va][vb][hr0][hr1][nfva][nfvb][[v [hr0' hr1']]] har. *) +(* apply lored_nsteps_abs_inv in hr0, hr1. *) +(* move : hr0 => [va' [hr00 hr01]]. *) +(* move : hr1 => [vb' [hr10 hr11]]. move {ih}. *) +(* exists i,j,va',vb'. subst. *) +(* suff [v0 [hv00 hv01]] : exists v0, rtc ERed.R va' v0 /\ rtc ERed.R vb' v0. *) +(* repeat split =>//=. sfirstorder. *) +(* simpl in *; by lia. *) +(* move /algo_metric_join /DJoin.symmetric : ha0. *) +(* have : SN a0 /\ SN a1 by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) +(* move => /[dup] [[ha00 ha10]] []. *) +(* move : DJoin.abs_inj; repeat move/[apply]. *) +(* move : DJoin.standardization ha00 ha10; repeat move/[apply]. *) +(* (* this is awful *) *) +(* move => [vb][va][h' [h'' [h''' [h'''' h'''''']]]]. *) +(* have /LoReds.ToRReds {}hr00 : rtc LoRed.R a1 va' *) +(* by hauto lq:on use:@relations.rtc_nsteps. *) +(* have /LoReds.ToRReds {}hr10 : rtc LoRed.R a0 vb' *) +(* by hauto lq:on use:@relations.rtc_nsteps. *) +(* simpl in *. *) +(* have [*] : va' = va /\ vb' = vb by eauto using red_uniquenf. subst. *) +(* sfirstorder. *) +(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_PairBind_Imp, T_PairUniv_Imp, T_PairNat_Imp, T_PairSuc_Imp, T_PairZero_Imp. *) +(* move => a1 b1 a0 b0 h _ _ Γ A hu0 hu1. *) +(* have [sn0 sn1] : SN (PPair a0 b0) /\ SN (PPair a1 b1) *) +(* by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* move /Pair_Inv : hu0 => [A0][B0][ha0][hb0]hSu0. *) +(* move /Pair_Inv : hu1 => [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 /algo_metric_pair : h sn0 sn1; repeat move/[apply]. *) +(* move => [j][hj][ih0 ih1]. *) +(* have haE : a0 ⇔ a1 by hauto l:on. *) +(* 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 ih; 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. *) +(* + case : b => //=. *) +(* * hauto lq:on use:T_AbsBind_Imp. *) +(* * hauto lq:on rew:off use:T_PairBind_Imp. *) +(* * move => p1 A1 B1 p0 A0 B0. *) +(* move /algo_metric_bind. *) +(* move => [?][j [ih0 [ih1 ih2]]]_ _. subst. *) +(* move => Γ A hU0 hU1. *) +(* move /Bind_Inv : hU0 => [i0 [hA0 [hB0 hS0]]]. *) +(* move /Bind_Inv : hU1 => [i1 [hA1 [hB1 hS1]]]. *) +(* have ? : Γ ⊢ PUniv i0 ≲ PUniv (max i0 i1) *) +(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) +(* have ? : Γ ⊢ PUniv i1 ≲ PUniv (max i0 i1) *) +(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) +(* have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) +(* have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) +(* have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) *) +(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) +(* have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) *) +(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) - eapply ih; eauto. - apply : ctx_eq_subst_one; eauto. - eauto using Su_Eq. - * move => > /algo_metric_join. - hauto lq:on use:DJoin.bind_univ_noconf. - * move => > /algo_metric_join. - hauto lq:on use:Sub.nat_bind_noconf, Sub.FromJoin. - * move => > /algo_metric_join. - clear. hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. - * move => > /algo_metric_join. clear. - hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv. - + case : b => //=. - * hauto lq:on use:T_AbsUniv_Imp. - * hauto lq:on use:T_PairUniv_Imp. - * qauto l:on use:algo_metric_join, DJoin.bind_univ_noconf, DJoin.symmetric. - * move => i j /algo_metric_join /DJoin.univ_inj ? _ _ Γ A hi hj. - subst. - hauto l:on. - * move => > /algo_metric_join. - hauto lq:on use:Sub.nat_univ_noconf, Sub.FromJoin. - * move => > /algo_metric_join. - clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. - * move => > /algo_metric_join. - clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.suc_inv. - + case : b => //=. - * qauto l:on use:T_AbsNat_Imp. - * qauto l:on use:T_PairNat_Imp. - * move => > /algo_metric_join /Sub.FromJoin. hauto l:on use:Sub.bind_nat_noconf. - * move => > /algo_metric_join /Sub.FromJoin. hauto lq:on use:Sub.univ_nat_noconf. - * hauto l:on. - * move /algo_metric_join. - hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. - (* Zero *) - + case : b => //=. - * hauto lq:on rew:off use:T_AbsZero_Imp. - * hauto lq: on use: T_PairZero_Imp. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.bind_inv. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. - * hauto l:on. - * move =>> /algo_metric_join. - hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. - (* Suc *) - + case : b => //=. - * hauto lq:on rew:off use:T_AbsSuc_Imp. - * hauto lq:on use:T_PairSuc_Imp. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. - * move => > /algo_metric_join. - hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. - * move => a0 a1 h _ _. - move /algo_metric_suc : h => [j [h4 h5]]. - move => Γ A /Suc_Inv [h0 h1] /Suc_Inv [h2 h3]. - move : ih h4 h5;do!move/[apply]. - move => [ih _]. - move : ih h0 h2;do!move/[apply]. - move => h. apply : CE_HRed; eauto using rtc_refl. - by constructor. - - move : a b h fb fa. abstract : hnfneu. - move => + b. - case : b => //=. - (* NeuAbs *) - + move => a u halg _ nea. split => // Γ A hu /[dup] ha. - move /Abs_Inv => [A0][B0][_]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. - move /Abs_Pi_Inv in ha. - move /algo_metric_neu_abs /(_ nea) : halg. - move => [j0][hj0]halg. - apply : CE_HRed; eauto using rtc_refl. - eapply CE_NeuAbs => //=. - eapply ih; eauto. - (* NeuPair *) - + move => a0 b0 u halg _ neu. - split => // Γ A hu /[dup] wt. - move /Pair_Inv => [A0][B0][ha0][hb0]hU. - 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. - move /algo_metric_neu_pair /(_ neu) : halg => [j [hj [hL hR]]]. - have heL : PProj PL u ⇔ a0 by hauto l:on. - eapply CE_HRed; eauto using rtc_refl. - apply CE_NeuPair; eauto. - eapply ih; eauto. - apply : T_Conv; eauto. - have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i - by hauto l:on use:regularity. - have /E_Symmetric : Γ ⊢ PProj PL u ≡ a0 ∈ A2 by - hauto l:on use:coqeq_sound_mutual. - hauto l:on use:bind_inst. - (* NeuBind: Impossible *) - + move => b p p0 a /algo_metric_join h _ h0. exfalso. - move : h h0. clear. - move /Sub.FromJoin. - hauto l:on use:Sub.hne_bind_noconf. - (* NeuUniv: Impossible *) - + hauto lq:on rew:off use:DJoin.hne_univ_noconf, algo_metric_join. - + hauto lq:on rew:off use:DJoin.hne_nat_noconf, algo_metric_join. - (* Zero *) - + case => //=. - * move => i /algo_metric_join. clear. - hauto lq:on rew:off use:REReds.var_inv, REReds.zero_inv. - * move => >/algo_metric_join. clear. - hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. - * move => >/algo_metric_join. clear. - hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. - * move => >/algo_metric_join. clear. - move => h _ h2. exfalso. - hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. - (* Suc *) - + move => a0. - case => //=; move => >/algo_metric_join; clear. - * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. - * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. - * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. - * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. - - move {ih}. - move /algo_metric_sym in h. - qauto l:on use:coqeq_symmetric_mutual. - - move {hnfneu}. - (* Clear out some trivial cases *) - suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). - move => h0. - split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. - by firstorder. +(* have ihA : A0 ⇔ A1 by hauto l:on. *) +(* have hAE : Γ ⊢ A0 ≡ A1 ∈ PUniv (Nat.max i0 i1) *) +(* by hauto l:on use:coqeq_sound_mutual. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* constructor => //. *) - case : a h fb fa => //=. - + case : b => //=; move => > /algo_metric_join. - * move /DJoin.var_inj => i _ _. subst. - move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. - move /Var_Inv => [_ [C0 [h2 h3]]]. - have ? : B0 = C0 by eauto using lookup_deter. subst. - sfirstorder use:T_Var. - * clear => ? ? _. exfalso. - hauto l:on use:REReds.var_inv, REReds.hne_app_inv. - * clear => ? ? _. exfalso. - hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. - * clear => ? ? _. exfalso. - hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. - + case : b => //=; - lazymatch goal with - | [|- context[algo_metric _ (PApp _ _) (PApp _ _)]] => idtac - | _ => move => > /algo_metric_join - end. - * clear => *. exfalso. - hauto lq:on rew:off use:REReds.hne_app_inv, REReds.var_inv. - (* real case *) - * move => b1 a1 b0 a0 halg hne1 hne0 Γ A B wtA wtB. - move /App_Inv : wtA => [A0][B0][hb0][ha0]hS0. - move /App_Inv : wtB => [A1][B1][hb1][ha1]hS1. - move : algo_metric_app (hne0) (hne1) halg. repeat move/[apply]. - move => [j [hj [hal0 hal1]]]. - have /ih := hal0. - move /(_ hj). - move => [_ ihb]. - move : ihb (hne0) (hne1) 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 : ih (hj) hal1. repeat move/[apply]. - move => [ih _]. - move : ih (ha0') (ha1'); repeat move/[apply]. - move => iha. - split. qblast. - 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. - * clear => ? ? ?. exfalso. - hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. - * clear => ? ? ?. exfalso. - hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. - + case : b => //=. - * move => i p h /algo_metric_join. clear => ? _ ?. exfalso. - hauto l:on use:REReds.hne_proj_inv, REReds.var_inv. - * move => > /algo_metric_join. clear => ? ? ?. exfalso. - hauto l:on use:REReds.hne_proj_inv, REReds.hne_app_inv. - (* real case *) - * move => p1 a1 p0 a0 /algo_metric_proj ha hne1 hne0. - move : ha (hne0) (hne1); repeat move/[apply]. - move => [? [j []]]. subst. - move : ih; repeat move/[apply]. - move => [_ ih]. - case : p1. - ** move => Γ A B 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 => Γ A B 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 => > /algo_metric_join; clear => ? ? ?. exfalso. - hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. - (* ind ind case *) - + move => P a0 b0 c0. - case : b => //=; - lazymatch goal with - | [|- context[algo_metric _ (PInd _ _ _ _) (PInd _ _ _ _)]] => idtac - | _ => move => > /algo_metric_join; clear => *; exfalso - end. - * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. - * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. - * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. - * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. - move /(_ h1 h0). - move => [j][hj][hP][ha][hb]hc Γ A B hL hR. - move /Ind_Inv : hL => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. - move /Ind_Inv : hR => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. - have {}iha : a0 ∼ a1 by qauto l:on. - have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. - move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. - move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. - have {}ihP : P ⇔ P1 by qauto l:on. - set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. - have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. - have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) - by hauto l:on use:coqeq_sound_mutual. - have haE : Γ ⊢ a0 ≡ a1 ∈ 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) P ≡ 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) P - by eauto using T_Conv_E. - have {}ihb : b0 ⇔ b1 by hauto l:on. - have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. - set T := ren_PTm shift _ in wtc0. - have : (cons P Δ) ⊢ 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. - have hEInd : Γ ⊢ PInd P a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P by hfcrush use:coqeq_sound_mutual. - exists (subst_PTm (scons a0 VarPTm) P). - 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. -Qed. +(* eapply ih; eauto. *) +(* apply : ctx_eq_subst_one; eauto. *) +(* eauto using Su_Eq. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on use:DJoin.bind_univ_noconf. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on use:Sub.nat_bind_noconf, Sub.FromJoin. *) +(* * move => > /algo_metric_join. *) +(* clear. hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. *) +(* * move => > /algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv. *) +(* + case : b => //=. *) +(* * hauto lq:on use:T_AbsUniv_Imp. *) +(* * hauto lq:on use:T_PairUniv_Imp. *) +(* * qauto l:on use:algo_metric_join, DJoin.bind_univ_noconf, DJoin.symmetric. *) +(* * move => i j /algo_metric_join /DJoin.univ_inj ? _ _ Γ A hi hj. *) +(* subst. *) +(* hauto l:on. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on use:Sub.nat_univ_noconf, Sub.FromJoin. *) +(* * move => > /algo_metric_join. *) +(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. *) +(* * move => > /algo_metric_join. *) +(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.suc_inv. *) +(* + case : b => //=. *) +(* * qauto l:on use:T_AbsNat_Imp. *) +(* * qauto l:on use:T_PairNat_Imp. *) +(* * move => > /algo_metric_join /Sub.FromJoin. hauto l:on use:Sub.bind_nat_noconf. *) +(* * move => > /algo_metric_join /Sub.FromJoin. hauto lq:on use:Sub.univ_nat_noconf. *) +(* * hauto l:on. *) +(* * move /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. *) +(* (* Zero *) *) +(* + case : b => //=. *) +(* * hauto lq:on rew:off use:T_AbsZero_Imp. *) +(* * hauto lq: on use: T_PairZero_Imp. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.bind_inv. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. *) +(* * hauto l:on. *) +(* * move =>> /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. *) +(* (* Suc *) *) +(* + case : b => //=. *) +(* * hauto lq:on rew:off use:T_AbsSuc_Imp. *) +(* * hauto lq:on use:T_PairSuc_Imp. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. *) +(* * move => > /algo_metric_join. *) +(* hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. *) +(* * move => a0 a1 h _ _. *) +(* move /algo_metric_suc : h => [j [h4 h5]]. *) +(* move => Γ A /Suc_Inv [h0 h1] /Suc_Inv [h2 h3]. *) +(* move : ih h4 h5;do!move/[apply]. *) +(* move => [ih _]. *) +(* move : ih h0 h2;do!move/[apply]. *) +(* move => h. apply : CE_HRed; eauto using rtc_refl. *) +(* by constructor. *) +(* - move : a b h fb fa. abstract : hnfneu. *) +(* move => + b. *) +(* case : b => //=. *) +(* (* NeuAbs *) *) +(* + move => a u halg _ nea. split => // Γ A hu /[dup] ha. *) +(* move /Abs_Inv => [A0][B0][_]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. *) +(* move /Abs_Pi_Inv in ha. *) +(* move /algo_metric_neu_abs /(_ nea) : halg. *) +(* move => [j0][hj0]halg. *) +(* apply : CE_HRed; eauto using rtc_refl. *) +(* eapply CE_NeuAbs => //=. *) +(* eapply ih; eauto. *) +(* (* NeuPair *) *) +(* + move => a0 b0 u halg _ neu. *) +(* split => // Γ A hu /[dup] wt. *) +(* move /Pair_Inv => [A0][B0][ha0][hb0]hU. *) +(* 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. *) +(* move /algo_metric_neu_pair /(_ neu) : halg => [j [hj [hL hR]]]. *) +(* have heL : PProj PL u ⇔ a0 by hauto l:on. *) +(* eapply CE_HRed; eauto using rtc_refl. *) +(* apply CE_NeuPair; eauto. *) +(* eapply ih; eauto. *) +(* apply : T_Conv; eauto. *) +(* have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i *) +(* by hauto l:on use:regularity. *) +(* have /E_Symmetric : Γ ⊢ PProj PL u ≡ a0 ∈ A2 by *) +(* hauto l:on use:coqeq_sound_mutual. *) +(* hauto l:on use:bind_inst. *) +(* (* NeuBind: Impossible *) *) +(* + move => b p p0 a /algo_metric_join h _ h0. exfalso. *) +(* move : h h0. clear. *) +(* move /Sub.FromJoin. *) +(* hauto l:on use:Sub.hne_bind_noconf. *) +(* (* NeuUniv: Impossible *) *) +(* + hauto lq:on rew:off use:DJoin.hne_univ_noconf, algo_metric_join. *) +(* + hauto lq:on rew:off use:DJoin.hne_nat_noconf, algo_metric_join. *) +(* (* Zero *) *) +(* + case => //=. *) +(* * move => i /algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.var_inv, REReds.zero_inv. *) +(* * move => >/algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. *) +(* * move => >/algo_metric_join. clear. *) +(* hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. *) +(* * move => >/algo_metric_join. clear. *) +(* move => h _ h2. exfalso. *) +(* hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. *) +(* (* Suc *) *) +(* + move => a0. *) +(* case => //=; move => >/algo_metric_join; clear. *) +(* * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. *) +(* * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. *) +(* * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. *) +(* - move {ih}. *) +(* move /algo_metric_sym in h. *) +(* qauto l:on use:coqeq_symmetric_mutual. *) +(* - move {hnfneu}. *) +(* (* Clear out some trivial cases *) *) +(* suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). *) +(* move => h0. *) +(* split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. *) +(* by firstorder. *) + +(* case : a h fb fa => //=. *) +(* + case : b => //=; move => > /algo_metric_join. *) +(* * move /DJoin.var_inj => i _ _. subst. *) +(* move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. *) +(* move /Var_Inv => [_ [C0 [h2 h3]]]. *) +(* have ? : B0 = C0 by eauto using lookup_deter. subst. *) +(* sfirstorder use:T_Var. *) +(* * clear => ? ? _. exfalso. *) +(* hauto l:on use:REReds.var_inv, REReds.hne_app_inv. *) +(* * clear => ? ? _. exfalso. *) +(* hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. *) +(* * clear => ? ? _. exfalso. *) +(* hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. *) +(* + case : b => //=; *) +(* lazymatch goal with *) +(* | [|- context[algo_metric _ (PApp _ _) (PApp _ _)]] => idtac *) +(* | _ => move => > /algo_metric_join *) +(* end. *) +(* * clear => *. exfalso. *) +(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.var_inv. *) +(* (* real case *) *) +(* * move => b1 a1 b0 a0 halg hne1 hne0 Γ A B wtA wtB. *) +(* move /App_Inv : wtA => [A0][B0][hb0][ha0]hS0. *) +(* move /App_Inv : wtB => [A1][B1][hb1][ha1]hS1. *) +(* move : algo_metric_app (hne0) (hne1) halg. repeat move/[apply]. *) +(* move => [j [hj [hal0 hal1]]]. *) +(* have /ih := hal0. *) +(* move /(_ hj). *) +(* move => [_ ihb]. *) +(* move : ihb (hne0) (hne1) 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 : ih (hj) hal1. repeat move/[apply]. *) +(* move => [ih _]. *) +(* move : ih (ha0') (ha1'); repeat move/[apply]. *) +(* move => iha. *) +(* split. qblast. *) +(* 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. *) +(* * clear => ? ? ?. exfalso. *) +(* hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. *) +(* * clear => ? ? ?. exfalso. *) +(* hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. *) +(* + case : b => //=. *) +(* * move => i p h /algo_metric_join. clear => ? _ ?. exfalso. *) +(* hauto l:on use:REReds.hne_proj_inv, REReds.var_inv. *) +(* * move => > /algo_metric_join. clear => ? ? ?. exfalso. *) +(* hauto l:on use:REReds.hne_proj_inv, REReds.hne_app_inv. *) +(* (* real case *) *) +(* * move => p1 a1 p0 a0 /algo_metric_proj ha hne1 hne0. *) +(* move : ha (hne0) (hne1); repeat move/[apply]. *) +(* move => [? [j []]]. subst. *) +(* move : ih; repeat move/[apply]. *) +(* move => [_ ih]. *) +(* case : p1. *) +(* ** move => Γ A B 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 => Γ A B 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 => > /algo_metric_join; clear => ? ? ?. exfalso. *) +(* hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. *) +(* (* ind ind case *) *) +(* + move => P a0 b0 c0. *) +(* case : b => //=; *) +(* lazymatch goal with *) +(* | [|- context[algo_metric _ (PInd _ _ _ _) (PInd _ _ _ _)]] => idtac *) +(* | _ => move => > /algo_metric_join; clear => *; exfalso *) +(* end. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. *) +(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. *) +(* * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. *) +(* move /(_ h1 h0). *) +(* move => [j][hj][hP][ha][hb]hc Γ A B hL hR. *) +(* move /Ind_Inv : hL => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. *) +(* move /Ind_Inv : hR => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. *) +(* have {}iha : a0 ∼ a1 by qauto l:on. *) +(* have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. *) +(* move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. *) +(* move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. *) +(* have {}ihP : P ⇔ P1 by qauto l:on. *) +(* set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. *) +(* have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. *) +(* have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) *) +(* by hauto l:on use:coqeq_sound_mutual. *) +(* have haE : Γ ⊢ a0 ≡ a1 ∈ 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) P ≡ 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) P *) +(* by eauto using T_Conv_E. *) +(* have {}ihb : b0 ⇔ b1 by hauto l:on. *) +(* have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. *) +(* set T := ren_PTm shift _ in wtc0. *) +(* have : (cons P Δ) ⊢ 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. *) +(* have hEInd : Γ ⊢ PInd P a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P by hfcrush use:coqeq_sound_mutual. *) +(* exists (subst_PTm (scons a0 VarPTm) P). *) +(* 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. *) +(* 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 coqeq_complete Γ (a b A : PTm) : - Γ ⊢ a ≡ b ∈ A -> a ⇔ b. -Proof. - move => h. - suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. - eapply fundamental_theorem in h. - move /logrel.SemEq_SN_Join : h. - move => h. - have : exists va vb : PTm, - rtc LoRed.R a va /\ - rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb - by hauto l:on use:DJoin.standardization_lo. - move => [va][vb][hva][hvb][nva][nvb]hj. - move /relations.rtc_nsteps : hva => [i hva]. - move /relations.rtc_nsteps : hvb => [j hvb]. - exists (i + j + size_PTm va + size_PTm vb). - hauto lq:on solve+:lia. -Qed. +(* Lemma coqeq_complete Γ (a b A : PTm) : *) +(* Γ ⊢ a ≡ b ∈ A -> a ⇔ b. *) +(* Proof. *) +(* move => h. *) +(* suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. *) +(* eapply fundamental_theorem in h. *) +(* move /logrel.SemEq_SN_Join : h. *) +(* move => h. *) +(* have : exists va vb : PTm, *) +(* rtc LoRed.R a va /\ *) +(* rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb *) +(* by hauto l:on use:DJoin.standardization_lo. *) +(* move => [va][vb][hva][hvb][nva][nvb]hj. *) +(* move /relations.rtc_nsteps : hva => [i hva]. *) +(* move /relations.rtc_nsteps : hvb => [j hvb]. *) +(* exists (i + j + size_PTm va + size_PTm vb). *) +(* hauto lq:on solve+:lia. *) +(* Qed. *) Reserved Notation "a ≪ b" (at level 70). diff --git a/theories/common.v b/theories/common.v index 18f4dfb..39713ba 100644 --- a/theories/common.v +++ b/theories/common.v @@ -284,8 +284,8 @@ Inductive algo_dom : PTm -> PTm -> Prop := algo_dom (PInd P0 u0 b0 c0) (PInd P1 u1 b1 c1) | A_Conf a b : - HRed.nf a -> - HRed.nf b -> + ishf a \/ ishne a -> + ishf b \/ ishne b -> tm_conf a b -> algo_dom a b @@ -376,8 +376,8 @@ Inductive salgo_dom : PTm -> PTm -> Prop := salgo_dom a b | S_Conf a b : - HRed.nf a -> - HRed.nf b -> + ishf a \/ ishne a -> + ishf b \/ ishne b -> stm_conf a b -> salgo_dom a b @@ -417,7 +417,7 @@ Proof. elim : a b => //=; hauto l:on inv:HRed.R. Qed. Ltac2 destruct_salgo () := lazy_match! goal with - | [h : is_true (ishne ?a) |- is_true (stm_conf ?a _) ] => + | [_ : 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) diff --git a/theories/executable.v b/theories/executable.v index 238fe45..e62e3c3 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -226,7 +226,7 @@ Ltac check_sub_triv := intros;subst; lazymatch goal with (* | [h : algo_dom (VarPTm _) (PAbs _) |- _] => idtac *) - | [h : salgo_dom _ _ |- _] => try (inversion h; subst => //=; ltac2:(Control.enter destruct_algo)) + | [_ : salgo_dom _ _ |- _] => try (inversion h; subst => //=; ltac2:(Control.enter destruct_algo)) | _ => idtac end. diff --git a/theories/executable_correct.v b/theories/executable_correct.v index d51af9d..4b76638 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -246,9 +246,6 @@ Proof. move => /negP h0. eapply check_equal_complete in h0. apply h0. by constructor. - - move => a b i0 i1 j. simp ce_prop. - move => _ h. inversion h; subst => //=. - hauto lq:on inv:CoqEq_Neu unfold:stm_conf. - 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. From 9d68e5d6c93b17a033abea7ea0439af364c15301 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 23:22:09 -0400 Subject: [PATCH 36/51] Finish the conf case --- theories/algorithmic.v | 63 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 62 insertions(+), 1 deletion(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index eb93263..c8a4799 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -448,6 +448,14 @@ 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. @@ -1316,7 +1324,7 @@ 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 => [:hhPairNeu hhAbsNeu]. + move => [:hConfNeuNf hhPairNeu hhAbsNeu]. apply algo_dom_mutual. - move => a b h ih hj. split => //. move => Γ A. move : T_Abs_Inv; repeat move/[apply]. @@ -1516,6 +1524,59 @@ Lemma coqeq_complete' : 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. Admitted. From 181e06ae01fed64158a786da5caac24a16108f78 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Mon, 10 Mar 2025 23:45:19 -0400 Subject: [PATCH 37/51] Finish the completeness proof for equality --- theories/algorithmic.v | 570 +++++++---------------------------------- 1 file changed, 87 insertions(+), 483 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index c8a4799..a870f9f 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1345,10 +1345,74 @@ Lemma coqeq_complete' : 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}. - admit. - - move {hhAbsNeu}. abstract : hhPairNeu. - admit. + - 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. @@ -1577,490 +1641,30 @@ Lemma coqeq_complete' : apply : DJoin.transitive; eauto. hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. apply DJoin.FromRRed0. by apply HRed.ToRRed. -Admitted. - - - -(* algo_metric k 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). *) -(* Proof. *) -(* move : k a b. *) -(* elim /Wf_nat.lt_wf_ind. *) -(* move => n ih. *) -(* move => a b /[dup] h /algo_metric_case. move : a b h => [:hstepL]. *) -(* move => a b h. *) -(* (* Cases where a and b can take steps *) *) -(* case; cycle 1. *) -(* move : ih a b h. *) -(* abstract : hstepL. qauto l:on use:HRed.preservation, CE_HRedL, hred_hne. *) -(* move /algo_metric_sym /algo_metric_case : (h). *) -(* case; cycle 1. *) -(* move /algo_metric_sym : h. *) -(* move : hstepL ih => /[apply]/[apply]. *) -(* repeat move /[apply]. *) -(* move => hstepL. *) -(* hauto lq:on use:coqeq_symmetric_mutual, algo_metric_sym. *) -(* (* Cases where a and b can't take wh steps *) *) -(* move {hstepL}. *) -(* move : a b h. move => [:hnfneu]. *) -(* move => a b h. *) -(* case => fb; case => fa. *) -(* - split; last by sfirstorder use:hf_not_hne. *) -(* move {hnfneu}. *) -(* case : a h fb fa => //=. *) -(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_AbsBind_Imp, T_AbsUniv_Imp, T_AbsZero_Imp, T_AbsSuc_Imp, T_AbsNat_Imp. *) -(* move => a0 a1 ha0 _ _ Γ A wt0 wt1. *) -(* move : T_Abs_Inv wt0 wt1; repeat move/[apply]. move => [Δ [V [wt1 wt0]]]. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* apply CE_AbsAbs. *) -(* suff [l [h0 h1]] : exists l, l < n /\ algo_metric l a1 a0 by eapply ih; eauto. *) -(* have ? : n > 0 by sauto solve+:lia. *) -(* exists (n - 1). split; first by lia. *) -(* move : (ha0). rewrite /algo_metric. *) -(* move => [i][j][va][vb][hr0][hr1][nfva][nfvb][[v [hr0' hr1']]] har. *) -(* apply lored_nsteps_abs_inv in hr0, hr1. *) -(* move : hr0 => [va' [hr00 hr01]]. *) -(* move : hr1 => [vb' [hr10 hr11]]. move {ih}. *) -(* exists i,j,va',vb'. subst. *) -(* suff [v0 [hv00 hv01]] : exists v0, rtc ERed.R va' v0 /\ rtc ERed.R vb' v0. *) -(* repeat split =>//=. sfirstorder. *) -(* simpl in *; by lia. *) -(* move /algo_metric_join /DJoin.symmetric : ha0. *) -(* have : SN a0 /\ SN a1 by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) -(* move => /[dup] [[ha00 ha10]] []. *) -(* move : DJoin.abs_inj; repeat move/[apply]. *) -(* move : DJoin.standardization ha00 ha10; repeat move/[apply]. *) -(* (* this is awful *) *) -(* move => [vb][va][h' [h'' [h''' [h'''' h'''''']]]]. *) -(* have /LoReds.ToRReds {}hr00 : rtc LoRed.R a1 va' *) -(* by hauto lq:on use:@relations.rtc_nsteps. *) -(* have /LoReds.ToRReds {}hr10 : rtc LoRed.R a0 vb' *) -(* by hauto lq:on use:@relations.rtc_nsteps. *) -(* simpl in *. *) -(* have [*] : va' = va /\ vb' = vb by eauto using red_uniquenf. subst. *) -(* sfirstorder. *) -(* + case : b => //=; try qauto depth:1 use:T_AbsPair_Imp, T_PairBind_Imp, T_PairUniv_Imp, T_PairNat_Imp, T_PairSuc_Imp, T_PairZero_Imp. *) -(* move => a1 b1 a0 b0 h _ _ Γ A hu0 hu1. *) -(* have [sn0 sn1] : SN (PPair a0 b0) /\ SN (PPair a1 b1) *) -(* by qauto l:on use:fundamental_theorem, logrel.SemWt_SN. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* move /Pair_Inv : hu0 => [A0][B0][ha0][hb0]hSu0. *) -(* move /Pair_Inv : hu1 => [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 /algo_metric_pair : h sn0 sn1; repeat move/[apply]. *) -(* move => [j][hj][ih0 ih1]. *) -(* have haE : a0 ⇔ a1 by hauto l:on. *) -(* 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 ih; 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. *) -(* + case : b => //=. *) -(* * hauto lq:on use:T_AbsBind_Imp. *) -(* * hauto lq:on rew:off use:T_PairBind_Imp. *) -(* * move => p1 A1 B1 p0 A0 B0. *) -(* move /algo_metric_bind. *) -(* move => [?][j [ih0 [ih1 ih2]]]_ _. subst. *) -(* move => Γ A hU0 hU1. *) -(* move /Bind_Inv : hU0 => [i0 [hA0 [hB0 hS0]]]. *) -(* move /Bind_Inv : hU1 => [i1 [hA1 [hB1 hS1]]]. *) -(* have ? : Γ ⊢ PUniv i0 ≲ PUniv (max i0 i1) *) -(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) -(* have ? : Γ ⊢ PUniv i1 ≲ PUniv (max i0 i1) *) -(* by hauto lq:on rew:off use:Su_Univ, wff_mutual solve+:lia. *) -(* have {}hA0 : Γ ⊢ A0 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) -(* have {}hA1 : Γ ⊢ A1 ∈ PUniv (max i0 i1) by eauto using T_Conv. *) -(* have {}hB0 : (cons A0 Γ) ⊢ B0 ∈ PUniv (max i0 i1) *) -(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) -(* have {}hB1 : (cons A1 Γ) ⊢ B1 ∈ PUniv (max i0 i1) *) -(* by hauto lq:on use:T_Univ_Raise solve+:lia. *) - -(* have ihA : A0 ⇔ A1 by hauto l:on. *) -(* have hAE : Γ ⊢ A0 ≡ A1 ∈ PUniv (Nat.max i0 i1) *) -(* by hauto l:on use:coqeq_sound_mutual. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* constructor => //. *) - -(* eapply ih; eauto. *) -(* apply : ctx_eq_subst_one; eauto. *) -(* eauto using Su_Eq. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on use:DJoin.bind_univ_noconf. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on use:Sub.nat_bind_noconf, Sub.FromJoin. *) -(* * move => > /algo_metric_join. *) -(* clear. hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv. *) -(* * move => > /algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv. *) -(* + case : b => //=. *) -(* * hauto lq:on use:T_AbsUniv_Imp. *) -(* * hauto lq:on use:T_PairUniv_Imp. *) -(* * qauto l:on use:algo_metric_join, DJoin.bind_univ_noconf, DJoin.symmetric. *) -(* * move => i j /algo_metric_join /DJoin.univ_inj ? _ _ Γ A hi hj. *) -(* subst. *) -(* hauto l:on. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on use:Sub.nat_univ_noconf, Sub.FromJoin. *) -(* * move => > /algo_metric_join. *) -(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv. *) -(* * move => > /algo_metric_join. *) -(* clear. hauto lq:on rew:off use:REReds.univ_inv, REReds.suc_inv. *) -(* + case : b => //=. *) -(* * qauto l:on use:T_AbsNat_Imp. *) -(* * qauto l:on use:T_PairNat_Imp. *) -(* * move => > /algo_metric_join /Sub.FromJoin. hauto l:on use:Sub.bind_nat_noconf. *) -(* * move => > /algo_metric_join /Sub.FromJoin. hauto lq:on use:Sub.univ_nat_noconf. *) -(* * hauto l:on. *) -(* * move /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv. *) -(* (* Zero *) *) -(* + case : b => //=. *) -(* * hauto lq:on rew:off use:T_AbsZero_Imp. *) -(* * hauto lq: on use: T_PairZero_Imp. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.bind_inv. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.univ_inv. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.nat_inv. *) -(* * hauto l:on. *) -(* * move =>> /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.zero_inv, REReds.suc_inv. *) -(* (* Suc *) *) -(* + case : b => //=. *) -(* * hauto lq:on rew:off use:T_AbsSuc_Imp. *) -(* * hauto lq:on use:T_PairSuc_Imp. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.bind_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.nat_inv. *) -(* * move => > /algo_metric_join. *) -(* hauto lq:on rew:off use:REReds.suc_inv, REReds.zero_inv. *) -(* * move => a0 a1 h _ _. *) -(* move /algo_metric_suc : h => [j [h4 h5]]. *) -(* move => Γ A /Suc_Inv [h0 h1] /Suc_Inv [h2 h3]. *) -(* move : ih h4 h5;do!move/[apply]. *) -(* move => [ih _]. *) -(* move : ih h0 h2;do!move/[apply]. *) -(* move => h. apply : CE_HRed; eauto using rtc_refl. *) -(* by constructor. *) -(* - move : a b h fb fa. abstract : hnfneu. *) -(* move => + b. *) -(* case : b => //=. *) -(* (* NeuAbs *) *) -(* + move => a u halg _ nea. split => // Γ A hu /[dup] ha. *) -(* move /Abs_Inv => [A0][B0][_]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. *) -(* move /Abs_Pi_Inv in ha. *) -(* move /algo_metric_neu_abs /(_ nea) : halg. *) -(* move => [j0][hj0]halg. *) -(* apply : CE_HRed; eauto using rtc_refl. *) -(* eapply CE_NeuAbs => //=. *) -(* eapply ih; eauto. *) -(* (* NeuPair *) *) -(* + move => a0 b0 u halg _ neu. *) -(* split => // Γ A hu /[dup] wt. *) -(* move /Pair_Inv => [A0][B0][ha0][hb0]hU. *) -(* 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. *) -(* move /algo_metric_neu_pair /(_ neu) : halg => [j [hj [hL hR]]]. *) -(* have heL : PProj PL u ⇔ a0 by hauto l:on. *) -(* eapply CE_HRed; eauto using rtc_refl. *) -(* apply CE_NeuPair; eauto. *) -(* eapply ih; eauto. *) -(* apply : T_Conv; eauto. *) -(* have {}hE : Γ ⊢ PBind PSig A2 B2 ∈ PUniv i *) -(* by hauto l:on use:regularity. *) -(* have /E_Symmetric : Γ ⊢ PProj PL u ≡ a0 ∈ A2 by *) -(* hauto l:on use:coqeq_sound_mutual. *) -(* hauto l:on use:bind_inst. *) -(* (* NeuBind: Impossible *) *) -(* + move => b p p0 a /algo_metric_join h _ h0. exfalso. *) -(* move : h h0. clear. *) -(* move /Sub.FromJoin. *) -(* hauto l:on use:Sub.hne_bind_noconf. *) -(* (* NeuUniv: Impossible *) *) -(* + hauto lq:on rew:off use:DJoin.hne_univ_noconf, algo_metric_join. *) -(* + hauto lq:on rew:off use:DJoin.hne_nat_noconf, algo_metric_join. *) -(* (* Zero *) *) -(* + case => //=. *) -(* * move => i /algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.var_inv, REReds.zero_inv. *) -(* * move => >/algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.zero_inv. *) -(* * move => >/algo_metric_join. clear. *) -(* hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.zero_inv. *) -(* * move => >/algo_metric_join. clear. *) -(* move => h _ h2. exfalso. *) -(* hauto q:on use:REReds.hne_ind_inv, REReds.zero_inv. *) -(* (* Suc *) *) -(* + move => a0. *) -(* case => //=; move => >/algo_metric_join; clear. *) -(* * hauto lq:on rew:off use:REReds.var_inv, REReds.suc_inv. *) -(* * hauto lq:on rew:off use:REReds.hne_app_inv, REReds.suc_inv. *) -(* * hauto lq:on rew:off use:REReds.hne_proj_inv, REReds.suc_inv. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.suc_inv. *) -(* - move {ih}. *) -(* move /algo_metric_sym in h. *) -(* qauto l:on use:coqeq_symmetric_mutual. *) -(* - move {hnfneu}. *) -(* (* Clear out some trivial cases *) *) -(* suff : (forall Γ A B, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ B -> a ∼ b /\ (exists C, Γ ⊢ C ≲ A /\ Γ ⊢ C ≲ B /\ Γ ⊢ a ∈ C /\ Γ ⊢ b ∈ C)). *) -(* move => h0. *) -(* split. move => *. apply : CE_HRed; eauto using rtc_refl. apply CE_NeuNeu. by firstorder. *) -(* by firstorder. *) - -(* case : a h fb fa => //=. *) -(* + case : b => //=; move => > /algo_metric_join. *) -(* * move /DJoin.var_inj => i _ _. subst. *) -(* move => Γ A B /Var_Inv [? [B0 [h0 h1]]]. *) -(* move /Var_Inv => [_ [C0 [h2 h3]]]. *) -(* have ? : B0 = C0 by eauto using lookup_deter. subst. *) -(* sfirstorder use:T_Var. *) -(* * clear => ? ? _. exfalso. *) -(* hauto l:on use:REReds.var_inv, REReds.hne_app_inv. *) -(* * clear => ? ? _. exfalso. *) -(* hauto l:on use:REReds.var_inv, REReds.hne_proj_inv. *) -(* * clear => ? ? _. exfalso. *) -(* hauto q:on use:REReds.var_inv, REReds.hne_ind_inv. *) -(* + case : b => //=; *) -(* lazymatch goal with *) -(* | [|- context[algo_metric _ (PApp _ _) (PApp _ _)]] => idtac *) -(* | _ => move => > /algo_metric_join *) -(* end. *) -(* * clear => *. exfalso. *) -(* hauto lq:on rew:off use:REReds.hne_app_inv, REReds.var_inv. *) -(* (* real case *) *) -(* * move => b1 a1 b0 a0 halg hne1 hne0 Γ A B wtA wtB. *) -(* move /App_Inv : wtA => [A0][B0][hb0][ha0]hS0. *) -(* move /App_Inv : wtB => [A1][B1][hb1][ha1]hS1. *) -(* move : algo_metric_app (hne0) (hne1) halg. repeat move/[apply]. *) -(* move => [j [hj [hal0 hal1]]]. *) -(* have /ih := hal0. *) -(* move /(_ hj). *) -(* move => [_ ihb]. *) -(* move : ihb (hne0) (hne1) 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 : ih (hj) hal1. repeat move/[apply]. *) -(* move => [ih _]. *) -(* move : ih (ha0') (ha1'); repeat move/[apply]. *) -(* move => iha. *) -(* split. qblast. *) -(* 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. *) -(* * clear => ? ? ?. exfalso. *) -(* hauto q:on use:REReds.hne_app_inv, REReds.hne_proj_inv. *) -(* * clear => ? ? ?. exfalso. *) -(* hauto q:on use:REReds.hne_app_inv, REReds.hne_ind_inv. *) -(* + case : b => //=. *) -(* * move => i p h /algo_metric_join. clear => ? _ ?. exfalso. *) -(* hauto l:on use:REReds.hne_proj_inv, REReds.var_inv. *) -(* * move => > /algo_metric_join. clear => ? ? ?. exfalso. *) -(* hauto l:on use:REReds.hne_proj_inv, REReds.hne_app_inv. *) -(* (* real case *) *) -(* * move => p1 a1 p0 a0 /algo_metric_proj ha hne1 hne0. *) -(* move : ha (hne0) (hne1); repeat move/[apply]. *) -(* move => [? [j []]]. subst. *) -(* move : ih; repeat move/[apply]. *) -(* move => [_ ih]. *) -(* case : p1. *) -(* ** move => Γ A B 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 => Γ A B 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 => > /algo_metric_join; clear => ? ? ?. exfalso. *) -(* hauto q:on use:REReds.hne_proj_inv, REReds.hne_ind_inv. *) -(* (* ind ind case *) *) -(* + move => P a0 b0 c0. *) -(* case : b => //=; *) -(* lazymatch goal with *) -(* | [|- context[algo_metric _ (PInd _ _ _ _) (PInd _ _ _ _)]] => idtac *) -(* | _ => move => > /algo_metric_join; clear => *; exfalso *) -(* end. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.var_inv. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_app_inv. *) -(* * hauto q:on use:REReds.hne_ind_inv, REReds.hne_proj_inv. *) -(* * move => P1 a1 b1 c1 /[dup] halg /algo_metric_ind + h0 h1. *) -(* move /(_ h1 h0). *) -(* move => [j][hj][hP][ha][hb]hc Γ A B hL hR. *) -(* move /Ind_Inv : hL => [iP0][wtP0][wta0][wtb0][wtc0]hSu0. *) -(* move /Ind_Inv : hR => [iP1][wtP1][wta1][wtb1][wtc1]hSu1. *) -(* have {}iha : a0 ∼ a1 by qauto l:on. *) -(* have [] : iP0 <= max iP0 iP1 /\ iP1 <= max iP0 iP1 by lia. *) -(* move : T_Univ_Raise wtP0; do!move/[apply]. move => wtP0. *) -(* move : T_Univ_Raise wtP1; do!move/[apply]. move => wtP1. *) -(* have {}ihP : P ⇔ P1 by qauto l:on. *) -(* set Δ := cons _ _ in wtP0, wtP1, wtc0, wtc1. *) -(* have wfΔ :⊢ Δ by hauto l:on use:wff_mutual. *) -(* have hPE : Δ ⊢ P ≡ P1 ∈ PUniv (max iP0 iP1) *) -(* by hauto l:on use:coqeq_sound_mutual. *) -(* have haE : Γ ⊢ a0 ≡ a1 ∈ 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) P ≡ 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) P *) -(* by eauto using T_Conv_E. *) -(* have {}ihb : b0 ⇔ b1 by hauto l:on. *) -(* have hPSig : Γ ⊢ PBind PSig PNat P ≡ PBind PSig PNat P1 ∈ PUniv (Nat.max iP0 iP1) by eauto with wt. *) -(* set T := ren_PTm shift _ in wtc0. *) -(* have : (cons P Δ) ⊢ 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 : h0 h1 ihP iha ihb ihc. clear. sauto lq:on. *) -(* have hEInd : Γ ⊢ PInd P a0 b0 c0 ≡ PInd P1 a1 b1 c1 ∈ subst_PTm (scons a0 VarPTm) P by hfcrush use:coqeq_sound_mutual. *) -(* exists (subst_PTm (scons a0 VarPTm) P). *) -(* 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. *) -(* Qed. *) +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 coqeq_complete Γ (a b A : PTm) : *) -(* Γ ⊢ a ≡ b ∈ A -> a ⇔ b. *) -(* Proof. *) -(* move => h. *) -(* suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. *) -(* eapply fundamental_theorem in h. *) -(* move /logrel.SemEq_SN_Join : h. *) -(* move => h. *) -(* have : exists va vb : PTm, *) -(* rtc LoRed.R a va /\ *) -(* rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb *) -(* by hauto l:on use:DJoin.standardization_lo. *) -(* move => [va][vb][hva][hvb][nva][nvb]hj. *) -(* move /relations.rtc_nsteps : hva => [i hva]. *) -(* move /relations.rtc_nsteps : hvb => [j hvb]. *) -(* exists (i + j + size_PTm va + size_PTm vb). *) -(* hauto lq:on solve+:lia. *) -(* Qed. *) +Lemma coqeq_complete Γ (a b A : PTm) : + Γ ⊢ a ≡ b ∈ A -> a ⇔ b. +Proof. + move => h. + suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. + eapply fundamental_theorem in h. + move /logrel.SemEq_SN_Join : h. + move => h. + have : exists va vb : PTm, + rtc LoRed.R a va /\ + rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb + by hauto l:on use:DJoin.standardization_lo. + move => [va][vb][hva][hvb][nva][nvb]hj. + move /relations.rtc_nsteps : hva => [i hva]. + move /relations.rtc_nsteps : hvb => [j hvb]. + exists (i + j + size_PTm va + size_PTm vb). + hauto lq:on solve+:lia. +Qed. Reserved Notation "a ≪ b" (at level 70). From 96ad0a474067aae6b05c92b0ef70acc00371640b Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 11 Mar 2025 00:14:43 -0400 Subject: [PATCH 38/51] Add stub for the new coqleq_complete' --- theories/algorithmic.v | 456 ++++++++++++++-------------------- theories/common.v | 2 + theories/executable.v | 8 +- theories/executable_correct.v | 11 - theories/termination.v | 16 -- 5 files changed, 193 insertions(+), 300 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index a870f9f..d4aa29d 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -1647,26 +1647,31 @@ 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. - suff : exists k, algo_metric k a b by hauto lq:on use:coqeq_complete', regularity. - eapply fundamental_theorem in h. - move /logrel.SemEq_SN_Join : h. - move => h. - have : exists va vb : PTm, - rtc LoRed.R a va /\ - rtc LoRed.R b vb /\ nf va /\ nf vb /\ EJoin.R va vb - by hauto l:on use:DJoin.standardization_lo. - move => [va][vb][hva][hvb][nva][nvb]hj. - move /relations.rtc_nsteps : hva => [i hva]. - move /relations.rtc_nsteps : hvb => [j hvb]. - exists (i + j + size_PTm va + size_PTm vb). - hauto lq:on solve+:lia. + 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 := @@ -1708,269 +1713,176 @@ Scheme coqleq_ind := Induction for CoqLEq Sort Prop Combined Scheme coqleq_mutual from coqleq_ind, coqleq_r_ind. -(* Definition salgo_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 /\ ESub.R va vb /\ size_PTm va + size_PTm vb + i + j <= k. *) +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 salgo_metric_algo_metric k (a b : PTm) : *) -(* ishne a \/ ishne b -> *) -(* salgo_metric k a b -> *) -(* algo_metric k a b. *) -(* Proof. *) -(* move => h. *) -(* move => [i][j][va][vb][hva][hvb][nva][nvb][hS]sz. *) -(* rewrite/ESub.R in hS. *) -(* move : hS => [va'][vb'][h0][h1]h2. *) -(* suff : va' = vb' by sauto lq:on. *) -(* have {}hva : rtc RERed.R a va by hauto lq:on use:@relations.rtc_nsteps, REReds.FromRReds, LoReds.ToRReds. *) -(* have {}hvb : rtc RERed.R b vb by hauto lq:on use:@relations.rtc_nsteps, REReds.FromRReds, LoReds.ToRReds. *) -(* apply REReds.FromEReds in h0, h1. *) -(* have : ishne va' \/ ishne vb' by *) -(* hauto lq:on rew:off use:@relations.rtc_transitive, REReds.hne_preservation. *) -(* hauto lq:on use:Sub1.hne_refl. *) -(* 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 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_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 salgo_metric_case k (a b : PTm ) : *) -(* salgo_metric k a b -> *) -(* (ishf a \/ ishne a) \/ exists k' a', HRed.R a a' /\ salgo_metric k' a' b /\ k' < k. *) -(* Proof. *) -(* move=>[i][j][va][vb][h0] [h1][h2][h3][[v [h4 h5]]] h6. *) -(* 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:algo_metric solve+:lia. *) -(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_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:algo_metric solve+:lia. *) -(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_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:algo_metric solve+:lia. *) -(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) -(* + sfirstorder use:ne_hne. *) -(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) -(* + sfirstorder use:ne_hne. *) -(* + sfirstorder use:ne_hne. *) -(* 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 coqleq_complete' : + (forall a b, salgo_dom a b -> Sub.R a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⋖ b) /\ + (forall a b, salgo_dom_r a b -> Sub.R a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ≪ b). +Proof. + apply salgo_dom_mutual. + - move => i j /Sub.univ_inj. + hauto lq:on ctrs:CoqLEq. + - admit. + - admit. + - sfirstorder. + - admit. + - admit. + - 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. +Admitted. -(* Lemma algo_metric_caseR k (a b : PTm) : *) -(* salgo_metric k a b -> *) -(* (ishf b \/ ishne b) \/ exists k' b', HRed.R b b' /\ salgo_metric k' a b' /\ k' < k. *) -(* Proof. *) -(* move=>[i][j][va][vb][h0] [h1][h2][h3][[v [h4 h5]]] h6. *) -(* case : b h1 => //=; try by firstorder. *) -(* - inversion 1 as [|A B C D E F]; subst. *) -(* hauto qb:on use:ne_hne. *) -(* inversion E; subst => /=. *) -(* + hauto q:on use:HRed.AppAbs unfold:salgo_metric solve+:lia. *) -(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:salgo_metric solve+:lia. *) -(* + sfirstorder qb:on use:ne_hne. *) -(* - inversion 1 as [|A B C D E F]; subst. *) -(* hauto qb:on use:ne_hne. *) -(* inversion E; subst => /=. *) -(* + hauto lq:on use:HRed.ProjPair unfold:algo_metric solve+:lia. *) -(* + hauto q:on ctrs:HRed.R use: hf_hred_lored unfold:algo_metric solve+:lia. *) -(* - inversion 1 as [|A B C D E F]; subst. *) -(* hauto qb:on use:ne_hne. *) -(* inversion E; subst => /=. *) -(* + hauto lq:on use:HRed.IndZero unfold:algo_metric solve+:lia. *) -(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) -(* + sfirstorder use:ne_hne. *) -(* + hauto lq:on ctrs:HRed.R use:hf_hred_lored unfold:algo_metric solve+:lia. *) -(* + sfirstorder use:ne_hne. *) -(* + sfirstorder use:ne_hne. *) -(* Qed. *) - -(* Lemma salgo_metric_sub k (a b : PTm) : *) -(* salgo_metric k a b -> *) -(* Sub.R a b. *) -(* Proof. *) -(* rewrite /algo_metric. *) -(* move => [i][j][va][vb][h0][h1][h2][h3][[va' [vb' [hva [hvb hS]]]]]h5. *) -(* have {}h0 : rtc LoRed.R a va by hauto lq:on use:@relations.rtc_nsteps. *) -(* have {}h1 : rtc LoRed.R b vb by hauto lq:on use:@relations.rtc_nsteps. *) -(* apply REReds.FromEReds in hva,hvb. *) -(* apply LoReds.ToRReds in h0,h1. *) -(* apply REReds.FromRReds in h0,h1. *) -(* rewrite /Sub.R. exists va', vb'. sfirstorder use:@relations.rtc_transitive. *) -(* Qed. *) - -(* Lemma salgo_metric_pi k (A0 : PTm) B0 A1 B1 : *) -(* salgo_metric k (PBind PPi A0 B0) (PBind PPi A1 B1) -> *) -(* exists j, j < k /\ salgo_metric j A1 A0 /\ salgo_metric j B0 B1. *) -(* Proof. *) -(* move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. *) -(* move : lored_nsteps_bind_inv h0 => /[apply]. *) -(* move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. *) -(* move : lored_nsteps_bind_inv h1 => /[apply]. *) -(* move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. *) -(* move /ESub.pi_inj : h4 => [? ?]. *) -(* hauto qb:on solve+:lia. *) -(* Qed. *) - -(* Lemma salgo_metric_sig k (A0 : PTm) B0 A1 B1 : *) -(* salgo_metric k (PBind PSig A0 B0) (PBind PSig A1 B1) -> *) -(* exists j, j < k /\ salgo_metric j A0 A1 /\ salgo_metric j B0 B1. *) -(* Proof. *) -(* move => [i][j][va][vb][h0][h1][h2][h3][h4]h5. *) -(* move : lored_nsteps_bind_inv h0 => /[apply]. *) -(* move => [i0][i1][a2][b2][?][?][?][ha02]hb02. subst. *) -(* move : lored_nsteps_bind_inv h1 => /[apply]. *) -(* move => [j0][j1][a3][b3][?][?][?][ha13]hb13. subst. *) -(* move /ESub.sig_inj : h4 => [? ?]. *) -(* hauto qb:on solve+:lia. *) -(* Qed. *) - -(* Lemma coqleq_complete' k (a b : PTm ) : *) -(* salgo_metric k a b -> (forall Γ i, Γ ⊢ a ∈ PUniv i -> Γ ⊢ b ∈ PUniv i -> a ≪ b). *) -(* Proof. *) -(* move : k a b. *) -(* elim /Wf_nat.lt_wf_ind. *) -(* move => n ih. *) -(* move => a b /[dup] h /salgo_metric_case. *) -(* (* Cases where a and b can take steps *) *) -(* case; cycle 1. *) -(* move : a b h. *) -(* qauto l:on use:HRed.preservation, CLE_HRedL, hred_hne. *) -(* case /algo_metric_caseR : (h); cycle 1. *) -(* qauto l:on use:HRed.preservation, CLE_HRedR, hred_hne. *) -(* (* Cases where neither a nor b can take steps *) *) -(* case => fb; case => fa. *) -(* - case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) -(* + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) -(* * move => p0 A0 B0 _ p1 A1 B1 _. *) -(* move => h. *) -(* have ? : p1 = p0 by *) -(* hauto lq:on rew:off use:salgo_metric_sub, Sub.bind_inj. *) -(* subst. *) -(* case : p0 h => //=. *) -(* ** move /salgo_metric_pi. *) -(* move => [j [hj [hA hB]]] Γ i. *) -(* move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. *) -(* have ihA : A0 ≪ A1 by hauto l:on. *) -(* econstructor; eauto using E_Refl; 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. *) -(* ** move /salgo_metric_sig. *) -(* move => [j [hj [hA hB]]] Γ i. *) -(* move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. *) -(* have ihA : A1 ≪ A0 by hauto l:on. *) -(* econstructor; eauto using E_Refl; 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. *) -(* * hauto lq:on use:salgo_metric_sub, Sub.bind_univ_noconf. *) -(* * hauto lq:on use:salgo_metric_sub, Sub.nat_bind_noconf. *) -(* * move => _ > _ /salgo_metric_sub. *) -(* hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv inv:Sub1.R. *) -(* * hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. *) -(* + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) -(* * hauto lq:on use:salgo_metric_sub, Sub.univ_bind_noconf. *) -(* * move => *. econstructor; eauto using rtc_refl. *) -(* hauto lq:on use:salgo_metric_sub, Sub.univ_inj, CLE_UnivCong. *) -(* * hauto lq:on rew:off use:REReds.univ_inv, REReds.nat_inv, salgo_metric_sub inv:Sub1.R. *) -(* * hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. *) -(* * hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. *) -(* (* Both cases are impossible *) *) -(* + case : b fb => //=. *) -(* * hauto lq:on use:T_AbsNat_Imp. *) -(* * hauto lq:on use:T_PairNat_Imp. *) -(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.bind_inv, salgo_metric_sub inv:Sub1.R. *) -(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. *) -(* * hauto l:on. *) -(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. *) -(* * hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. *) -(* + move => ? ? Γ i /Zero_Inv. *) -(* clear. *) -(* move /synsub_to_usub => [_ [_ ]]. *) -(* hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. *) -(* + move => ? _ _ Γ i /Suc_Inv => [[_]]. *) -(* move /synsub_to_usub. *) -(* hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. *) -(* - have {}h : DJoin.R a b by *) -(* hauto lq:on use:salgo_metric_algo_metric, algo_metric_join. *) -(* case : b fb h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) -(* + hauto lq:on use:DJoin.hne_bind_noconf. *) -(* + hauto lq:on use:DJoin.hne_univ_noconf. *) -(* + hauto lq:on use:DJoin.hne_nat_noconf. *) -(* + move => _ _ Γ i _. *) -(* move /Zero_Inv. *) -(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) -(* + move => p _ _ Γ i _ /Suc_Inv. *) -(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) -(* - have {}h : DJoin.R b a by *) -(* hauto lq:on use:salgo_metric_algo_metric, algo_metric_join, DJoin.symmetric. *) -(* case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. *) -(* + hauto lq:on use:DJoin.hne_bind_noconf. *) -(* + hauto lq:on use:DJoin.hne_univ_noconf. *) -(* + hauto lq:on use:DJoin.hne_nat_noconf. *) -(* + move => _ _ Γ i. *) -(* move /Zero_Inv. *) -(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) -(* + move => p _ _ Γ i /Suc_Inv. *) -(* hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. *) -(* - move => Γ i ha hb. *) -(* econstructor; eauto using rtc_refl. *) -(* apply CLE_NeuNeu. move {ih}. *) -(* have {}h : algo_metric n a b by *) -(* hauto lq:on use:salgo_metric_algo_metric. *) -(* eapply coqeq_complete'; eauto. *) -(* Qed. *) + move : k a b. + elim /Wf_nat.lt_wf_ind. + move => n ih. + move => a b /[dup] h /salgo_metric_case. + (* Cases where a and b can take steps *) + case; cycle 1. + move : a b h. + qauto l:on use:HRed.preservation, CLE_HRedL, hred_hne. + case /algo_metric_caseR : (h); cycle 1. + qauto l:on use:HRed.preservation, CLE_HRedR, hred_hne. + (* Cases where neither a nor b can take steps *) + case => fb; case => fa. + - case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. + + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. + * move => p0 A0 B0 _ p1 A1 B1 _. + move => h. + have ? : p1 = p0 by + hauto lq:on rew:off use:salgo_metric_sub, Sub.bind_inj. + subst. + case : p0 h => //=. + ** move /salgo_metric_pi. + move => [j [hj [hA hB]]] Γ i. + move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. + have ihA : A0 ≪ A1 by hauto l:on. + econstructor; eauto using E_Refl; 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. + ** move /salgo_metric_sig. + move => [j [hj [hA hB]]] Γ i. + move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. + have ihA : A1 ≪ A0 by hauto l:on. + econstructor; eauto using E_Refl; 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. + * hauto lq:on use:salgo_metric_sub, Sub.bind_univ_noconf. + * hauto lq:on use:salgo_metric_sub, Sub.nat_bind_noconf. + * move => _ > _ /salgo_metric_sub. + hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv inv:Sub1.R. + * hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. + + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. + * hauto lq:on use:salgo_metric_sub, Sub.univ_bind_noconf. + * move => *. econstructor; eauto using rtc_refl. + hauto lq:on use:salgo_metric_sub, Sub.univ_inj, CLE_UnivCong. + * hauto lq:on rew:off use:REReds.univ_inv, REReds.nat_inv, salgo_metric_sub inv:Sub1.R. + * hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. + * hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. + (* Both cases are impossible *) + + case : b fb => //=. + * hauto lq:on use:T_AbsNat_Imp. + * hauto lq:on use:T_PairNat_Imp. + * hauto lq:on rew:off use:REReds.nat_inv, REReds.bind_inv, salgo_metric_sub inv:Sub1.R. + * hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. + * hauto l:on. + * hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. + * hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. + + move => ? ? Γ i /Zero_Inv. + clear. + move /synsub_to_usub => [_ [_ ]]. + hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. + + move => ? _ _ Γ i /Suc_Inv => [[_]]. + move /synsub_to_usub. + hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. + - have {}h : DJoin.R a b by + hauto lq:on use:salgo_metric_algo_metric, algo_metric_join. + case : b fb h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. + + hauto lq:on use:DJoin.hne_bind_noconf. + + hauto lq:on use:DJoin.hne_univ_noconf. + + hauto lq:on use:DJoin.hne_nat_noconf. + + move => _ _ Γ i _. + move /Zero_Inv. + hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. + + move => p _ _ Γ i _ /Suc_Inv. + hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. + - have {}h : DJoin.R b a by + hauto lq:on use:salgo_metric_algo_metric, algo_metric_join, DJoin.symmetric. + case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. + + hauto lq:on use:DJoin.hne_bind_noconf. + + hauto lq:on use:DJoin.hne_univ_noconf. + + hauto lq:on use:DJoin.hne_nat_noconf. + + move => _ _ Γ i. + move /Zero_Inv. + hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. + + move => p _ _ Γ i /Suc_Inv. + hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. + - move => Γ i ha hb. + econstructor; eauto using rtc_refl. + apply CLE_NeuNeu. move {ih}. + have {}h : algo_metric n a b by + hauto lq:on use:salgo_metric_algo_metric. + eapply coqeq_complete'; eauto. +Qed. (* Lemma coqleq_complete Γ (a b : PTm) : *) (* Γ ⊢ a ≲ b -> a ≪ b. *) diff --git a/theories/common.v b/theories/common.v index 39713ba..35267fc 100644 --- a/theories/common.v +++ b/theories/common.v @@ -403,6 +403,8 @@ with salgo_dom_r : PTm -> PTm -> Prop := 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 -> diff --git a/theories/executable.v b/theories/executable.v index e62e3c3..558aa75 100644 --- a/theories/executable.v +++ b/theories/executable.v @@ -341,4 +341,10 @@ Proof. sfirstorder use:hne_no_hred, hf_no_hred. Qed. -#[export]Hint Rewrite check_sub_hredl check_sub_hredr check_sub_nfnf check_sub_univ_univ check_sub_pi_pi check_sub_sig_sig : ce_prop. +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 index 4b76638..40debce 100644 --- a/theories/executable_correct.v +++ b/theories/executable_correct.v @@ -180,17 +180,6 @@ Qed. Ltac simp_sub := with_strategy opaque [check_equal] simpl in *. -Combined Scheme salgo_dom_mutual from salgo_ind, salgor_ind. - -(* Reusing algo_dom results in an inefficient proof, but i'll brute force it so i can get the result more quickly *) -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. - -Hint Rewrite check_sub_neuneu check_sub_conf : ce_prop. - 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). diff --git a/theories/termination.v b/theories/termination.v index 41400ef..c5bc37e 100644 --- a/theories/termination.v +++ b/theories/termination.v @@ -3,19 +3,3 @@ From Hammer Require Import Tactics. Require Import ssreflect ssrbool. From stdpp Require Import relations (nsteps (..), rtc(..)). Import Psatz. - -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. From 8dbef3e29ed6f0a6c31fb26f0b2934d6b7fd9f5a Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 11 Mar 2025 16:24:57 -0400 Subject: [PATCH 39/51] Finish refactoring --- theories/algorithmic.v | 243 +++++++++++++++++++---------------------- 1 file changed, 112 insertions(+), 131 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index d4aa29d..d9711e1 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -947,6 +947,18 @@ 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. @@ -1760,18 +1772,95 @@ 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 Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ⋖ b) /\ - (forall a b, salgo_dom_r a b -> Sub.R a b -> forall Γ A, Γ ⊢ a ∈ A -> Γ ⊢ b ∈ A -> a ≪ b). + (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. - - admit. - - admit. + - 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. - - admit. - - admit. + - 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. @@ -1785,130 +1874,22 @@ Proof. apply : Sub.transitive; eauto. hauto lq:on use:fundamental_theorem, logrel.SemWt_SN. apply /Sub.FromJoin /DJoin.FromRRed0. by apply HRed.ToRRed. -Admitted. - - - move : k a b. - elim /Wf_nat.lt_wf_ind. - move => n ih. - move => a b /[dup] h /salgo_metric_case. - (* Cases where a and b can take steps *) - case; cycle 1. - move : a b h. - qauto l:on use:HRed.preservation, CLE_HRedL, hred_hne. - case /algo_metric_caseR : (h); cycle 1. - qauto l:on use:HRed.preservation, CLE_HRedR, hred_hne. - (* Cases where neither a nor b can take steps *) - case => fb; case => fa. - - case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - * move => p0 A0 B0 _ p1 A1 B1 _. - move => h. - have ? : p1 = p0 by - hauto lq:on rew:off use:salgo_metric_sub, Sub.bind_inj. - subst. - case : p0 h => //=. - ** move /salgo_metric_pi. - move => [j [hj [hA hB]]] Γ i. - move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. - have ihA : A0 ≪ A1 by hauto l:on. - econstructor; eauto using E_Refl; 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. - ** move /salgo_metric_sig. - move => [j [hj [hA hB]]] Γ i. - move /Bind_Univ_Inv => [hA1 hB1] /Bind_Univ_Inv [hA0 hB0]. - have ihA : A1 ≪ A0 by hauto l:on. - econstructor; eauto using E_Refl; 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. - * hauto lq:on use:salgo_metric_sub, Sub.bind_univ_noconf. - * hauto lq:on use:salgo_metric_sub, Sub.nat_bind_noconf. - * move => _ > _ /salgo_metric_sub. - hauto lq:on rew:off use:REReds.bind_inv, REReds.zero_inv inv:Sub1.R. - * hauto lq:on rew:off use:REReds.bind_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. - + case : b fb => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - * hauto lq:on use:salgo_metric_sub, Sub.univ_bind_noconf. - * move => *. econstructor; eauto using rtc_refl. - hauto lq:on use:salgo_metric_sub, Sub.univ_inj, CLE_UnivCong. - * hauto lq:on rew:off use:REReds.univ_inv, REReds.nat_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.univ_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.suc_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. - (* Both cases are impossible *) - + case : b fb => //=. - * hauto lq:on use:T_AbsNat_Imp. - * hauto lq:on use:T_PairNat_Imp. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.bind_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv, salgo_metric_sub inv:Sub1.R. - * hauto l:on. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.zero_inv, salgo_metric_sub inv:Sub1.R. - * hauto lq:on rew:off use:REReds.nat_inv, REReds.suc_inv, salgo_metric_sub inv:Sub1.R. - + move => ? ? Γ i /Zero_Inv. - clear. - move /synsub_to_usub => [_ [_ ]]. - hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. - + move => ? _ _ Γ i /Suc_Inv => [[_]]. - move /synsub_to_usub. - hauto lq:on rew:off use:REReds.nat_inv, REReds.univ_inv inv:Sub1.R. - - have {}h : DJoin.R a b by - hauto lq:on use:salgo_metric_algo_metric, algo_metric_join. - case : b fb h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - + hauto lq:on use:DJoin.hne_bind_noconf. - + hauto lq:on use:DJoin.hne_univ_noconf. - + hauto lq:on use:DJoin.hne_nat_noconf. - + move => _ _ Γ i _. - move /Zero_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - + move => p _ _ Γ i _ /Suc_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - - have {}h : DJoin.R b a by - hauto lq:on use:salgo_metric_algo_metric, algo_metric_join, DJoin.symmetric. - case : a fa h => //=; try hauto depth:1 lq:on use:T_AbsUniv_Imp', T_PairUniv_Imp'. - + hauto lq:on use:DJoin.hne_bind_noconf. - + hauto lq:on use:DJoin.hne_univ_noconf. - + hauto lq:on use:DJoin.hne_nat_noconf. - + move => _ _ Γ i. - move /Zero_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - + move => p _ _ Γ i /Suc_Inv. - hauto q:on use:REReds.nat_inv, REReds.univ_inv, synsub_to_usub inv:Sub1.R. - - move => Γ i ha hb. - econstructor; eauto using rtc_refl. - apply CLE_NeuNeu. move {ih}. - have {}h : algo_metric n a b by - hauto lq:on use:salgo_metric_algo_metric. - eapply coqeq_complete'; eauto. +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_complete Γ (a b : PTm) : *) -(* Γ ⊢ a ≲ b -> a ≪ b. *) -(* Proof. *) -(* move => h. *) -(* suff : exists k, salgo_metric k a b by hauto lq:on use:coqleq_complete', regularity. *) -(* eapply fundamental_theorem in h. *) -(* move /logrel.SemLEq_SN_Sub : h. *) -(* move => h. *) -(* have : exists va vb : PTm , *) -(* rtc LoRed.R a va /\ *) -(* rtc LoRed.R b vb /\ nf va /\ nf vb /\ ESub.R va vb *) -(* by hauto l:on use:Sub.standardization_lo. *) -(* move => [va][vb][hva][hvb][nva][nvb]hj. *) -(* move /relations.rtc_nsteps : hva => [i hva]. *) -(* move /relations.rtc_nsteps : hvb => [j hvb]. *) -(* exists (i + j + size_PTm va + size_PTm vb). *) -(* hauto lq:on solve+:lia. *) -(* 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. *) +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. From f9d3a620f4c6d920465f3b84bd2f3441c7cb07bc Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Tue, 11 Mar 2025 16:27:31 -0400 Subject: [PATCH 40/51] Remove itauto dependency as it introduces weird axioms --- theories/algorithmic.v | 5 ++--- theories/fp_red.v | 14 +++++++------- theories/logrel.v | 16 ++++++++-------- 3 files changed, 17 insertions(+), 18 deletions(-) diff --git a/theories/algorithmic.v b/theories/algorithmic.v index d9711e1..184872d 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -5,7 +5,6 @@ Require Import ssreflect ssrbool. Require Import Psatz. From stdpp Require Import relations (rtc(..), nsteps(..)). Require Import Coq.Logic.FunctionalExtensionality. -Require Import Cdcl.Itauto. Module HRed. Lemma ToRRed (a b : PTm) : HRed.R a b -> RRed.R a b. @@ -98,7 +97,7 @@ Proof. - 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 => //=. itauto. + 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. @@ -199,7 +198,7 @@ Proof. - 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 => //=. itauto. + 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. diff --git a/theories/fp_red.v b/theories/fp_red.v index 9d8718b..382f25b 100644 --- a/theories/fp_red.v +++ b/theories/fp_red.v @@ -10,7 +10,7 @@ From stdpp Require Import relations (rtc (..), rtc_once, rtc_r, sn). From Hammer Require Import Tactics. Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common. Require Import Btauto. -Require Import Cdcl.Itauto. + Ltac2 spec_refl () := List.iter @@ -2575,7 +2575,7 @@ Module LoReds. ~~ 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 := @@ -2633,7 +2633,7 @@ Module LoReds. rtc LoRed.R (PSuc a0) (PSuc a1). Proof. solve_s. Qed. - Local Ltac triv := simpl in *; itauto. + 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) /\ @@ -3048,7 +3048,7 @@ Module DJoin. have {h0 h1 h2 h3} : isbind c /\ isuniv c by hauto l:on use:REReds.bind_preservation, REReds.univ_preservation. - case : c => //=; itauto. + case : c => //=; sfirstorder b:on. Qed. Lemma hne_univ_noconf (a b : PTm) : @@ -3078,7 +3078,7 @@ Module DJoin. Proof. move => [c [h0 h1]] h2 h3. have : ishne c /\ isnat c by sfirstorder use:REReds.hne_preservation, REReds.nat_preservation. - clear. case : c => //=; itauto. + clear. case : c => //=; sfirstorder b:on. Qed. Lemma bind_inj p0 p1 (A0 A1 : PTm) B0 B1 : @@ -3594,7 +3594,7 @@ Module Sub. hauto l:on use:REReds.bind_preservation, REReds.univ_preservation, Sub1.bind_preservation, Sub1.univ_preservation. move : h2 h3. clear. - case : c => //=; itauto. + case : c => //=; sfirstorder b:on. Qed. Lemma univ_bind_noconf (a b : PTm) : @@ -3605,7 +3605,7 @@ Module Sub. hauto l:on use:REReds.bind_preservation, REReds.univ_preservation, Sub1.bind_preservation, Sub1.univ_preservation. move : h2 h3. clear. - case : c => //=; itauto. + case : c => //=; sfirstorder b:on. Qed. Lemma bind_inj p0 p1 (A0 A1 : PTm) B0 B1 : diff --git a/theories/logrel.v b/theories/logrel.v index a479f81..d4b4bd9 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -6,7 +6,7 @@ Require Import ssreflect ssrbool. Require Import Logic.PropExtensionality (propositional_extensionality). From stdpp Require Import relations (rtc(..), rtc_subrel). Import Psatz. -Require Import Cdcl.Itauto. + Definition ProdSpace (PA : PTm -> Prop) (PF : PTm -> (PTm -> Prop) -> Prop) b : Prop := @@ -355,7 +355,7 @@ Proof. 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 itauto. + 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. @@ -365,7 +365,7 @@ Proof. 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 itauto. + 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. @@ -375,7 +375,7 @@ Proof. 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 itauto. + 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 => //=. @@ -394,7 +394,7 @@ Proof. 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 itauto. + 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 => //=. @@ -413,7 +413,7 @@ Proof. 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 itauto. + 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 => //=. @@ -424,7 +424,7 @@ Proof. 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 itauto. + 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 => //=. @@ -1058,7 +1058,7 @@ Definition Γ_sub' Γ Δ := forall ρ, ρ_ok Δ ρ -> ρ_ok Γ ρ. Definition Γ_eq' Γ Δ := forall ρ, ρ_ok Δ ρ <-> ρ_ok Γ ρ. Lemma Γ_sub'_refl Γ : Γ_sub' Γ Γ. - rewrite /Γ_sub'. itauto. Qed. + rewrite /Γ_sub'. sfirstorder b:on. Qed. Lemma Γ_sub'_cons Γ Δ A B i j : Sub.R B A -> From 4b2bbeea6fe7c456c440e00672e8ccbdb161483b Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Wed, 16 Apr 2025 23:57:00 -0400 Subject: [PATCH 41/51] Add SE_FunExt --- theories/logrel.v | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/theories/logrel.v b/theories/logrel.v index d4b4bd9..d78d459 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -1516,6 +1516,20 @@ Proof. rewrite /DJoin.R. hauto lq:on ctrs:rtc,RERed.R. 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. From ef8feb63c3c9df872f769e86c676c3aa04fcdaca Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 17 Apr 2025 15:07:14 -0400 Subject: [PATCH 42/51] Redefine semantic context well-formedness as an inductive --- theories/logrel.v | 53 ++++++++++++++++++++++++++--------------------- 1 file changed, 29 insertions(+), 24 deletions(-) diff --git a/theories/logrel.v b/theories/logrel.v index d78d459..f85b32e 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -619,10 +619,6 @@ Proof. split; apply : InterpUniv_cumulative; eauto. Qed. -(* Semantic context wellformedness *) -Definition SemWff Γ := forall (i : nat) A, lookup i Γ A -> exists j, Γ ⊨ A ∈ PUniv j. -Notation "⊨ Γ" := (SemWff Γ) (at level 70). - Lemma ρ_ok_id Γ : ρ_ok Γ VarPTm. Proof. @@ -763,6 +759,34 @@ 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. @@ -784,25 +808,6 @@ Lemma SemLEq_SN_Sub Γ (a b : PTm) : SN a /\ SN b /\ Sub.R a b. Proof. hauto l:on use:SemLEq_SemWt, SemWt_SN. Qed. -(* Structural laws for Semantic context wellformedness *) -Lemma SemWff_nil : SemWff nil. -Proof. hfcrush inv:lookup. Qed. - -Lemma SemWff_cons Γ (A : PTm) i : - ⊨ Γ -> - Γ ⊨ A ∈ PUniv i -> - (* -------------- *) - ⊨ (cons A Γ). -Proof. - move => h h0. - move => j A0. elim/lookup_inv => //=_. - - hauto q:on use:weakening_Sem. - - move => i0 Γ0 A1 B + ? [*]. subst. - move : h => /[apply]. move => [k hk]. - exists k. change (PUniv k) with (ren_PTm shift (PUniv k)). - eauto using weakening_Sem. -Qed. - (* Semantic typing rules *) Lemma ST_Var' Γ (i : nat) A j : lookup i Γ A -> @@ -819,7 +824,7 @@ Lemma ST_Var Γ (i : nat) A : ⊨ Γ -> lookup i Γ A -> Γ ⊨ VarPTm i ∈ A. -Proof. hauto l:on use:ST_Var' unfold:SemWff. Qed. +Proof. hauto l:on use:ST_Var', SemWff_lookup. Qed. Lemma InterpUniv_Bind_nopf p i (A : PTm) B PA : ⟦ A ⟧ i ↘ PA -> From a367591e9a67e5cc33cfd6e4d85a9d932fa74f6a Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 17 Apr 2025 15:15:58 -0400 Subject: [PATCH 43/51] Add extensional version of pair equality rules --- theories/logrel.v | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/theories/logrel.v b/theories/logrel.v index f85b32e..fa50b9c 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -1521,6 +1521,22 @@ Proof. 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 -> From e1fc6b609dd69dd4ae69f6b1146eab095a923e69 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 17 Apr 2025 15:22:45 -0400 Subject: [PATCH 44/51] Add the extensional representation of pair&abs equality rules --- theories/logrel.v | 2 +- theories/typing.v | 36 +++++++++++------------------------- 2 files changed, 12 insertions(+), 26 deletions(-) diff --git a/theories/logrel.v b/theories/logrel.v index fa50b9c..e11659e 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -1701,4 +1701,4 @@ 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 : sem. + 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/typing.v b/theories/typing.v index ae78747..e911d51 100644 --- a/theories/typing.v +++ b/theories/typing.v @@ -89,23 +89,12 @@ with Eq : list PTm -> PTm -> PTm -> PTm -> Prop := (cons A0 Γ) ⊢ B0 ≡ B1 ∈ PUniv i -> Γ ⊢ PBind p A0 B0 ≡ PBind p A1 B1 ∈ PUniv i -| E_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 - | 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_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 - | E_Proj1 Γ (a b : PTm) A B : Γ ⊢ a ≡ b ∈ PBind PSig A B -> Γ ⊢ PProj PL a ≡ PProj PL b ∈ A @@ -164,16 +153,20 @@ with Eq : list PTm -> PTm -> PTm -> PTm -> Prop := (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 -(* Eta *) -| E_AppEta Γ (b : PTm) A B i : - Γ ⊢ PBind PPi A B ∈ (PUniv i) -> +| E_FunExt Γ (a b : PTm) A B i : + Γ ⊢ PBind PPi A B ∈ PUniv i -> + Γ ⊢ a ∈ PBind PPi A B -> Γ ⊢ b ∈ PBind PPi A B -> - Γ ⊢ PAbs (PApp (ren_PTm shift b) (VarPTm var_zero)) ≡ 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_PairEta Γ (a : PTm ) A B i : - Γ ⊢ PBind PSig A B ∈ (PUniv i) -> +| E_PairExt Γ (a b : 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 + Γ ⊢ 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 *) @@ -242,10 +235,3 @@ Scheme wf_ind := Induction for Wff Sort Prop with le_ind := Induction for LEq Sort Prop. Combined Scheme wt_mutual from wf_ind, wt_ind, eq_ind, le_ind. - -(* Lemma lem : *) -(* (forall n (Γ : fin n -> PTm n), ⊢ Γ -> ...) /\ *) -(* (forall n Γ (a A : PTm n), Γ ⊢ a ∈ A -> ...) /\ *) -(* (forall n Γ (a b A : PTm n), Γ ⊢ a ≡ b ∈ A -> ...) /\ *) -(* (forall n Γ (A B : PTm n), Γ ⊢ A ≲ B -> ...). *) -(* Proof. apply wt_mutual. ... *) From 7c985fa58e1080e94dcbd877b9bd64df22c7183e Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Thu, 17 Apr 2025 16:42:57 -0400 Subject: [PATCH 45/51] Minor --- theories/structural.v | 28 ++++++++++------------------ 1 file changed, 10 insertions(+), 18 deletions(-) diff --git a/theories/structural.v b/theories/structural.v index ccb4c6f..76f679b 100644 --- a/theories/structural.v +++ b/theories/structural.v @@ -137,12 +137,12 @@ Lemma E_ProjPair2' Γ (a b : PTm) A B i U : Γ ⊢ 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 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 -> @@ -222,17 +222,7 @@ Proof. - hauto lq:on ctrs:Wt,LEq. - hauto lq:on ctrs:Eq. - hauto lq:on rew:off use:E_Bind', Wff_Cons, renaming_up. - - move => Γ a b A B i hPi ihPi ha iha Δ ξ hΔ hξ. - move : ihPi (hΔ) (hξ). repeat move/[apply]. - move => /Bind_Inv [j][h0][h1]h2. - have ? : Δ ⊢ PBind PPi (ren_PTm ξ A) (ren_PTm (upRen_PTm_PTm ξ) B) ∈ PUniv j by qauto l:on ctrs:Wt. - move {hPi}. - apply : E_Abs; eauto. qauto l:on ctrs:Wff use:renaming_up. - move => *. apply : E_App'; eauto. by asimpl. - - move => Γ a0 a1 b0 b1 A B i hA ihA ha iha hb ihb Δ ξ hΔ hξ. - apply : E_Pair; eauto. - move : ihb hΔ hξ. repeat move/[apply]. - 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]. @@ -302,8 +292,10 @@ Proof. move /(_ Ξ (upRen_PTm_PTm (upRen_PTm_PTm ξ)) hΞ) : ihc. move /(_ ltac:(by eauto using renaming_up)). by asimpl. - - move => *. - apply : E_AppEta'; eauto. 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. + admit. + by apply renaming_up. - qauto l:on use:E_PairEta. - hauto lq:on ctrs:LEq. - qauto l:on ctrs:LEq. From 87b84794b470eecb4b056a8e1c0d4fb49834645c Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 18 Apr 2025 14:13:46 -0400 Subject: [PATCH 46/51] Fix structural rules --- theories/structural.v | 37 +++++++++++-------------------------- 1 file changed, 11 insertions(+), 26 deletions(-) diff --git a/theories/structural.v b/theories/structural.v index 76f679b..207447d 100644 --- a/theories/structural.v +++ b/theories/structural.v @@ -294,9 +294,10 @@ Proof. 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. - admit. + hfcrush use:Bind_Inv. by apply renaming_up. - - qauto l:on use:E_PairEta. + - 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. @@ -439,17 +440,7 @@ Proof. - hauto lq:on ctrs:Eq. - hauto lq:on ctrs:Eq. - hauto lq:on rew:off use:E_Bind', Wff_Cons, morphing_up. - - move => Γ a b A B i hPi ihPi ha iha Δ ρ hΔ hρ. - move : ihPi (hΔ) (hρ). repeat move/[apply]. - move => /Bind_Inv [j][h0][h1]h2. - have ? : Δ ⊢ PBind PPi (subst_PTm ρ A) (subst_PTm (up_PTm_PTm ρ) B) ∈ PUniv j by qauto l:on ctrs:Wt. - move {hPi}. - apply : E_Abs; eauto. qauto l:on ctrs:Wff use:morphing_up. - move => *. apply : E_App'; eauto. by asimpl. - - move => Γ a0 a1 b0 b1 A B i hA ihA ha iha hb ihb Δ ρ hΔ hρ. - apply : E_Pair; eauto. - move : ihb hΔ hρ. repeat move/[apply]. - 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. @@ -516,9 +507,14 @@ Proof. move /(_ Ξ (up_PTm_PTm (up_PTm_PTm ξ)) hΞ) : ihc. move /(_ ltac:(sauto l:on use:morphing_up)). asimpl. substify. by asimpl. - - move => *. - apply : E_AppEta'; eauto. by asimpl. - - qauto l:on use:E_PairEta. + - 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. @@ -659,7 +655,6 @@ Proof. sfirstorder. apply : ctx_eq_subst_one; eauto using Su_Eq, E_Symmetric. hauto lq:on. - - hauto lq:on ctrs:Wt,Eq. - move => n i b0 b1 a0 a1 A B hP _ hb [ihb0 [ihb1 [i0 ihb2]]] ha [iha0 [iha1 [i1 iha2]]]. repeat split. @@ -669,7 +664,6 @@ Proof. 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_inst db: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. @@ -718,15 +712,6 @@ Proof. subst Ξ. move : morphing_wt hc; repeat move/[apply]. asimpl. by apply. sauto lq:on use:substing_wt. - - move => Γ b A B i hP _ hb [i0 ihb]. - repeat split => //=; eauto with wt. - have {}hb : (cons A Γ) ⊢ ren_PTm shift b ∈ ren_PTm shift (PBind PPi A B) - by hauto lq:on use:weakening_wt, Bind_Inv. - apply : T_Abs; eauto. - apply : T_App'; eauto; rewrite-/ren_PTm. asimpl. by rewrite subst_scons_id. - apply T_Var. sfirstorder use:wff_mutual. - apply here. - - hauto lq:on ctrs:Wt. - move => Γ A B C hA [i [ihA0 ihA1]] hC [j [ihC0 ihC1]]. have ? : ⊢ Γ by sfirstorder use:wff_mutual. exists (max i j). From d9282fb815a8b2c18df40b573c5c2f969e908b07 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 18 Apr 2025 15:42:40 -0400 Subject: [PATCH 47/51] Finish preservation --- theories/preservation.v | 88 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 86 insertions(+), 2 deletions(-) diff --git a/theories/preservation.v b/theories/preservation.v index c8a2106..2794909 100644 --- a/theories/preservation.v +++ b/theories/preservation.v @@ -1,4 +1,4 @@ -Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common typing structural fp_red. +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. @@ -112,6 +112,45 @@ Proof. 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_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_ProjPair1 : forall (a b : PTm) Γ (A : PTm), Γ ⊢ PProj PL (PPair a b) ∈ A -> Γ ⊢ PProj PL (PPair a b) ≡ a ∈ A. Proof. @@ -125,6 +164,51 @@ Proof. 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_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. @@ -159,7 +243,7 @@ Proof. apply : Su_Sig_Proj2; eauto. move : hA0 => /[swap]. move : Su_Transitive. repeat move/[apply]. move {hS}. - move => ?. apply : E_Conv; eauto. apply : E_ProjPair2; eauto. + 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. From 43daff1b278f9bf21cdc89f9a69faca2b0e0b82c Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 18 Apr 2025 15:46:07 -0400 Subject: [PATCH 48/51] Fix soundness --- theories/soundness.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/soundness.v b/theories/soundness.v index 7f86852..877e3fb 100644 --- a/theories/soundness.v +++ b/theories/soundness.v @@ -7,7 +7,7 @@ Theorem fundamental_theorem : (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; [hauto l:on use:SE_Pair]. + apply wt_mutual; eauto with sem. Unshelve. all : exact 0. Qed. From 2b92845e3e00c4a3f1385c4f1c30cdd353b1e319 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Fri, 18 Apr 2025 16:38:34 -0400 Subject: [PATCH 49/51] Add E_AppEta --- theories/admissible.v | 112 ++++++++++++++++++++++++++++++++++++++++ theories/algorithmic.v | 3 +- theories/preservation.v | 60 --------------------- 3 files changed, 114 insertions(+), 61 deletions(-) diff --git a/theories/admissible.v b/theories/admissible.v index 830ceec..48c7cea 100644 --- a/theories/admissible.v +++ b/theories/admissible.v @@ -16,6 +16,70 @@ Proof. 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 -> @@ -46,3 +110,51 @@ Proof. 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_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. admit. + 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. +Admitted. diff --git a/theories/algorithmic.v b/theories/algorithmic.v index 184872d..cca7cfa 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -586,7 +586,8 @@ Proof. 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. hauto l:on use:regularity. + apply : E_Abs; eauto. + apply iha. move /Su_Pi_Proj2_Var in hp0. apply : T_Conv; eauto. diff --git a/theories/preservation.v b/theories/preservation.v index 2794909..2722ee7 100644 --- a/theories/preservation.v +++ b/theories/preservation.v @@ -4,32 +4,6 @@ Require Import ssreflect. Require Import Psatz. Require Import Coq.Logic.FunctionalExtensionality. -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 Proj1_Inv Γ (a : PTm ) U : Γ ⊢ PProj PL a ∈ U -> exists A B, Γ ⊢ a ∈ PBind PSig A B /\ Γ ⊢ A ≲ U. @@ -93,40 +67,6 @@ Proof. - 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_Abs Γ a b A B : A :: Γ ⊢ a ≡ b ∈ B -> Γ ⊢ PAbs a ≡ PAbs b ∈ PBind PPi A B. From 8e083aad4b83f8013a80b38f7fb6df69197241ac Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 19 Apr 2025 00:07:48 -0400 Subject: [PATCH 50/51] Add renaming_comp --- theories/admissible.v | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/theories/admissible.v b/theories/admissible.v index 48c7cea..e7f0769 100644 --- a/theories/admissible.v +++ b/theories/admissible.v @@ -120,6 +120,14 @@ Proof. hauto l:on use:regularity, E_FunExt. 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. @@ -151,10 +159,10 @@ Proof. 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. admit. + 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. -Admitted. +Qed. From 0e04a7076b069ab311fde2239ac8940eabcbdf60 Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 19 Apr 2025 00:24:09 -0400 Subject: [PATCH 51/51] Prove PairEta --- theories/admissible.v | 96 +++++++++++++++++++++++++++++++++++++++++ theories/algorithmic.v | 6 +-- theories/preservation.v | 73 ------------------------------- 3 files changed, 98 insertions(+), 77 deletions(-) diff --git a/theories/admissible.v b/theories/admissible.v index e7f0769..3e48d49 100644 --- a/theories/admissible.v +++ b/theories/admissible.v @@ -120,6 +120,13 @@ 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). @@ -166,3 +173,92 @@ Proof. 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 index cca7cfa..4e4e6fd 100644 --- a/theories/algorithmic.v +++ b/theories/algorithmic.v @@ -608,13 +608,12 @@ Proof. 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. - hauto l:on use:regularity. 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. hauto l:on use:regularity. + apply : E_Abs; eauto. apply iha. move /Su_Pi_Proj2_Var in hPi'. apply : T_Conv; eauto. @@ -666,7 +665,7 @@ Proof. 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_Symmetric; apply : E_PairEta). + apply : E_Transitive; last (apply : E_PairEta). apply : E_Pair; eauto. hauto l:on use:regularity. abstract : ih0'. apply ih0. apply : T_Conv; eauto. @@ -679,7 +678,6 @@ Proof. move /E_Symmetric in ih0'. move /regularity_sub0 in hA'. hauto l:on use:bind_inst. - hauto l:on use:regularity. eassumption. (* Same as before *) - move {hAppL}. diff --git a/theories/preservation.v b/theories/preservation.v index 2722ee7..301553e 100644 --- a/theories/preservation.v +++ b/theories/preservation.v @@ -4,51 +4,6 @@ Require Import ssreflect. Require Import Psatz. Require Import Coq.Logic.FunctionalExtensionality. -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 Ind_Inv Γ P (a : PTm) b c U : Γ ⊢ PInd P a b c ∈ U -> @@ -91,34 +46,6 @@ Proof. asimpl. rewrite !subst_scons_id. by apply E_Symmetric. 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_Pair Γ a0 b0 a1 b1 A B i : Γ ⊢ PBind PSig A B ∈ PUniv i -> Γ ⊢ a0 ≡ a1 ∈ A ->