Require Import core unscoped.

Require Import core_axioms unscoped_axioms.
Require Import Setoid Morphisms Relation_Definitions.

Module Core.

Inductive ty : Type :=
  | var_ty : nat -> ty
  | arr : ty -> ty -> ty
  | all : ty -> ty.

Lemma congr_arr {s0 : ty} {s1 : ty} {t0 : ty} {t1 : ty} (H0 : s0 = t0)
  (H1 : s1 = t1) : arr s0 s1 = arr t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => arr x s1) H0))
         (ap (fun x => arr t0 x) H1)).
Qed.

Lemma congr_all {s0 : ty} {t0 : ty} (H0 : s0 = t0) : all s0 = all t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => all x) H0)).
Qed.

Lemma upRen_ty_ty (xi : nat -> nat) : nat -> nat.
Proof.
exact (up_ren xi).
Defined.

Fixpoint ren_ty (xi_ty : nat -> nat) (s : ty) {struct s} : ty :=
  match s with
  | var_ty s0 => var_ty (xi_ty s0)
  | arr s0 s1 => arr (ren_ty xi_ty s0) (ren_ty xi_ty s1)
  | all s0 => all (ren_ty (upRen_ty_ty xi_ty) s0)
  end.

Lemma up_ty_ty (sigma : nat -> ty) : nat -> ty.
Proof.
exact (scons (var_ty var_zero) (funcomp (ren_ty shift) sigma)).
Defined.

Fixpoint subst_ty (sigma_ty : nat -> ty) (s : ty) {struct s} : ty :=
  match s with
  | var_ty s0 => sigma_ty s0
  | arr s0 s1 => arr (subst_ty sigma_ty s0) (subst_ty sigma_ty s1)
  | all s0 => all (subst_ty (up_ty_ty sigma_ty) s0)
  end.

Lemma upId_ty_ty (sigma : nat -> ty) (Eq : forall x, sigma x = var_ty x) :
  forall x, up_ty_ty sigma x = var_ty x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint idSubst_ty (sigma_ty : nat -> ty)
(Eq_ty : forall x, sigma_ty x = var_ty x) (s : ty) {struct s} :
subst_ty sigma_ty s = s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (idSubst_ty sigma_ty Eq_ty s0) (idSubst_ty sigma_ty Eq_ty s1)
  | all s0 =>
      congr_all (idSubst_ty (up_ty_ty sigma_ty) (upId_ty_ty _ Eq_ty) s0)
  end.

Lemma upExtRen_ty_ty (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_ty_ty xi x = upRen_ty_ty zeta x.
Proof.
exact (fun n => match n with
                | S n' => ap shift (Eq n')
                | O => eq_refl
                end).
Qed.

Fixpoint extRen_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat)
(Eq_ty : forall x, xi_ty x = zeta_ty x) (s : ty) {struct s} :
ren_ty xi_ty s = ren_ty zeta_ty s :=
  match s with
  | var_ty s0 => ap (var_ty) (Eq_ty s0)
  | arr s0 s1 =>
      congr_arr (extRen_ty xi_ty zeta_ty Eq_ty s0)
        (extRen_ty xi_ty zeta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (extRen_ty (upRen_ty_ty xi_ty) (upRen_ty_ty zeta_ty)
           (upExtRen_ty_ty _ _ Eq_ty) s0)
  end.

Lemma upExt_ty_ty (sigma : nat -> ty) (tau : nat -> ty)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_ty_ty sigma x = up_ty_ty tau x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint ext_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty)
(Eq_ty : forall x, sigma_ty x = tau_ty x) (s : ty) {struct s} :
subst_ty sigma_ty s = subst_ty tau_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (ext_ty sigma_ty tau_ty Eq_ty s0)
        (ext_ty sigma_ty tau_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (ext_ty (up_ty_ty sigma_ty) (up_ty_ty tau_ty) (upExt_ty_ty _ _ Eq_ty)
           s0)
  end.

Lemma up_ren_ren_ty_ty (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_ty_ty zeta) (upRen_ty_ty xi) x = upRen_ty_ty rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Fixpoint compRenRen_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat)
(rho_ty : nat -> nat) (Eq_ty : forall x, funcomp zeta_ty xi_ty x = rho_ty x)
(s : ty) {struct s} : ren_ty zeta_ty (ren_ty xi_ty s) = ren_ty rho_ty s :=
  match s with
  | var_ty s0 => ap (var_ty) (Eq_ty s0)
  | arr s0 s1 =>
      congr_arr (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s0)
        (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compRenRen_ty (upRen_ty_ty xi_ty) (upRen_ty_ty zeta_ty)
           (upRen_ty_ty rho_ty) (up_ren_ren _ _ _ Eq_ty) s0)
  end.

Lemma up_ren_subst_ty_ty (xi : nat -> nat) (tau : nat -> ty)
  (theta : nat -> ty) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_ty_ty tau) (upRen_ty_ty xi) x = up_ty_ty theta x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint compRenSubst_ty (xi_ty : nat -> nat) (tau_ty : nat -> ty)
(theta_ty : nat -> ty)
(Eq_ty : forall x, funcomp tau_ty xi_ty x = theta_ty x) (s : ty) {struct s} :
subst_ty tau_ty (ren_ty xi_ty s) = subst_ty theta_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s0)
        (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compRenSubst_ty (upRen_ty_ty xi_ty) (up_ty_ty tau_ty)
           (up_ty_ty theta_ty) (up_ren_subst_ty_ty _ _ _ Eq_ty) s0)
  end.

Lemma up_subst_ren_ty_ty (sigma : nat -> ty) (zeta_ty : nat -> nat)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (ren_ty zeta_ty) sigma x = theta x) :
  forall x,
  funcomp (ren_ty (upRen_ty_ty zeta_ty)) (up_ty_ty sigma) x =
  up_ty_ty theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenRen_ty shift (upRen_ty_ty zeta_ty)
                (funcomp shift zeta_ty) (fun x => eq_refl) (sigma n'))
             (eq_trans
                (eq_sym
                   (compRenRen_ty zeta_ty shift (funcomp shift zeta_ty)
                      (fun x => eq_refl) (sigma n')))
                (ap (ren_ty shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstRen_ty (sigma_ty : nat -> ty) (zeta_ty : nat -> nat)
(theta_ty : nat -> ty)
(Eq_ty : forall x, funcomp (ren_ty zeta_ty) sigma_ty x = theta_ty x)
(s : ty) {struct s} :
ren_ty zeta_ty (subst_ty sigma_ty s) = subst_ty theta_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s0)
        (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compSubstRen_ty (up_ty_ty sigma_ty) (upRen_ty_ty zeta_ty)
           (up_ty_ty theta_ty) (up_subst_ren_ty_ty _ _ _ Eq_ty) s0)
  end.

Lemma up_subst_subst_ty_ty (sigma : nat -> ty) (tau_ty : nat -> ty)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (subst_ty tau_ty) sigma x = theta x) :
  forall x,
  funcomp (subst_ty (up_ty_ty tau_ty)) (up_ty_ty sigma) x = up_ty_ty theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenSubst_ty shift (up_ty_ty tau_ty)
                (funcomp (up_ty_ty tau_ty) shift) (fun x => eq_refl)
                (sigma n'))
             (eq_trans
                (eq_sym
                   (compSubstRen_ty tau_ty shift
                      (funcomp (ren_ty shift) tau_ty) (fun x => eq_refl)
                      (sigma n'))) (ap (ren_ty shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstSubst_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty)
(theta_ty : nat -> ty)
(Eq_ty : forall x, funcomp (subst_ty tau_ty) sigma_ty x = theta_ty x)
(s : ty) {struct s} :
subst_ty tau_ty (subst_ty sigma_ty s) = subst_ty theta_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s0)
        (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compSubstSubst_ty (up_ty_ty sigma_ty) (up_ty_ty tau_ty)
           (up_ty_ty theta_ty) (up_subst_subst_ty_ty _ _ _ Eq_ty) s0)
  end.

Lemma renRen_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat) (s : ty) :
  ren_ty zeta_ty (ren_ty xi_ty s) = ren_ty (funcomp zeta_ty xi_ty) s.
Proof.
exact (compRenRen_ty xi_ty zeta_ty _ (fun n => eq_refl) s).
Qed.

Lemma renRen'_ty_pointwise (xi_ty : nat -> nat) (zeta_ty : nat -> nat) :
  pointwise_relation _ eq (funcomp (ren_ty zeta_ty) (ren_ty xi_ty))
    (ren_ty (funcomp zeta_ty xi_ty)).
Proof.
exact (fun s => compRenRen_ty xi_ty zeta_ty _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_ty (xi_ty : nat -> nat) (tau_ty : nat -> ty) (s : ty) :
  subst_ty tau_ty (ren_ty xi_ty s) = subst_ty (funcomp tau_ty xi_ty) s.
Proof.
exact (compRenSubst_ty xi_ty tau_ty _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_ty_pointwise (xi_ty : nat -> nat) (tau_ty : nat -> ty) :
  pointwise_relation _ eq (funcomp (subst_ty tau_ty) (ren_ty xi_ty))
    (subst_ty (funcomp tau_ty xi_ty)).
Proof.
exact (fun s => compRenSubst_ty xi_ty tau_ty _ (fun n => eq_refl) s).
Qed.

Lemma substRen_ty (sigma_ty : nat -> ty) (zeta_ty : nat -> nat) (s : ty) :
  ren_ty zeta_ty (subst_ty sigma_ty s) =
  subst_ty (funcomp (ren_ty zeta_ty) sigma_ty) s.
Proof.
exact (compSubstRen_ty sigma_ty zeta_ty _ (fun n => eq_refl) s).
Qed.

Lemma substRen_ty_pointwise (sigma_ty : nat -> ty) (zeta_ty : nat -> nat) :
  pointwise_relation _ eq (funcomp (ren_ty zeta_ty) (subst_ty sigma_ty))
    (subst_ty (funcomp (ren_ty zeta_ty) sigma_ty)).
Proof.
exact (fun s => compSubstRen_ty sigma_ty zeta_ty _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty) (s : ty) :
  subst_ty tau_ty (subst_ty sigma_ty s) =
  subst_ty (funcomp (subst_ty tau_ty) sigma_ty) s.
Proof.
exact (compSubstSubst_ty sigma_ty tau_ty _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_ty_pointwise (sigma_ty : nat -> ty) (tau_ty : nat -> ty) :
  pointwise_relation _ eq (funcomp (subst_ty tau_ty) (subst_ty sigma_ty))
    (subst_ty (funcomp (subst_ty tau_ty) sigma_ty)).
Proof.
exact (fun s => compSubstSubst_ty sigma_ty tau_ty _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst_up_ty_ty (xi : nat -> nat) (sigma : nat -> ty)
  (Eq : forall x, funcomp (var_ty) xi x = sigma x) :
  forall x, funcomp (var_ty) (upRen_ty_ty xi) x = up_ty_ty sigma x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint rinst_inst_ty (xi_ty : nat -> nat) (sigma_ty : nat -> ty)
(Eq_ty : forall x, funcomp (var_ty) xi_ty x = sigma_ty x) (s : ty) {struct s}
   : ren_ty xi_ty s = subst_ty sigma_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (rinst_inst_ty xi_ty sigma_ty Eq_ty s0)
        (rinst_inst_ty xi_ty sigma_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (rinst_inst_ty (upRen_ty_ty xi_ty) (up_ty_ty sigma_ty)
           (rinstInst_up_ty_ty _ _ Eq_ty) s0)
  end.

Lemma rinstInst'_ty (xi_ty : nat -> nat) (s : ty) :
  ren_ty xi_ty s = subst_ty (funcomp (var_ty) xi_ty) s.
Proof.
exact (rinst_inst_ty xi_ty _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_ty_pointwise (xi_ty : nat -> nat) :
  pointwise_relation _ eq (ren_ty xi_ty) (subst_ty (funcomp (var_ty) xi_ty)).
Proof.
exact (fun s => rinst_inst_ty xi_ty _ (fun n => eq_refl) s).
Qed.

Lemma instId'_ty (s : ty) : subst_ty (var_ty) s = s.
Proof.
exact (idSubst_ty (var_ty) (fun n => eq_refl) s).
Qed.

Lemma instId'_ty_pointwise : pointwise_relation _ eq (subst_ty (var_ty)) id.
Proof.
exact (fun s => idSubst_ty (var_ty) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_ty (s : ty) : ren_ty id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_ty s) (rinstInst'_ty id s)).
Qed.

Lemma rinstId'_ty_pointwise : pointwise_relation _ eq (@ren_ty id) id.
Proof.
exact (fun s => eq_ind_r (fun t => t = s) (instId'_ty s) (rinstInst'_ty id s)).
Qed.

Lemma varL'_ty (sigma_ty : nat -> ty) (x : nat) :
  subst_ty sigma_ty (var_ty x) = sigma_ty x.
Proof.
exact (eq_refl).
Qed.

Lemma varL'_ty_pointwise (sigma_ty : nat -> ty) :
  pointwise_relation _ eq (funcomp (subst_ty sigma_ty) (var_ty)) sigma_ty.
Proof.
exact (fun x => eq_refl).
Qed.

Lemma varLRen'_ty (xi_ty : nat -> nat) (x : nat) :
  ren_ty xi_ty (var_ty x) = var_ty (xi_ty x).
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_ty_pointwise (xi_ty : nat -> nat) :
  pointwise_relation _ eq (funcomp (ren_ty xi_ty) (var_ty))
    (funcomp (var_ty) xi_ty).
Proof.
exact (fun x => eq_refl).
Qed.

Inductive tm : Type :=
  | var_tm : nat -> tm
  | app : tm -> tm -> tm
  | tapp : tm -> ty -> tm
  | lam : ty -> tm -> tm
  | tlam : tm -> tm.

Lemma congr_app {s0 : tm} {s1 : tm} {t0 : tm} {t1 : tm} (H0 : s0 = t0)
  (H1 : s1 = t1) : app s0 s1 = app t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app x s1) H0))
         (ap (fun x => app t0 x) H1)).
Qed.

Lemma congr_tapp {s0 : tm} {s1 : ty} {t0 : tm} {t1 : ty} (H0 : s0 = t0)
  (H1 : s1 = t1) : tapp s0 s1 = tapp t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => tapp x s1) H0))
         (ap (fun x => tapp t0 x) H1)).
Qed.

Lemma congr_lam {s0 : ty} {s1 : tm} {t0 : ty} {t1 : tm} (H0 : s0 = t0)
  (H1 : s1 = t1) : lam s0 s1 = lam t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => lam x s1) H0))
         (ap (fun x => lam t0 x) H1)).
Qed.

Lemma congr_tlam {s0 : tm} {t0 : tm} (H0 : s0 = t0) : tlam s0 = tlam t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => tlam x) H0)).
Qed.

Lemma upRen_ty_tm (xi : nat -> nat) : nat -> nat.
Proof.
exact (xi).
Defined.

Lemma upRen_tm_ty (xi : nat -> nat) : nat -> nat.
Proof.
exact (xi).
Defined.

Lemma upRen_tm_tm (xi : nat -> nat) : nat -> nat.
Proof.
exact (up_ren xi).
Defined.

Fixpoint ren_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat) (s : tm) {struct s}
   : tm :=
  match s with
  | var_tm s0 => var_tm (xi_tm s0)
  | app s0 s1 => app (ren_tm xi_ty xi_tm s0) (ren_tm xi_ty xi_tm s1)
  | tapp s0 s1 => tapp (ren_tm xi_ty xi_tm s0) (ren_ty xi_ty s1)
  | lam s0 s1 =>
      lam (ren_ty xi_ty s0)
        (ren_tm (upRen_tm_ty xi_ty) (upRen_tm_tm xi_tm) s1)
  | tlam s0 => tlam (ren_tm (upRen_ty_ty xi_ty) (upRen_ty_tm xi_tm) s0)
  end.

Lemma up_ty_tm (sigma : nat -> tm) : nat -> tm.
Proof.
exact (funcomp (ren_tm shift id) sigma).
Defined.

Lemma up_tm_ty (sigma : nat -> ty) : nat -> ty.
Proof.
exact (funcomp (ren_ty id) sigma).
Defined.

Lemma up_tm_tm (sigma : nat -> tm) : nat -> tm.
Proof.
exact (scons (var_tm var_zero) (funcomp (ren_tm id shift) sigma)).
Defined.

Fixpoint subst_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm) (s : tm)
{struct s} : tm :=
  match s with
  | var_tm s0 => sigma_tm s0
  | app s0 s1 =>
      app (subst_tm sigma_ty sigma_tm s0) (subst_tm sigma_ty sigma_tm s1)
  | tapp s0 s1 => tapp (subst_tm sigma_ty sigma_tm s0) (subst_ty sigma_ty s1)
  | lam s0 s1 =>
      lam (subst_ty sigma_ty s0)
        (subst_tm (up_tm_ty sigma_ty) (up_tm_tm sigma_tm) s1)
  | tlam s0 => tlam (subst_tm (up_ty_ty sigma_ty) (up_ty_tm sigma_tm) s0)
  end.

Lemma upId_ty_tm (sigma : nat -> tm) (Eq : forall x, sigma x = var_tm x) :
  forall x, up_ty_tm sigma x = var_tm x.
Proof.
exact (fun n => ap (ren_tm shift id) (Eq n)).
Qed.

Lemma upId_tm_ty (sigma : nat -> ty) (Eq : forall x, sigma x = var_ty x) :
  forall x, up_tm_ty sigma x = var_ty x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma upId_tm_tm (sigma : nat -> tm) (Eq : forall x, sigma x = var_tm x) :
  forall x, up_tm_tm sigma x = var_tm x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_tm id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint idSubst_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
(Eq_ty : forall x, sigma_ty x = var_ty x)
(Eq_tm : forall x, sigma_tm x = var_tm x) (s : tm) {struct s} :
subst_tm sigma_ty sigma_tm s = s :=
  match s with
  | var_tm s0 => Eq_tm s0
  | app s0 s1 =>
      congr_app (idSubst_tm sigma_ty sigma_tm Eq_ty Eq_tm s0)
        (idSubst_tm sigma_ty sigma_tm Eq_ty Eq_tm s1)
  | tapp s0 s1 =>
      congr_tapp (idSubst_tm sigma_ty sigma_tm Eq_ty Eq_tm s0)
        (idSubst_ty sigma_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (idSubst_ty sigma_ty Eq_ty s0)
        (idSubst_tm (up_tm_ty sigma_ty) (up_tm_tm sigma_tm)
           (upId_tm_ty _ Eq_ty) (upId_tm_tm _ Eq_tm) s1)
  | tlam s0 =>
      congr_tlam
        (idSubst_tm (up_ty_ty sigma_ty) (up_ty_tm sigma_tm)
           (upId_ty_ty _ Eq_ty) (upId_ty_tm _ Eq_tm) s0)
  end.

Lemma upExtRen_ty_tm (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_ty_tm xi x = upRen_ty_tm zeta x.
Proof.
exact (fun n => Eq n).
Qed.

Lemma upExtRen_tm_ty (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_tm_ty xi x = upRen_tm_ty zeta x.
Proof.
exact (fun n => Eq n).
Qed.

Lemma upExtRen_tm_tm (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_tm_tm xi x = upRen_tm_tm zeta x.
Proof.
exact (fun n => match n with
                | S n' => ap shift (Eq n')
                | O => eq_refl
                end).
Qed.

Fixpoint extRen_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
(zeta_ty : nat -> nat) (zeta_tm : nat -> nat)
(Eq_ty : forall x, xi_ty x = zeta_ty x)
(Eq_tm : forall x, xi_tm x = zeta_tm x) (s : tm) {struct s} :
ren_tm xi_ty xi_tm s = ren_tm zeta_ty zeta_tm s :=
  match s with
  | var_tm s0 => ap (var_tm) (Eq_tm s0)
  | app s0 s1 =>
      congr_app (extRen_tm xi_ty xi_tm zeta_ty zeta_tm Eq_ty Eq_tm s0)
        (extRen_tm xi_ty xi_tm zeta_ty zeta_tm Eq_ty Eq_tm s1)
  | tapp s0 s1 =>
      congr_tapp (extRen_tm xi_ty xi_tm zeta_ty zeta_tm Eq_ty Eq_tm s0)
        (extRen_ty xi_ty zeta_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (extRen_ty xi_ty zeta_ty Eq_ty s0)
        (extRen_tm (upRen_tm_ty xi_ty) (upRen_tm_tm xi_tm)
           (upRen_tm_ty zeta_ty) (upRen_tm_tm zeta_tm)
           (upExtRen_tm_ty _ _ Eq_ty) (upExtRen_tm_tm _ _ Eq_tm) s1)
  | tlam s0 =>
      congr_tlam
        (extRen_tm (upRen_ty_ty xi_ty) (upRen_ty_tm xi_tm)
           (upRen_ty_ty zeta_ty) (upRen_ty_tm zeta_tm)
           (upExtRen_ty_ty _ _ Eq_ty) (upExtRen_ty_tm _ _ Eq_tm) s0)
  end.

Lemma upExt_ty_tm (sigma : nat -> tm) (tau : nat -> tm)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_ty_tm sigma x = up_ty_tm tau x.
Proof.
exact (fun n => ap (ren_tm shift id) (Eq n)).
Qed.

Lemma upExt_tm_ty (sigma : nat -> ty) (tau : nat -> ty)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_tm_ty sigma x = up_tm_ty tau x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma upExt_tm_tm (sigma : nat -> tm) (tau : nat -> tm)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_tm_tm sigma x = up_tm_tm tau x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_tm id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint ext_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
(tau_ty : nat -> ty) (tau_tm : nat -> tm)
(Eq_ty : forall x, sigma_ty x = tau_ty x)
(Eq_tm : forall x, sigma_tm x = tau_tm x) (s : tm) {struct s} :
subst_tm sigma_ty sigma_tm s = subst_tm tau_ty tau_tm s :=
  match s with
  | var_tm s0 => Eq_tm s0
  | app s0 s1 =>
      congr_app (ext_tm sigma_ty sigma_tm tau_ty tau_tm Eq_ty Eq_tm s0)
        (ext_tm sigma_ty sigma_tm tau_ty tau_tm Eq_ty Eq_tm s1)
  | tapp s0 s1 =>
      congr_tapp (ext_tm sigma_ty sigma_tm tau_ty tau_tm Eq_ty Eq_tm s0)
        (ext_ty sigma_ty tau_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (ext_ty sigma_ty tau_ty Eq_ty s0)
        (ext_tm (up_tm_ty sigma_ty) (up_tm_tm sigma_tm) (up_tm_ty tau_ty)
           (up_tm_tm tau_tm) (upExt_tm_ty _ _ Eq_ty) (upExt_tm_tm _ _ Eq_tm)
           s1)
  | tlam s0 =>
      congr_tlam
        (ext_tm (up_ty_ty sigma_ty) (up_ty_tm sigma_tm) (up_ty_ty tau_ty)
           (up_ty_tm tau_tm) (upExt_ty_ty _ _ Eq_ty) (upExt_ty_tm _ _ Eq_tm)
           s0)
  end.

Lemma up_ren_ren_ty_tm (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_ty_tm zeta) (upRen_ty_tm xi) x = upRen_ty_tm rho x.
Proof.
exact (Eq).
Qed.

Lemma up_ren_ren_tm_ty (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_tm_ty zeta) (upRen_tm_ty xi) x = upRen_tm_ty rho x.
Proof.
exact (Eq).
Qed.

Lemma up_ren_ren_tm_tm (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_tm_tm zeta) (upRen_tm_tm xi) x = upRen_tm_tm rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Fixpoint compRenRen_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
(zeta_ty : nat -> nat) (zeta_tm : nat -> nat) (rho_ty : nat -> nat)
(rho_tm : nat -> nat) (Eq_ty : forall x, funcomp zeta_ty xi_ty x = rho_ty x)
(Eq_tm : forall x, funcomp zeta_tm xi_tm x = rho_tm x) (s : tm) {struct s} :
ren_tm zeta_ty zeta_tm (ren_tm xi_ty xi_tm s) = ren_tm rho_ty rho_tm s :=
  match s with
  | var_tm s0 => ap (var_tm) (Eq_tm s0)
  | app s0 s1 =>
      congr_app
        (compRenRen_tm xi_ty xi_tm zeta_ty zeta_tm rho_ty rho_tm Eq_ty Eq_tm
           s0)
        (compRenRen_tm xi_ty xi_tm zeta_ty zeta_tm rho_ty rho_tm Eq_ty Eq_tm
           s1)
  | tapp s0 s1 =>
      congr_tapp
        (compRenRen_tm xi_ty xi_tm zeta_ty zeta_tm rho_ty rho_tm Eq_ty Eq_tm
           s0) (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s0)
        (compRenRen_tm (upRen_tm_ty xi_ty) (upRen_tm_tm xi_tm)
           (upRen_tm_ty zeta_ty) (upRen_tm_tm zeta_tm) (upRen_tm_ty rho_ty)
           (upRen_tm_tm rho_tm) Eq_ty (up_ren_ren _ _ _ Eq_tm) s1)
  | tlam s0 =>
      congr_tlam
        (compRenRen_tm (upRen_ty_ty xi_ty) (upRen_ty_tm xi_tm)
           (upRen_ty_ty zeta_ty) (upRen_ty_tm zeta_tm) (upRen_ty_ty rho_ty)
           (upRen_ty_tm rho_tm) (up_ren_ren _ _ _ Eq_ty) Eq_tm s0)
  end.

Lemma up_ren_subst_ty_tm (xi : nat -> nat) (tau : nat -> tm)
  (theta : nat -> tm) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_ty_tm tau) (upRen_ty_tm xi) x = up_ty_tm theta x.
Proof.
exact (fun n => ap (ren_tm shift id) (Eq n)).
Qed.

Lemma up_ren_subst_tm_ty (xi : nat -> nat) (tau : nat -> ty)
  (theta : nat -> ty) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_tm_ty tau) (upRen_tm_ty xi) x = up_tm_ty theta x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma up_ren_subst_tm_tm (xi : nat -> nat) (tau : nat -> tm)
  (theta : nat -> tm) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_tm_tm tau) (upRen_tm_tm xi) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_tm id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint compRenSubst_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
(tau_ty : nat -> ty) (tau_tm : nat -> tm) (theta_ty : nat -> ty)
(theta_tm : nat -> tm)
(Eq_ty : forall x, funcomp tau_ty xi_ty x = theta_ty x)
(Eq_tm : forall x, funcomp tau_tm xi_tm x = theta_tm x) (s : tm) {struct s} :
subst_tm tau_ty tau_tm (ren_tm xi_ty xi_tm s) = subst_tm theta_ty theta_tm s
:=
  match s with
  | var_tm s0 => Eq_tm s0
  | app s0 s1 =>
      congr_app
        (compRenSubst_tm xi_ty xi_tm tau_ty tau_tm theta_ty theta_tm Eq_ty
           Eq_tm s0)
        (compRenSubst_tm xi_ty xi_tm tau_ty tau_tm theta_ty theta_tm Eq_ty
           Eq_tm s1)
  | tapp s0 s1 =>
      congr_tapp
        (compRenSubst_tm xi_ty xi_tm tau_ty tau_tm theta_ty theta_tm Eq_ty
           Eq_tm s0) (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s0)
        (compRenSubst_tm (upRen_tm_ty xi_ty) (upRen_tm_tm xi_tm)
           (up_tm_ty tau_ty) (up_tm_tm tau_tm) (up_tm_ty theta_ty)
           (up_tm_tm theta_tm) (up_ren_subst_tm_ty _ _ _ Eq_ty)
           (up_ren_subst_tm_tm _ _ _ Eq_tm) s1)
  | tlam s0 =>
      congr_tlam
        (compRenSubst_tm (upRen_ty_ty xi_ty) (upRen_ty_tm xi_tm)
           (up_ty_ty tau_ty) (up_ty_tm tau_tm) (up_ty_ty theta_ty)
           (up_ty_tm theta_tm) (up_ren_subst_ty_ty _ _ _ Eq_ty)
           (up_ren_subst_ty_tm _ _ _ Eq_tm) s0)
  end.

Lemma up_subst_ren_ty_tm (sigma : nat -> tm) (zeta_ty : nat -> nat)
  (zeta_tm : nat -> nat) (theta : nat -> tm)
  (Eq : forall x, funcomp (ren_tm zeta_ty zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_ty_ty zeta_ty) (upRen_ty_tm zeta_tm))
    (up_ty_tm sigma) x = up_ty_tm theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenRen_tm shift id (upRen_ty_ty zeta_ty) (upRen_ty_tm zeta_tm)
            (funcomp shift zeta_ty) (funcomp id zeta_tm) (fun x => eq_refl)
            (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compRenRen_tm zeta_ty zeta_tm shift id
                  (funcomp shift zeta_ty) (funcomp id zeta_tm)
                  (fun x => eq_refl) (fun x => eq_refl) (sigma n)))
            (ap (ren_tm shift id) (Eq n)))).
Qed.

Lemma up_subst_ren_tm_ty (sigma : nat -> ty) (zeta_ty : nat -> nat)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (ren_ty zeta_ty) sigma x = theta x) :
  forall x,
  funcomp (ren_ty (upRen_tm_ty zeta_ty)) (up_tm_ty sigma) x =
  up_tm_ty theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenRen_ty id (upRen_tm_ty zeta_ty) (funcomp id zeta_ty)
            (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compRenRen_ty zeta_ty id (funcomp id zeta_ty)
                  (fun x => eq_refl) (sigma n))) (ap (ren_ty id) (Eq n)))).
Qed.

Lemma up_subst_ren_tm_tm (sigma : nat -> tm) (zeta_ty : nat -> nat)
  (zeta_tm : nat -> nat) (theta : nat -> tm)
  (Eq : forall x, funcomp (ren_tm zeta_ty zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_tm_ty zeta_ty) (upRen_tm_tm zeta_tm))
    (up_tm_tm sigma) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenRen_tm id shift (upRen_tm_ty zeta_ty)
                (upRen_tm_tm zeta_tm) (funcomp id zeta_ty)
                (funcomp shift zeta_tm) (fun x => eq_refl) (fun x => eq_refl)
                (sigma n'))
             (eq_trans
                (eq_sym
                   (compRenRen_tm zeta_ty zeta_tm id shift
                      (funcomp id zeta_ty) (funcomp shift zeta_tm)
                      (fun x => eq_refl) (fun x => eq_refl) (sigma n')))
                (ap (ren_tm id shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstRen_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
(zeta_ty : nat -> nat) (zeta_tm : nat -> nat) (theta_ty : nat -> ty)
(theta_tm : nat -> tm)
(Eq_ty : forall x, funcomp (ren_ty zeta_ty) sigma_ty x = theta_ty x)
(Eq_tm : forall x, funcomp (ren_tm zeta_ty zeta_tm) sigma_tm x = theta_tm x)
(s : tm) {struct s} :
ren_tm zeta_ty zeta_tm (subst_tm sigma_ty sigma_tm s) =
subst_tm theta_ty theta_tm s :=
  match s with
  | var_tm s0 => Eq_tm s0
  | app s0 s1 =>
      congr_app
        (compSubstRen_tm sigma_ty sigma_tm zeta_ty zeta_tm theta_ty theta_tm
           Eq_ty Eq_tm s0)
        (compSubstRen_tm sigma_ty sigma_tm zeta_ty zeta_tm theta_ty theta_tm
           Eq_ty Eq_tm s1)
  | tapp s0 s1 =>
      congr_tapp
        (compSubstRen_tm sigma_ty sigma_tm zeta_ty zeta_tm theta_ty theta_tm
           Eq_ty Eq_tm s0)
        (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s0)
        (compSubstRen_tm (up_tm_ty sigma_ty) (up_tm_tm sigma_tm)
           (upRen_tm_ty zeta_ty) (upRen_tm_tm zeta_tm) (up_tm_ty theta_ty)
           (up_tm_tm theta_tm) (up_subst_ren_tm_ty _ _ _ Eq_ty)
           (up_subst_ren_tm_tm _ _ _ _ Eq_tm) s1)
  | tlam s0 =>
      congr_tlam
        (compSubstRen_tm (up_ty_ty sigma_ty) (up_ty_tm sigma_tm)
           (upRen_ty_ty zeta_ty) (upRen_ty_tm zeta_tm) (up_ty_ty theta_ty)
           (up_ty_tm theta_tm) (up_subst_ren_ty_ty _ _ _ Eq_ty)
           (up_subst_ren_ty_tm _ _ _ _ Eq_tm) s0)
  end.

Lemma up_subst_subst_ty_tm (sigma : nat -> tm) (tau_ty : nat -> ty)
  (tau_tm : nat -> tm) (theta : nat -> tm)
  (Eq : forall x, funcomp (subst_tm tau_ty tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_ty_ty tau_ty) (up_ty_tm tau_tm)) (up_ty_tm sigma) x =
  up_ty_tm theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenSubst_tm shift id (up_ty_ty tau_ty) (up_ty_tm tau_tm)
            (funcomp (up_ty_ty tau_ty) shift) (funcomp (up_ty_tm tau_tm) id)
            (fun x => eq_refl) (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compSubstRen_tm tau_ty tau_tm shift id
                  (funcomp (ren_ty shift) tau_ty)
                  (funcomp (ren_tm shift id) tau_tm) (fun x => eq_refl)
                  (fun x => eq_refl) (sigma n)))
            (ap (ren_tm shift id) (Eq n)))).
Qed.

Lemma up_subst_subst_tm_ty (sigma : nat -> ty) (tau_ty : nat -> ty)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (subst_ty tau_ty) sigma x = theta x) :
  forall x,
  funcomp (subst_ty (up_tm_ty tau_ty)) (up_tm_ty sigma) x = up_tm_ty theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenSubst_ty id (up_tm_ty tau_ty) (funcomp (up_tm_ty tau_ty) id)
            (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compSubstRen_ty tau_ty id (funcomp (ren_ty id) tau_ty)
                  (fun x => eq_refl) (sigma n))) (ap (ren_ty id) (Eq n)))).
Qed.

Lemma up_subst_subst_tm_tm (sigma : nat -> tm) (tau_ty : nat -> ty)
  (tau_tm : nat -> tm) (theta : nat -> tm)
  (Eq : forall x, funcomp (subst_tm tau_ty tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_tm_ty tau_ty) (up_tm_tm tau_tm)) (up_tm_tm sigma) x =
  up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenSubst_tm id shift (up_tm_ty tau_ty) (up_tm_tm tau_tm)
                (funcomp (up_tm_ty tau_ty) id)
                (funcomp (up_tm_tm tau_tm) shift) (fun x => eq_refl)
                (fun x => eq_refl) (sigma n'))
             (eq_trans
                (eq_sym
                   (compSubstRen_tm tau_ty tau_tm id shift
                      (funcomp (ren_ty id) tau_ty)
                      (funcomp (ren_tm id shift) tau_tm) (fun x => eq_refl)
                      (fun x => eq_refl) (sigma n')))
                (ap (ren_tm id shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstSubst_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
(tau_ty : nat -> ty) (tau_tm : nat -> tm) (theta_ty : nat -> ty)
(theta_tm : nat -> tm)
(Eq_ty : forall x, funcomp (subst_ty tau_ty) sigma_ty x = theta_ty x)
(Eq_tm : forall x, funcomp (subst_tm tau_ty tau_tm) sigma_tm x = theta_tm x)
(s : tm) {struct s} :
subst_tm tau_ty tau_tm (subst_tm sigma_ty sigma_tm s) =
subst_tm theta_ty theta_tm s :=
  match s with
  | var_tm s0 => Eq_tm s0
  | app s0 s1 =>
      congr_app
        (compSubstSubst_tm sigma_ty sigma_tm tau_ty tau_tm theta_ty theta_tm
           Eq_ty Eq_tm s0)
        (compSubstSubst_tm sigma_ty sigma_tm tau_ty tau_tm theta_ty theta_tm
           Eq_ty Eq_tm s1)
  | tapp s0 s1 =>
      congr_tapp
        (compSubstSubst_tm sigma_ty sigma_tm tau_ty tau_tm theta_ty theta_tm
           Eq_ty Eq_tm s0)
        (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s0)
        (compSubstSubst_tm (up_tm_ty sigma_ty) (up_tm_tm sigma_tm)
           (up_tm_ty tau_ty) (up_tm_tm tau_tm) (up_tm_ty theta_ty)
           (up_tm_tm theta_tm) (up_subst_subst_tm_ty _ _ _ Eq_ty)
           (up_subst_subst_tm_tm _ _ _ _ Eq_tm) s1)
  | tlam s0 =>
      congr_tlam
        (compSubstSubst_tm (up_ty_ty sigma_ty) (up_ty_tm sigma_tm)
           (up_ty_ty tau_ty) (up_ty_tm tau_tm) (up_ty_ty theta_ty)
           (up_ty_tm theta_tm) (up_subst_subst_ty_ty _ _ _ Eq_ty)
           (up_subst_subst_ty_tm _ _ _ _ Eq_tm) s0)
  end.

Lemma renRen_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) (s : tm) :
  ren_tm zeta_ty zeta_tm (ren_tm xi_ty xi_tm s) =
  ren_tm (funcomp zeta_ty xi_ty) (funcomp zeta_tm xi_tm) s.
Proof.
exact (compRenRen_tm xi_ty xi_tm zeta_ty zeta_tm _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma renRen'_tm_pointwise (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) :
  pointwise_relation _ eq
    (funcomp (ren_tm zeta_ty zeta_tm) (ren_tm xi_ty xi_tm))
    (ren_tm (funcomp zeta_ty xi_ty) (funcomp zeta_tm xi_tm)).
Proof.
exact (fun s =>
       compRenRen_tm xi_ty xi_tm zeta_ty zeta_tm _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) (s : tm) :
  subst_tm tau_ty tau_tm (ren_tm xi_ty xi_tm s) =
  subst_tm (funcomp tau_ty xi_ty) (funcomp tau_tm xi_tm) s.
Proof.
exact (compRenSubst_tm xi_ty xi_tm tau_ty tau_tm _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm_pointwise (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) :
  pointwise_relation _ eq
    (funcomp (subst_tm tau_ty tau_tm) (ren_tm xi_ty xi_tm))
    (subst_tm (funcomp tau_ty xi_ty) (funcomp tau_tm xi_tm)).
Proof.
exact (fun s =>
       compRenSubst_tm xi_ty xi_tm tau_ty tau_tm _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma substRen_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) (s : tm) :
  ren_tm zeta_ty zeta_tm (subst_tm sigma_ty sigma_tm s) =
  subst_tm (funcomp (ren_ty zeta_ty) sigma_ty)
    (funcomp (ren_tm zeta_ty zeta_tm) sigma_tm) s.
Proof.
exact (compSubstRen_tm sigma_ty sigma_tm zeta_ty zeta_tm _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma substRen_tm_pointwise (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) :
  pointwise_relation _ eq
    (funcomp (ren_tm zeta_ty zeta_tm) (subst_tm sigma_ty sigma_tm))
    (subst_tm (funcomp (ren_ty zeta_ty) sigma_ty)
       (funcomp (ren_tm zeta_ty zeta_tm) sigma_tm)).
Proof.
exact (fun s =>
       compSubstRen_tm sigma_ty sigma_tm zeta_ty zeta_tm _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) (s : tm) :
  subst_tm tau_ty tau_tm (subst_tm sigma_ty sigma_tm s) =
  subst_tm (funcomp (subst_ty tau_ty) sigma_ty)
    (funcomp (subst_tm tau_ty tau_tm) sigma_tm) s.
Proof.
exact (compSubstSubst_tm sigma_ty sigma_tm tau_ty tau_tm _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm_pointwise (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) :
  pointwise_relation _ eq
    (funcomp (subst_tm tau_ty tau_tm) (subst_tm sigma_ty sigma_tm))
    (subst_tm (funcomp (subst_ty tau_ty) sigma_ty)
       (funcomp (subst_tm tau_ty tau_tm) sigma_tm)).
Proof.
exact (fun s =>
       compSubstSubst_tm sigma_ty sigma_tm tau_ty tau_tm _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma rinstInst_up_ty_tm (xi : nat -> nat) (sigma : nat -> tm)
  (Eq : forall x, funcomp (var_tm) xi x = sigma x) :
  forall x, funcomp (var_tm) (upRen_ty_tm xi) x = up_ty_tm sigma x.
Proof.
exact (fun n => ap (ren_tm shift id) (Eq n)).
Qed.

Lemma rinstInst_up_tm_ty (xi : nat -> nat) (sigma : nat -> ty)
  (Eq : forall x, funcomp (var_ty) xi x = sigma x) :
  forall x, funcomp (var_ty) (upRen_tm_ty xi) x = up_tm_ty sigma x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma rinstInst_up_tm_tm (xi : nat -> nat) (sigma : nat -> tm)
  (Eq : forall x, funcomp (var_tm) xi x = sigma x) :
  forall x, funcomp (var_tm) (upRen_tm_tm xi) x = up_tm_tm sigma x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_tm id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint rinst_inst_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
(sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
(Eq_ty : forall x, funcomp (var_ty) xi_ty x = sigma_ty x)
(Eq_tm : forall x, funcomp (var_tm) xi_tm x = sigma_tm x) (s : tm) {struct s}
   : ren_tm xi_ty xi_tm s = subst_tm sigma_ty sigma_tm s :=
  match s with
  | var_tm s0 => Eq_tm s0
  | app s0 s1 =>
      congr_app (rinst_inst_tm xi_ty xi_tm sigma_ty sigma_tm Eq_ty Eq_tm s0)
        (rinst_inst_tm xi_ty xi_tm sigma_ty sigma_tm Eq_ty Eq_tm s1)
  | tapp s0 s1 =>
      congr_tapp (rinst_inst_tm xi_ty xi_tm sigma_ty sigma_tm Eq_ty Eq_tm s0)
        (rinst_inst_ty xi_ty sigma_ty Eq_ty s1)
  | lam s0 s1 =>
      congr_lam (rinst_inst_ty xi_ty sigma_ty Eq_ty s0)
        (rinst_inst_tm (upRen_tm_ty xi_ty) (upRen_tm_tm xi_tm)
           (up_tm_ty sigma_ty) (up_tm_tm sigma_tm)
           (rinstInst_up_tm_ty _ _ Eq_ty) (rinstInst_up_tm_tm _ _ Eq_tm) s1)
  | tlam s0 =>
      congr_tlam
        (rinst_inst_tm (upRen_ty_ty xi_ty) (upRen_ty_tm xi_tm)
           (up_ty_ty sigma_ty) (up_ty_tm sigma_tm)
           (rinstInst_up_ty_ty _ _ Eq_ty) (rinstInst_up_ty_tm _ _ Eq_tm) s0)
  end.

Lemma rinstInst'_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat) (s : tm) :
  ren_tm xi_ty xi_tm s =
  subst_tm (funcomp (var_ty) xi_ty) (funcomp (var_tm) xi_tm) s.
Proof.
exact (rinst_inst_tm xi_ty xi_tm _ _ (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm_pointwise (xi_ty : nat -> nat) (xi_tm : nat -> nat) :
  pointwise_relation _ eq (ren_tm xi_ty xi_tm)
    (subst_tm (funcomp (var_ty) xi_ty) (funcomp (var_tm) xi_tm)).
Proof.
exact (fun s =>
       rinst_inst_tm xi_ty xi_tm _ _ (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma instId'_tm (s : tm) : subst_tm (var_ty) (var_tm) s = s.
Proof.
exact (idSubst_tm (var_ty) (var_tm) (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma instId'_tm_pointwise :
  pointwise_relation _ eq (subst_tm (var_ty) (var_tm)) id.
Proof.
exact (fun s =>
       idSubst_tm (var_ty) (var_tm) (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_tm (s : tm) : ren_tm id id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id id s)).
Qed.

Lemma rinstId'_tm_pointwise : pointwise_relation _ eq (@ren_tm id id) id.
Proof.
exact (fun s =>
       eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id id s)).
Qed.

Lemma varL'_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm) (x : nat) :
  subst_tm sigma_ty sigma_tm (var_tm x) = sigma_tm x.
Proof.
exact (eq_refl).
Qed.

Lemma varL'_tm_pointwise (sigma_ty : nat -> ty) (sigma_tm : nat -> tm) :
  pointwise_relation _ eq (funcomp (subst_tm sigma_ty sigma_tm) (var_tm))
    sigma_tm.
Proof.
exact (fun x => eq_refl).
Qed.

Lemma varLRen'_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat) (x : nat) :
  ren_tm xi_ty xi_tm (var_tm x) = var_tm (xi_tm x).
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_tm_pointwise (xi_ty : nat -> nat) (xi_tm : nat -> nat) :
  pointwise_relation _ eq (funcomp (ren_tm xi_ty xi_tm) (var_tm))
    (funcomp (var_tm) xi_tm).
Proof.
exact (fun x => eq_refl).
Qed.

Class Up_tm X Y :=
    up_tm : X -> Y.

Class Up_ty X Y :=
    up_ty : X -> Y.

Instance Subst_tm : (Subst2 _ _ _ _) := @subst_tm.

Instance Up_tm_tm : (Up_tm _ _) := @up_tm_tm.

Instance Up_tm_ty : (Up_ty _ _) := @up_tm_ty.

Instance Up_ty_tm : (Up_tm _ _) := @up_ty_tm.

Instance Ren_tm : (Ren2 _ _ _ _) := @ren_tm.

Instance VarInstance_tm : (Var _ _) := @var_tm.

Instance Subst_ty : (Subst1 _ _ _) := @subst_ty.

Instance Up_ty_ty : (Up_ty _ _) := @up_ty_ty.

Instance Ren_ty : (Ren1 _ _ _) := @ren_ty.

Instance VarInstance_ty : (Var _ _) := @var_ty.

Notation "[ sigma_ty ; sigma_tm ]" := (subst_tm sigma_ty sigma_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_ty ; sigma_tm ]" := (subst_tm sigma_ty sigma_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__tm" := up_tm (only printing) : subst_scope.

Notation "↑__tm" := up_tm_tm (only printing) : subst_scope.

Notation "↑__ty" := up_tm_ty (only printing) : subst_scope.

Notation "↑__tm" := up_ty_tm (only printing) : subst_scope.

Notation "⟨ xi_ty ; xi_tm ⟩" := (ren_tm xi_ty xi_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_ty ; xi_tm ⟩" := (ren_tm xi_ty xi_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "'var'" := var_tm ( at level 1, only printing) : subst_scope.

Notation "x '__tm'" := (@ids _ _ VarInstance_tm x)
  ( at level 5, format "x __tm", only printing) : subst_scope.

Notation "x '__tm'" := (var_tm x) ( at level 5, format "x __tm") :
  subst_scope.

Notation "[ sigma_ty ]" := (subst_ty sigma_ty)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_ty ]" := (subst_ty sigma_ty s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__ty" := up_ty (only printing) : subst_scope.

Notation "↑__ty" := up_ty_ty (only printing) : subst_scope.

Notation "⟨ xi_ty ⟩" := (ren_ty xi_ty)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_ty ⟩" := (ren_ty xi_ty s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "'var'" := var_ty ( at level 1, only printing) : subst_scope.

Notation "x '__ty'" := (@ids _ _ VarInstance_ty x)
  ( at level 5, format "x __ty", only printing) : subst_scope.

Notation "x '__ty'" := (var_ty x) ( at level 5, format "x __ty") :
  subst_scope.

Instance subst_tm_morphism :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (respectful eq eq))) (@subst_tm)).
Proof.
exact (fun f_ty g_ty Eq_ty f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => subst_tm f_ty f_tm s = subst_tm g_ty g_tm t')
         (ext_tm f_ty f_tm g_ty g_tm Eq_ty Eq_tm s) t Eq_st).
Qed.

Instance subst_tm_morphism2 :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (pointwise_relation _ eq)))
    (@subst_tm)).
Proof.
exact (fun f_ty g_ty Eq_ty f_tm g_tm Eq_tm s =>
       ext_tm f_ty f_tm g_ty g_tm Eq_ty Eq_tm s).
Qed.

Instance ren_tm_morphism :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (respectful eq eq))) (@ren_tm)).
Proof.
exact (fun f_ty g_ty Eq_ty f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => ren_tm f_ty f_tm s = ren_tm g_ty g_tm t')
         (extRen_tm f_ty f_tm g_ty g_tm Eq_ty Eq_tm s) t Eq_st).
Qed.

Instance ren_tm_morphism2 :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (pointwise_relation _ eq)))
    (@ren_tm)).
Proof.
exact (fun f_ty g_ty Eq_ty f_tm g_tm Eq_tm s =>
       extRen_tm f_ty f_tm g_ty g_tm Eq_ty Eq_tm s).
Qed.

Instance subst_ty_morphism :
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@subst_ty)).
Proof.
exact (fun f_ty g_ty Eq_ty s t Eq_st =>
       eq_ind s (fun t' => subst_ty f_ty s = subst_ty g_ty t')
         (ext_ty f_ty g_ty Eq_ty s) t Eq_st).
Qed.

Instance subst_ty_morphism2 :
 (Proper (respectful (pointwise_relation _ eq) (pointwise_relation _ eq))
    (@subst_ty)).
Proof.
exact (fun f_ty g_ty Eq_ty s => ext_ty f_ty g_ty Eq_ty s).
Qed.

Instance ren_ty_morphism :
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) (@ren_ty)).
Proof.
exact (fun f_ty g_ty Eq_ty s t Eq_st =>
       eq_ind s (fun t' => ren_ty f_ty s = ren_ty g_ty t')
         (extRen_ty f_ty g_ty Eq_ty s) t Eq_st).
Qed.

Instance ren_ty_morphism2 :
 (Proper (respectful (pointwise_relation _ eq) (pointwise_relation _ eq))
    (@ren_ty)).
Proof.
exact (fun f_ty g_ty Eq_ty s => extRen_ty f_ty g_ty Eq_ty s).
Qed.

Ltac auto_unfold := repeat
                     unfold VarInstance_ty, Var, ids, Ren_ty, Ren1, ren1,
                      Up_ty_ty, Up_ty, up_ty, Subst_ty, Subst1, subst1,
                      VarInstance_tm, Var, ids, Ren_tm, Ren2, ren2, Up_ty_tm,
                      Up_tm, up_tm, Up_tm_ty, Up_ty, up_ty, Up_tm_tm, Up_tm,
                      up_tm, Subst_tm, Subst2, subst2.

Tactic Notation "auto_unfold" "in" "*" := repeat
                                           unfold VarInstance_ty, Var, ids,
                                            Ren_ty, Ren1, ren1, Up_ty_ty,
                                            Up_ty, up_ty, Subst_ty, Subst1,
                                            subst1, VarInstance_tm, Var, ids,
                                            Ren_tm, Ren2, ren2, Up_ty_tm,
                                            Up_tm, up_tm, Up_tm_ty, Up_ty,
                                            up_ty, Up_tm_tm, Up_tm, up_tm,
                                            Subst_tm, Subst2, subst2
                                            in *.

Ltac asimpl' := repeat (first
                 [ progress setoid_rewrite substSubst_tm_pointwise
                 | progress setoid_rewrite substSubst_tm
                 | progress setoid_rewrite substRen_tm_pointwise
                 | progress setoid_rewrite substRen_tm
                 | progress setoid_rewrite renSubst_tm_pointwise
                 | progress setoid_rewrite renSubst_tm
                 | progress setoid_rewrite renRen'_tm_pointwise
                 | progress setoid_rewrite renRen_tm
                 | progress setoid_rewrite substSubst_ty_pointwise
                 | progress setoid_rewrite substSubst_ty
                 | progress setoid_rewrite substRen_ty_pointwise
                 | progress setoid_rewrite substRen_ty
                 | progress setoid_rewrite renSubst_ty_pointwise
                 | progress setoid_rewrite renSubst_ty
                 | progress setoid_rewrite renRen'_ty_pointwise
                 | progress setoid_rewrite renRen_ty
                 | progress setoid_rewrite varLRen'_tm_pointwise
                 | progress setoid_rewrite varLRen'_tm
                 | progress setoid_rewrite varL'_tm_pointwise
                 | progress setoid_rewrite varL'_tm
                 | progress setoid_rewrite rinstId'_tm_pointwise
                 | progress setoid_rewrite rinstId'_tm
                 | progress setoid_rewrite instId'_tm_pointwise
                 | progress setoid_rewrite instId'_tm
                 | progress setoid_rewrite varLRen'_ty_pointwise
                 | progress setoid_rewrite varLRen'_ty
                 | progress setoid_rewrite varL'_ty_pointwise
                 | progress setoid_rewrite varL'_ty
                 | progress setoid_rewrite rinstId'_ty_pointwise
                 | progress setoid_rewrite rinstId'_ty
                 | progress setoid_rewrite instId'_ty_pointwise
                 | progress setoid_rewrite instId'_ty
                 | progress
                    unfold up_tm_tm, up_tm_ty, up_ty_tm, upRen_tm_tm,
                     upRen_tm_ty, upRen_ty_tm, up_ty_ty, upRen_ty_ty, up_ren
                 | progress cbn[subst_tm ren_tm subst_ty ren_ty]
                 | progress fsimpl ]).

Ltac asimpl := check_no_evars;
                repeat
                 unfold VarInstance_ty, Var, ids, Ren_ty, Ren1, ren1,
                  Up_ty_ty, Up_ty, up_ty, Subst_ty, Subst1, subst1,
                  VarInstance_tm, Var, ids, Ren_tm, Ren2, ren2, Up_ty_tm,
                  Up_tm, up_tm, Up_tm_ty, Up_ty, up_ty, Up_tm_tm, Up_tm,
                  up_tm, Subst_tm, Subst2, subst2 in *; asimpl'; minimize.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case ltac:(asimpl; cbn; eauto).

Ltac substify := auto_unfold; try setoid_rewrite rinstInst'_tm_pointwise;
                  try setoid_rewrite rinstInst'_tm;
                  try setoid_rewrite rinstInst'_ty_pointwise;
                  try setoid_rewrite rinstInst'_ty.

Ltac renamify := auto_unfold; try setoid_rewrite_left rinstInst'_tm_pointwise;
                  try setoid_rewrite_left rinstInst'_tm;
                  try setoid_rewrite_left rinstInst'_ty_pointwise;
                  try setoid_rewrite_left rinstInst'_ty.

End Core.

Module Fext.

Import
Core.

Lemma renRen'_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat) :
  funcomp (ren_ty zeta_ty) (ren_ty xi_ty) = ren_ty (funcomp zeta_ty xi_ty).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renRen_ty xi_ty zeta_ty n)).
Qed.

Lemma renSubst'_ty (xi_ty : nat -> nat) (tau_ty : nat -> ty) :
  funcomp (subst_ty tau_ty) (ren_ty xi_ty) = subst_ty (funcomp tau_ty xi_ty).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renSubst_ty xi_ty tau_ty n)).
Qed.

Lemma substRen'_ty (sigma_ty : nat -> ty) (zeta_ty : nat -> nat) :
  funcomp (ren_ty zeta_ty) (subst_ty sigma_ty) =
  subst_ty (funcomp (ren_ty zeta_ty) sigma_ty).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substRen_ty sigma_ty zeta_ty n)).
Qed.

Lemma substSubst'_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty) :
  funcomp (subst_ty tau_ty) (subst_ty sigma_ty) =
  subst_ty (funcomp (subst_ty tau_ty) sigma_ty).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substSubst_ty sigma_ty tau_ty n)).
Qed.

Lemma rinstInst_ty (xi_ty : nat -> nat) :
  ren_ty xi_ty = subst_ty (funcomp (var_ty) xi_ty).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => rinst_inst_ty xi_ty _ (fun n => eq_refl) x)).
Qed.

Lemma instId_ty : subst_ty (var_ty) = id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => idSubst_ty (var_ty) (fun n => eq_refl) (id x))).
Qed.

Lemma rinstId_ty : @ren_ty id = id.
Proof.
exact (eq_trans (rinstInst_ty (id _)) instId_ty).
Qed.

Lemma varL_ty (sigma_ty : nat -> ty) :
  funcomp (subst_ty sigma_ty) (var_ty) = sigma_ty.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma varLRen_ty (xi_ty : nat -> nat) :
  funcomp (ren_ty xi_ty) (var_ty) = funcomp (var_ty) xi_ty.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma renRen'_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) :
  funcomp (ren_tm zeta_ty zeta_tm) (ren_tm xi_ty xi_tm) =
  ren_tm (funcomp zeta_ty xi_ty) (funcomp zeta_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renRen_tm xi_ty xi_tm zeta_ty zeta_tm n)).
Qed.

Lemma renSubst'_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) :
  funcomp (subst_tm tau_ty tau_tm) (ren_tm xi_ty xi_tm) =
  subst_tm (funcomp tau_ty xi_ty) (funcomp tau_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renSubst_tm xi_ty xi_tm tau_ty tau_tm n)).
Qed.

Lemma substRen'_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) :
  funcomp (ren_tm zeta_ty zeta_tm) (subst_tm sigma_ty sigma_tm) =
  subst_tm (funcomp (ren_ty zeta_ty) sigma_ty)
    (funcomp (ren_tm zeta_ty zeta_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substRen_tm sigma_ty sigma_tm zeta_ty zeta_tm n)).
Qed.

Lemma substSubst'_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) :
  funcomp (subst_tm tau_ty tau_tm) (subst_tm sigma_ty sigma_tm) =
  subst_tm (funcomp (subst_ty tau_ty) sigma_ty)
    (funcomp (subst_tm tau_ty tau_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substSubst_tm sigma_ty sigma_tm tau_ty tau_tm n)).
Qed.

Lemma rinstInst_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat) :
  ren_tm xi_ty xi_tm =
  subst_tm (funcomp (var_ty) xi_ty) (funcomp (var_tm) xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x =>
          rinst_inst_tm xi_ty xi_tm _ _ (fun n => eq_refl) (fun n => eq_refl)
            x)).
Qed.

Lemma instId_tm : subst_tm (var_ty) (var_tm) = id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x =>
          idSubst_tm (var_ty) (var_tm) (fun n => eq_refl) (fun n => eq_refl)
            (id x))).
Qed.

Lemma rinstId_tm : @ren_tm id id = id.
Proof.
exact (eq_trans (rinstInst_tm (id _) (id _)) instId_tm).
Qed.

Lemma varL_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm) :
  funcomp (subst_tm sigma_ty sigma_tm) (var_tm) = sigma_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma varLRen_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat) :
  funcomp (ren_tm xi_ty xi_tm) (var_tm) = funcomp (var_tm) xi_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Ltac asimpl_fext' := repeat (first
                      [ progress rewrite ?substSubst_tm_pointwise
                      | progress rewrite ?substSubst_tm
                      | progress rewrite ?substRen_tm_pointwise
                      | progress rewrite ?substRen_tm
                      | progress rewrite ?renSubst_tm_pointwise
                      | progress rewrite ?renSubst_tm
                      | progress rewrite ?renRen'_tm_pointwise
                      | progress rewrite ?renRen_tm
                      | progress rewrite ?substSubst_ty_pointwise
                      | progress rewrite ?substSubst_ty
                      | progress rewrite ?substRen_ty_pointwise
                      | progress rewrite ?substRen_ty
                      | progress rewrite ?renSubst_ty_pointwise
                      | progress rewrite ?renSubst_ty
                      | progress rewrite ?renRen'_ty_pointwise
                      | progress rewrite ?renRen_ty
                      | progress rewrite ?varLRen_tm
                      | progress rewrite ?varL_tm
                      | progress rewrite ?rinstId_tm
                      | progress rewrite ?instId_tm
                      | progress rewrite ?substSubst'_tm
                      | progress rewrite ?substRen'_tm
                      | progress rewrite ?renSubst'_tm
                      | progress rewrite ?renRen'_tm
                      | progress rewrite ?varLRen_ty
                      | progress rewrite ?varL_ty
                      | progress rewrite ?rinstId_ty
                      | progress rewrite ?instId_ty
                      | progress rewrite ?substSubst'_ty
                      | progress rewrite ?substRen'_ty
                      | progress rewrite ?renSubst'_ty
                      | progress rewrite ?renRen'_ty
                      | progress
                         unfold up_tm_tm, up_tm_ty, up_ty_tm, upRen_tm_tm,
                          upRen_tm_ty, upRen_ty_tm, up_ty_ty, upRen_ty_ty,
                          up_ren
                      | progress cbn[subst_tm ren_tm subst_ty ren_ty]
                      | fsimpl_fext ]).

Ltac asimpl_fext := check_no_evars; repeat try unfold_funcomp;
                     repeat
                      unfold VarInstance_ty, Var, ids, Ren_ty, Ren1, ren1,
                       Up_ty_ty, Up_ty, up_ty, Subst_ty, Subst1, subst1,
                       VarInstance_tm, Var, ids, Ren_tm, Ren2, ren2,
                       Up_ty_tm, Up_tm, up_tm, Up_tm_ty, Up_ty, up_ty,
                       Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst2, subst2
                       in *; asimpl_fext'; repeat try unfold_funcomp.

Tactic Notation "asimpl_fext" "in" hyp(J) := revert J; asimpl_fext; intros J.

Tactic Notation "auto_case_fext" := auto_case ltac:(asimpl_fext; cbn; eauto).

Ltac substify_fext := auto_unfold; try repeat erewrite ?rinstInst_tm;
                       try repeat erewrite ?rinstInst_ty.

Ltac renamify_fext := auto_unfold; try repeat erewrite <- ?rinstInst_tm;
                       try repeat erewrite <- ?rinstInst_ty.

End Fext.

Module Extra.

Import Core.

#[export]Hint Opaque subst_tm: rewrite.

#[export]Hint Opaque ren_tm: rewrite.

#[export]Hint Opaque subst_ty: rewrite.

#[export]Hint Opaque ren_ty: rewrite.

End Extra.

Module interface.

Export Core.

Export Fext.

Export Extra.

End interface.

Export interface.


(****************************************************************

   File: EqualUntypedG.v
   Author: Amy Felty

   original: January 2014
   Apr 2021: Current Coq Version: V8.13.1

   Generalized context version (G version) of:
   1. Admissibility of reflexivity for algorithmic equality
   2. Admissibility of symmetry, transitivity for algorithmic equality
   3. Correctness of algorithmic equality with respect to declaritive
      equality.
   4. Adequacy

  ***************************************************************)

From HybridSys Require Export sl.

#[global] Hint Resolve level_CON level_VAR level_BND level_APP level_ABS : hybrid.
#[global] Hint Resolve proper_APP abstr_proper : hybrid.
#[global] Hint Unfold proper: hybrid.

Section encoding.

(****************************************************************
   Constants for Lambda Terms
  ****************************************************************)

Inductive Econ: Set := cAPP: Econ | cLAM: Econ.
Definition uexp : Set := expr Econ.

Definition Var : var -> uexp := (VAR Econ).
Definition Bnd : bnd -> uexp := (BND Econ).
Definition app : uexp -> uexp -> uexp :=
  fun M:uexp => fun N:uexp => (APP (APP (CON cAPP) M) N).
Definition lam : (uexp -> uexp) -> uexp :=
  fun M:uexp->uexp => (APP (CON cLAM) (lambda M)).

(****************************************************************
   Some Properties of Constructors
  ****************************************************************)

Lemma proper_Var: forall x:var, (proper (Var x)).
Proof.
unfold Var; auto with hybrid.
Qed.

Lemma proper_lam : forall (e:uexp->uexp),
  abstr e -> proper (lam e).
Proof.
unfold lam; auto with hybrid.
Qed.

Lemma proper_app : forall e1 e2:uexp,
  proper e1 -> proper e2 -> proper (app e1 e2).
Proof.
unfold app; auto with hybrid.
Qed.

(****************************************************************
   The atm type and instantiation of oo.
  ****************************************************************)

Inductive atm : Set :=
   term : uexp -> atm
 | deq : uexp -> uexp -> atm
 | aeq : uexp -> uexp -> atm.

Definition oo_ := oo atm Econ.
Definition atom_ : atm -> oo_ := atom Econ.
Definition T_ : oo_ := T atm Econ.

(****************************************************************
   Definition of prog
  ****************************************************************)

Inductive prog : atm -> oo_ -> Prop :=
  (* well-formedness of terms (app and lam) *)
  | tm_a : forall M N:uexp,
      prog (term (app M N))
        (Conj (atom_ (term M)) (atom_ (term N)))
  | tm_l : forall M:uexp->uexp, abstr M ->
      prog (term (lam M))
        (All (fun x:uexp =>
          (Imp (term x) (atom_ (term (M x))))))
  (* declarative equality *)
  | de_l :forall M N:uexp->uexp, abstr M -> abstr N ->
      prog (deq (lam M) (lam N))
        (All (fun x:uexp =>
          (Imp (term x)
            (Imp (deq x x) (atom_ (deq (M x) (N x)))))))
  | de_a : forall M1 M2 N1 N2:uexp,
      prog (deq (app M1 M2) (app N1 N2))
        (Conj (atom_ (deq M1 N1)) (atom_ (deq M2 N2)))
  | de_r : forall M:uexp,
      prog (deq M M) (atom_ (term M))
  | de_s : forall M1 M2:uexp,
      prog (deq M2 M1) (atom_ (deq M1 M2))
  | de_t : forall M1 M2 M3:uexp,
      prog (deq M1 M3) (Conj (atom_ (deq M1 M2)) (atom_ (deq M2 M3)))
  (* algorithmic equality *)
  | ae_l :forall M N:uexp->uexp, abstr M -> abstr N ->
      prog (aeq (lam M) (lam N))
        (All (fun x:uexp =>
          (Imp (aeq x x) (atom_ (aeq (M x) (N x))))))
  | ae_a : forall M1 M2 N1 N2:uexp,
      prog (aeq (app M1 M2) (app N1 N2))
        (Conj (atom_ (aeq M1 N1)) (atom_ (aeq M2 N2))).

(****************************************************************
   Instantiation of seq
  ****************************************************************)

Definition seq_ : nat -> list atm -> oo_ -> Prop := seq prog.
Definition seq'_ := seq' prog.
Definition seq0 (B : oo_) : Prop := seq'_ nil B.

End encoding.

#[global] Hint Resolve proper_Var : hybrid.
#[global] Hint Resolve tm_a tm_l de_l de_a de_r de_s de_t ae_l ae_a : hybrid.
#[global] Hint Unfold oo_ atom_ T_: hybrid.
#[global] Hint Unfold seq_ seq'_ seq0: hybrid.

(****************************************************************
 1. Admissibility of Reflexivity
  ****************************************************************)

(************)
(* Contexts *)
(************)

Section ctx_refl.

(* Context Relation for Admissibility of Reflexivity and aeq Adequacy *)
Inductive xaG : list atm -> Prop :=
| nil_xa : xaG nil
| cons_xa : forall (Phi_xa:list atm) (x:uexp), proper x ->
    xaG Phi_xa -> xaG (term x::aeq x x::Phi_xa).

(* Context Membership *)
Lemma memb_refl : forall (Phi_xa:list atm) (T:uexp),
  xaG Phi_xa -> In (term T) Phi_xa -> In (aeq T T) Phi_xa.
Proof.
intros Phi_xa; induction 1; try (simpl; tauto).
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | h2]].
- injection h2; intros; subst; subst; simpl; auto.
- discriminate h2.
- simpl; right; auto with hybrid.
Qed.

Lemma aeq_strengthen_weaken :
  forall (i:nat) (T T':uexp) (Phi Psi:list atm),
  (forall (T T':uexp), In (aeq T T') Phi <->  In (aeq T T') Psi) ->
  seq_ i Phi (atom_ (aeq T T')) ->
  seq_ i Psi (atom_ (aeq T T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Phi Psi:list atm),
     (forall (T T':uexp), In (aeq T T') Phi <->  In (aeq T T') Psi) ->
     seq_ i Phi (atom_ (aeq T T')) ->
     seq_ i Psi (atom_ (aeq T T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Phi Psi h1 h2.
inversion h2; subst; clear h2.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with
          (All (fun x:uexp => (Imp (aeq x x) (atom_ (aeq (M x) (N x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h5.
    generalize (H4 x h5); intro h6.
    inversion h6; subst; clear h6 H4.
    apply s_imp; auto.
    apply h with (aeq x x::Phi); auto; try lia.
    (* proof of extended context inv *)
    intros T T'; generalize (h1 T T'); simpl; tauto.
  (* app case *)
  +inversion H3; subst; clear H3.
   assert (hi:i<i+1+1); try lia.
   generalize h; intro h'.
   specialize h with (1:=hi) (2:=h1) (3:=H4).
   specialize h' with (1:=hi) (2:=h1) (3:=H5).
   unfold seq_,atom_;
     apply s_bc with (Conj (atom_ (aeq M1 N1)) (atom_ (aeq M2 N2)));
     auto with hybrid.
   apply s_and; auto.
(* context case *)
- destruct (h1 T T') as [h2 h3].
  generalize (h2 H2); clear h1 h2 h3 H2.
  case Psi.
  + simpl; tauto.
  + intros a Phi h1.
    apply s_init; auto with hybrid.
Qed.

Lemma d_str_xa2a_aeq :
  forall (i:nat) (T T' x:uexp) (Gamma:list atm),
  seq_ i (term x::aeq x x::Gamma) (atom_ (aeq T T')) ->
  seq_ i (aeq x x::Gamma) (atom_ (aeq T T')).
Proof.
intros i T T' x Gamma h.
apply aeq_strengthen_weaken with (term x::aeq x x::Gamma); auto.
clear h T T' i.
intros T T'; simpl; split.
- intros [h1 | [h1 | h1]]; try discriminate h1; auto.
- intros [h1 | h1]; auto.
Qed.

End ctx_refl.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

#[global] Hint Resolve nil_xa cons_xa memb_refl : hybrid.

Section refl.

Lemma aeq_refl :
  forall (i:nat) (T:uexp) (Phi_xa:list atm), xaG Phi_xa ->
  seq_ i Phi_xa (atom_ (term T)) ->
  seq_ i Phi_xa (atom_ (aeq T T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T:uexp) (Phi_xa:list atm),
     xaG Phi_xa ->
     seq_ i Phi_xa (atom_ (term T)) ->
     seq_ i Phi_xa (atom_ (aeq T T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T Phi_xa gInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=gInv) (3:=H4).
    specialize h' with (1:=hi) (2:=gInv) (3:=H5).
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (aeq M M)) (atom_ (aeq N N)));
      auto with hybrid.
    apply s_and; auto.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with
          (All (fun x:uexp => (Imp (aeq x x) (atom_ (aeq (M x) (M x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h1.
    generalize (H4 x h1); intro h2.
    inversion h2; subst; clear h2.
    apply s_imp; auto.
    apply d_str_xa2a_aeq; auto.
    apply h; eauto with hybrid; try lia.
    apply seq_thin_exch with (term x::Phi_xa); auto.
    intro a; simpl; tauto.
(* context case *)
- apply s_init; eauto with hybrid. (* applies memb_refl *)
Qed.

Lemma aeq_refl_cor :
  forall (T:uexp), seq0 (atom_ (term T)) -> seq0 (atom_ (aeq T T)).
Proof.
intros T [n h].
assert (h1:xaG nil); eauto with hybrid.
specialize aeq_refl with (1:=h1) (2:=h); intro h2.
exists n; auto.
Qed.

End refl.

(****************************************************************
 2. Admissibility of Symmetry and Transivity
  ****************************************************************)

(************)
(* Contexts *)
(************)

Section ctx_symm_tr.

(* Context Relation for Symmetry and Transitivity *)
Inductive aG : list atm -> Prop :=
| nil_a : aG nil
| cons_a : forall (Phi_a:list atm) (x:uexp), proper x ->
    aG Phi_a -> aG (aeq x x::Phi_a).

(* Membership Lemma: used in symmetry and transitivity proofs *)
Lemma memb_symm_tr: forall (Phi_a:list atm) (T T':uexp),
  aG Phi_a -> In (aeq T T') Phi_a -> T=T'.
Proof.
intros Phi_a T T'; induction 1; try (simpl; tauto).
intro h2; simpl in h2; destruct h2 as [h2 | h2]; auto.
injection h2; intros; subst; simpl; auto.
Qed.

End ctx_symm_tr.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

#[global] Hint Resolve nil_a cons_a : hybrid.

Section symm_tr.

Lemma aeq_symm :
  forall (i:nat) (T T':uexp) (Phi_a:list atm),
  aG Phi_a ->
  seq_ i Phi_a (atom_ (aeq T T')) ->
  seq_ i Phi_a (atom_ (aeq T' T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Phi_a:list atm),
     aG Phi_a ->
     seq_ i Phi_a (atom_ (aeq T T')) ->
     seq_ i Phi_a (atom_ (aeq T' T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Phi_a cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with
          (All (fun x:uexp => (Imp (aeq x x) (atom_ (aeq (N x) (M x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h2.
    specialize H4 with (1:=h2).
    inversion H4; subst; clear H4.
    apply s_imp; auto.
    apply h; eauto with hybrid; try lia.
  (* app case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (aeq N1 M1)) (atom_ (aeq N2 M2)));
      auto with hybrid.
    apply s_and; auto.
    * apply h; try lia; auto.
    * apply h; try lia; auto.
(* context case *)
- inversion cInv; subst.
  specialize memb_symm_tr with (1:=cInv) (2:=H2); intro; subst; auto.
  apply s_init; eauto with hybrid.
Qed.

Lemma aeq_symm_cor : forall (T T':uexp),
 seq0 (atom_ (aeq T T')) -> seq0 (atom_ (aeq T' T)).
Proof.
intros T T' [i h1].
generalize nil_a; intro h3.
exists i; apply aeq_symm; auto.
Qed.

Lemma aeq_trans :
  forall (i:nat) (T R U:uexp) (Phi_a:list atm),
  aG Phi_a ->
  seq_ i Phi_a (atom_ (aeq T R)) ->
  seq_ i Phi_a (atom_ (aeq R U)) ->
  seq_ i Phi_a (atom_ (aeq T U)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T R U:uexp) (Phi_a:list atm),
     aG Phi_a ->
     seq_ i Phi_a (atom_ (aeq T R)) ->
     seq_ i Phi_a (atom_ (aeq R U)) ->
     seq_ i Phi_a (atom_ (aeq T U)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T R U Phi_a cInv h1 h2.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    inversion h2; subst; clear h2.
    * inversion H1; subst; clear H1.
      specialize abstr_lbind_simp with (1:=H7) (2:=H5) (3:=H0); intro h1.
      rewrite H.
      unfold seq_,atom_;
        apply s_bc with
            (All (fun x:uexp => (Imp (aeq x x) (atom_ (aeq (M x) (N0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h2.
      inversion H6; subst; clear H6.
      specialize H10 with (1:=h2).
      unfold ext_eq in h1; rewrite -> h1 in H10; auto; clear H0 H7 h1 M0.
      assert (hi:i1=i); try lia; subst; clear H.
      specialize H4 with (1:=h2).
      inversion H10; subst; clear H10.
      inversion H4; subst; clear H4.
      apply s_imp; auto.
      assert (hi:i0=i); try lia; subst; clear H.
      apply h with (N x); eauto with hybrid; try lia.
    (* lam case: context subcase *)
    * specialize memb_symm_tr with (1:=cInv) (2:=H3); intro; subst.
      unfold seq_,atom_;
        apply s_bc with
            (All (fun x:uexp => (Imp (aeq x x) (atom_ (aeq (M x) (N x))))));
        auto with hybrid.
      apply s_all; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    inversion h2; subst; clear h2.
    * inversion H1; subst; clear H1.
      inversion H3; subst; clear H3.
      assert (hi:i1=i); try lia; subst; clear H.
      unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (aeq M1 N0)) (atom_ (aeq M2 N3)));
        auto with hybrid.
      apply s_and; auto.
      -- apply h with N1; try lia; auto.
      -- apply h with N2; try lia; auto.
    (* app case: context subcase *)
    * specialize memb_symm_tr with (1:=cInv) (2:=H2); intro; subst.
      unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (aeq M1 N1)) (atom_ (aeq M2 N2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- inversion cInv; subst.
  specialize memb_symm_tr with (1:=cInv) (2:=H2); intro; subst; auto.
Qed.

Lemma aeq_trans_cor : forall (T R U:uexp),
 seq0 (atom_ (aeq T R)) -> seq0 (atom_ (aeq R U)) ->
 seq0 (atom_ (aeq T U)).
Proof.
intros T R U [i h1] [j h2].
generalize nil_a; intro h3.
exists (i+j); apply aeq_trans with R; auto.
- apply seq_mono_cor with i; auto; try lia.
- apply seq_mono_cor with j; auto; try lia.
Qed.

End symm_tr.

(****************************************************************
 3. Correctness
  ****************************************************************)

(************************)
(* Inversion Properties *)
(************************)
(* Specialized inversion properties of prog (could be automated) *)

Section de_inv.

Lemma de_l_inv :
forall (i:nat) (Psi:list atm) (T T':uexp->uexp),
(forall x : uexp,
       proper x ->
       seq_ i Psi (Imp (term x) (Imp (deq x x)
                   (atom_ (deq (T x) (T' x)))))) ->
exists j:nat, (i=j+2 /\
 forall x : uexp,
       proper x ->
       seq_ j ((deq x x)::(term x)::Psi) (atom_ (deq (T x) (T' x)))).
Proof.
induction i; auto.
- intros Psi T T' H.
  generalize (H (Var 0) (proper_Var 0)); intro H1.
  inversion H1; clear H1; subst.
  replace (i+1) with (S i) in H0; try lia.
- generalize i; clear i IHi.
  induction i; auto.
  + intros Psi T T' H.
    generalize (H (Var 0) (proper_Var 0)); intro H1.
    inversion H1; clear H1; subst.
    inversion H4; clear H4; subst.
    replace (i0+1+1) with (S (S i0)) in H0; try lia.
  + intros Psi T T' H.
    exists i; split; try lia.
    intros x H0.
    generalize (H x H0); intro H1.
    inversion H1; clear H1; subst.
    inversion H5; clear H5; subst.
    assert (i1 = i); try lia.
    subst; auto.
Qed.

End de_inv.

(************)
(* Contexts *)
(************)

Section ctx_ceq.

(* Context Relation for Completeness *)
Inductive daG : list atm -> Prop :=
| nil_da : daG nil
| cons_da : forall (Gamma:list atm) (x:uexp),
    proper x -> daG Gamma ->
    daG (term x::deq x x::aeq x x::Gamma).

(* Membership Lemma *)
Lemma memb_ceq : forall (Gamma:list atm) (T T':uexp),
  daG Gamma ->
  In (deq T T') Gamma -> In (aeq T T') Gamma.
Proof.
intros Gamma T T'; induction 1; try (simpl; tauto).
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | [h2 | h2]]].
- discriminate h2.
- injection h2; intros; subst; subst; simpl; auto.
- discriminate h2.
- simpl; right; auto with hybrid.
Qed.

Lemma term_strengthen_weaken :
  forall (i:nat) (T:uexp) (Phi Psi:list atm),
  (forall (T:uexp), In (term T) Phi <->  In (term T) Psi) ->
  seq_ i Phi (atom_ (term T)) ->
  seq_ i Psi (atom_ (term T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T:uexp) (Phi Psi:list atm),
     (forall (T:uexp), In (term T ) Phi <->  In (term T) Psi) ->
     seq_ i Phi (atom_ (term T)) ->
     seq_ i Psi (atom_ (term T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T Phi Psi h1 h2.
inversion h2; subst; clear h2.
- inversion H0; subst; clear H0.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=h1) (3:=H4).
    specialize h' with (1:=hi) (2:=h1) (3:=H5).
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (term M)) (atom_ (term N)));
      auto with hybrid.
    apply s_and; auto.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with
          (All (fun x:uexp => (Imp (term x) (atom_ (term (M x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h5.
    generalize (H4 x h5); intro h6.
    inversion h6; subst; clear h6 H4.
    apply s_imp; auto.
    apply h with (term x::Phi); auto; try lia.
    (* proof of extended context inv *)
    intro T; generalize (h1 T); simpl; tauto.
(* context case *)
- destruct (h1 T) as [h2 h3].
  generalize (h2 H2); clear h1 h2 h3 H2.
  case Psi.
  + simpl; tauto.
  + intros a Phi h1.
    apply s_init; auto with hybrid.
Qed.

Lemma d_str_da2a_aeq :
  forall (i:nat) (T T' x:uexp) (Gamma:list atm),
  seq_ i (term x::deq x x::aeq x x::Gamma) (atom_ (aeq T T')) ->
  seq_ i (aeq x x::Gamma) (atom_ (aeq T T')).
Proof.
intros i T T' x Gamma h.
apply aeq_strengthen_weaken with (term x::deq x x::aeq x x::Gamma); auto.
clear h T T' i.
intros T T'; simpl; split.
- intros [h1 | [h1 | [h1 | h1]]]; try discriminate h1; auto.
- intros [h1 | h1]; auto.
Qed.

End ctx_ceq.

(*************)
(* Promotion *)
(*************)

Section promote_refl.

Fixpoint rm_da2xa (l:list atm) {struct l} : list atm
  := match l with
       nil => nil
     | (term z::deq x y::aeq x' y'::l') =>
                    (term z::aeq x' y'::rm_da2xa l')
     | _ => nil
     end.

Lemma rm_da2xa_lem_aeq :
  forall (T T':uexp) (Gamma:list atm),
  daG Gamma ->
  (In (aeq T T') (rm_da2xa Gamma) <-> In (aeq T T') Gamma).
Proof.
intros T T' Gamma; induction 1.
- simpl; tauto.
- split.
  + simpl; tauto.
  + simpl; intros [h1 | [h1 | h1]]; try tauto.
    discriminate h1.
Qed.

Lemma rm_da2xa_lem_term :
  forall (T:uexp) (Gamma:list atm),
  daG Gamma ->
  (In (term T) Gamma <-> In (term T) (rm_da2xa Gamma)).
Proof.
intros T Gamma; induction 1.
- simpl; tauto.
- split.
  + simpl; intros [h1 | [h1 | [h1 | h1]]]; try tauto.
    discriminate h1.
  + simpl; tauto.
Qed.

Hint Resolve rm_da2xa_lem_aeq : hybrid.

Lemma c_wk_da2xa_aeq :
  forall (i:nat) (T T':uexp) (Gamma:list atm),
  daG Gamma ->
  seq_ i (rm_da2xa Gamma) (atom_ (aeq T T')) ->
  seq_ i Gamma (atom_ (aeq T T')).
Proof.
intros i T T' Gamma h1 h2.
apply aeq_strengthen_weaken with (rm_da2xa Gamma);
  eauto with hybrid.
Qed.

(* context strengthening *)
Lemma daG2xaG_strengthen : forall (Gamma:list atm),
  daG Gamma -> xaG (rm_da2xa Gamma).
Proof.
intro Gamma; induction 1; simpl; eauto with hybrid.
Qed.

Hint Resolve rm_da2xa_lem_term : hybrid.

Lemma c_str_da2xa_term :
  forall (i:nat) (T:uexp) (Gamma:list atm),
  daG Gamma ->
  seq_ i Gamma (atom_ (term T)) ->
  seq_ i (rm_da2xa Gamma) (atom_ (term T)).
Proof.
intros i T Gamma h1 h2.
apply term_strengthen_weaken with Gamma; eauto with hybrid.
Qed.

Hint Resolve c_wk_da2xa_aeq aeq_refl daG2xaG_strengthen
             c_str_da2xa_term : hybrid.

(* Promotion Lemma for Reflexivity *)
Lemma refl_promote :
  forall (i:nat) (T:uexp) (Gamma:list atm), daG Gamma ->
  seq_ i Gamma (atom_ (term T)) ->
  seq_ i Gamma (atom_ (aeq T T)).
Proof.
intros i T Gamma h h2; eauto with hybrid.
(* apply c_wk_da2xa_aeq; auto.
   apply aeq_refl; auto.
   apply daG2xaG_strengthen; auto.
   apply c_str_da2xa_term; auto. *)
Qed.

End promote_refl.

Section promote_symm_tr.

Fixpoint rm_da2a (l:list atm) {struct l} : list atm
  := match l with
       nil => nil
     | (term z::deq x y::aeq x' y'::l') => (aeq x' y'::rm_da2a l')
     | _ => nil
     end.

Lemma rm_da2a_lem_aeq1 :
  forall (T T':uexp) (Gamma:list atm),
  daG Gamma ->
  (In (aeq T T') (rm_da2a Gamma) <-> In (aeq T T') Gamma).
Proof.
intros T T' Gamma; induction 1.
- simpl; tauto.
- split.
  + simpl; tauto.
  + simpl; intros [h1 | [h1 | [h1 | h1]]]; try tauto; discriminate h1.
Qed.

Lemma rm_da2a_lem_aeq2 :
  forall (T T':uexp) (Gamma:list atm),
  daG Gamma ->
  (In (aeq T T') Gamma <-> In (aeq T T') (rm_da2a Gamma)).
Proof.
intros T T' Gamma h.
generalize (rm_da2a_lem_aeq1 T T' Gamma h); tauto.
Qed.

Hint Resolve rm_da2a_lem_aeq1 : hybrid.

Lemma c_wk_da2a_aeq :
  forall (i:nat) (T T':uexp) (Gamma:list atm),
  daG Gamma ->
  seq_ i (rm_da2a Gamma) (atom_ (aeq T T')) ->
  seq_ i Gamma (atom_ (aeq T T')).
Proof.
intros i T T' Gamma h1 h2.
apply aeq_strengthen_weaken with (rm_da2a Gamma);
  eauto with hybrid.
Qed.

(* context strengthening *)
Lemma daG2aG_strengthen : forall (Gamma:list atm),
  daG Gamma -> aG (rm_da2a Gamma).
Proof.
intro Gamma; induction 1; simpl; eauto with hybrid.
Qed.

Hint Resolve rm_da2a_lem_aeq2 : hybrid.

Lemma c_str_da2a_aeq :
  forall (i:nat) (T T':uexp) (Gamma:list atm),
  daG Gamma ->
  seq_ i Gamma (atom_ (aeq T T')) ->
  seq_ i (rm_da2a Gamma) (atom_ (aeq T T')).
Proof.
intros i T T' Gamma h1 h2.
apply aeq_strengthen_weaken with Gamma; eauto with hybrid.
Qed.

Hint Resolve c_wk_da2a_aeq aeq_symm daG2aG_strengthen c_str_da2a_aeq :
             hybrid.

(* Promotion Lemma for Symmetry *)
Lemma symm_promote :
  forall (i:nat) (T U:uexp) (Gamma:list atm), daG Gamma ->
  seq_ i Gamma (atom_ (aeq T U)) ->
  seq_ i Gamma (atom_ (aeq U T)).
Proof.
intros i T U Gamma h h2; eauto with hybrid.
(* apply c_wk_da2a_aeq; auto.
   apply aeq_symm; auto.
   apply daG2aG_strengthen; auto.
   apply c_str_da2a_aeq; auto. *)
Qed.

(* Promotion Lemma for Transitivity *)
Lemma tr_promote :
  forall (i:nat) (T R U:uexp) (Gamma:list atm), daG Gamma ->
  seq_ i Gamma (atom_ (aeq T R)) ->
  seq_ i Gamma (atom_ (aeq R U)) ->
  seq_ i Gamma (atom_ (aeq T U)).
Proof.
intros i T R U Gamma h h2 h3; eauto with hybrid.
apply c_wk_da2a_aeq; eauto with hybrid.
apply aeq_trans with R; eauto with hybrid.
(* apply daG2aG_strengthen; auto.
   apply c_str_da2a_aeq; auto.
   apply c_str_da2a_aeq; auto. *)
Qed.

End promote_symm_tr.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

Section ceq.

Hint Resolve nil_da cons_da memb_ceq : hybrid.

Lemma eq_ceq :
  forall (i:nat) (M N:uexp) (Gamma:list atm), daG Gamma ->
  seq_ i Gamma (atom_ (deq M N)) ->
  seq_ i Gamma (atom_ (aeq M N)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (M N:uexp) (Gamma:list atm), daG Gamma ->
     seq_ i Gamma (atom_ (deq M N)) ->
     seq_ i Gamma (atom_ (aeq M N)))).
intro H'.
apply H'; clear H' i; auto.
intros i h M N Gamma gInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (de_l_inv i Gamma M0 N0 H4); clear H4; intros [j [h1 h2]];
      subst.
    unfold seq_,atom_;
      apply s_bc with
          (All (fun x:uexp => (Imp (aeq x x) (atom_ (aeq (M0 x) (N0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h1.
    apply seq_mono with (j+1); try lia.
    apply s_imp; auto.
    apply d_str_da2a_aeq; auto.
    apply h; eauto with hybrid; try lia.
    apply seq_thin_exch with (deq x x::term x::Gamma); eauto with hybrid.
    * intro a; simpl; tauto.
    * apply h2; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (aeq M1 N1)) (atom_ (aeq M2 N2)));
      auto with hybrid.
    apply s_and; auto.
    * apply h; try lia; auto.
    * apply h; try lia; auto.
  (* refl case *)
  + apply seq_mono with i0; auto; try lia.
    apply refl_promote; auto.
  (* symm case *)
  + apply seq_mono with i0; auto; try lia.
    apply symm_promote; auto.
    apply h; eauto with hybrid; try lia.
  (* trans case *)
  + inversion H3; subst; clear H3.
    apply seq_mono with i; auto; try lia.
    apply tr_promote with M2; auto.
    * apply h; eauto with hybrid; try lia.
    * apply h; eauto with hybrid; try lia.
(* context case *)
- inversion gInv; subst.
  apply s_init; eauto with hybrid.
  (* applies memb_ceq *)
Qed.

Lemma eq_ceq_cor : forall (T R:uexp),
 seq0 (atom_ (deq T R)) -> seq0 (atom_ (aeq T R)).
Proof.
intros T R [i h1].
assert (h3:daG nil); eauto with hybrid.
exists i; apply eq_ceq; auto.
Qed.

End ceq.

(****************************************************************
 4. Adequacy
  ****************************************************************)

(************************)
(* Inversion Properties *)
(************************)
(* Specialized inversion properties of prog (could be automated) *)

Section ae_inv.

Lemma ae_l_inv :
forall (i:nat) (Psi:list atm) (T T':uexp->uexp),
(forall x : uexp,
       proper x ->
       seq_ i Psi (Imp (aeq x x) (atom_ (aeq (T x) (T' x))))) ->
exists j:nat, (i=j+1 /\
 forall x : uexp,
       proper x ->
       seq_ j (aeq x x::Psi) (atom_ (aeq (T x) (T' x)))).
Proof.
induction i; auto.
- intros Psi T T' H.
  generalize (H (Var 0) (proper_Var 0)); intro H1.
  inversion H1; clear H1; subst.
  replace (i+1) with (S i) in H0; try lia.
- intros Psi T T' H.
  exists i; split; try lia.
  intros x H0.
  generalize (H x H0); intro H1.
  inversion H1; clear H1; subst.
  assert (i0 = i); try lia.
  subst; auto.
Qed.

End ae_inv.

(*********************)
(* "proper" Adequacy *)
(*********************)

Section proper_adeq.

Lemma term_proper : forall T:uexp,
  seq0 (atom_ (term T)) -> (proper T).
Proof.
intros T [n h1].
generalize T h1; clear h1 T.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T : uexp, seq_ n nil (atom_ (term T)) -> proper T)).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* app case *)
- inversion H3; clear H3; subst.
  apply proper_app; auto.
  + apply h1 with i0; auto; try lia.
  + apply h1 with i0; auto; try lia.
(* lam case *)
- inversion H3; clear H3; subst.
apply proper_lam; auto.
Qed.

Lemma deq_proper : forall T T':uexp,
  seq0 (atom_ (deq T T')) -> (proper T /\ proper T').
Proof.
intros T T' [n h1].
generalize T T' h1; clear h1 T T'.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T T' : uexp, seq_ n nil (atom_ (deq T T')) ->
        (proper T /\ proper T'))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T T' h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- split; apply proper_lam; auto.
(* app case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; apply proper_app; auto.
(* refl case *)
- split; apply term_proper; unfold seq0,seq'_,seq'; auto.
  + exists i; auto.
  + exists i; auto.
(* symm case *)
- assert (h4:i<i+1); try lia.
  specialize h1 with (1:=h4) (2:=H3); elim h1; clear h1; intros h1 h5; auto.
(* trans case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; auto.
Qed.

Lemma aeq_proper : forall T T':uexp,
  seq0 (atom_ (aeq T T')) -> (proper T /\ proper T').
Proof.
intros T T' [n h1].
generalize T T' h1; clear h1 T T'.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T T' : uexp, seq_ n nil (atom_ (aeq T T')) ->
        (proper T /\ proper T'))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T T' h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- split; apply proper_lam; auto.
(* app case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; apply proper_app; auto.
Qed.

End proper_adeq.

(************)
(* Contexts *)
(************)

Section ctx_aeq_adeq.

(* Membership lemma used in adequacy of aeq *)
Lemma memb_aeq_adeq1 : forall (Gamma:list atm) (T T':uexp),
  xaG Gamma -> In (aeq T T') Gamma -> In (term T) Gamma.
Proof.
intros Gamma T T'; induction 1; try (simpl; tauto).
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | h2]].
- discriminate h2.
- injection h2; intros; subst; subst; simpl; auto.
- simpl; right; auto with hybrid.
Qed.

(* Membership lemma used in adequacy of aeq *)
Lemma memb_aeq_adeq2 : forall (Gamma:list atm) (T T':uexp),
  xaG Gamma -> In (aeq T T') Gamma -> In (term T') Gamma.
Proof.
intros Gamma; induction 1; try (simpl; tauto).
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | h2]].
- discriminate h2.
- injection h2; intros; subst; subst; simpl; auto.
- simpl; right; auto with hybrid.
Qed.

Lemma d_str_xa2x_term :
  forall (i:nat) (T x:uexp) (Gamma:list atm),
  seq_ i (term x::aeq x x::Gamma) (atom_ (term T)) ->
  seq_ i (term x::Gamma) (atom_ (term T)).
Proof.
intros i T x Gamma h.
apply term_strengthen_weaken with (term x::aeq x x::Gamma); auto.
clear h T i.
intro T; simpl; split.
- intros [h1 | [h1 | h1]]; auto.
  discriminate h1.
- intros [h1 | h1]; auto.
Qed.

End ctx_aeq_adeq.

(****************)
(* aeq Adequacy *)
(****************)

#[global] Hint Resolve nil_xa cons_xa memb_aeq_adeq1 memb_aeq_adeq2 : hybrid.

Section aeq_adeq.

Lemma aeq_term :
  forall (i:nat) (T T':uexp) (Gamma:list atm),
  xaG Gamma ->
  seq_ i Gamma (atom_ (aeq T T')) ->
  seq_ i Gamma (atom_ (term T)) /\ seq_ i Gamma (atom_ (term T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Gamma:list atm),
     xaG Gamma ->
     seq_ i Gamma (atom_ (aeq T T')) ->
     seq_ i Gamma (atom_ (term T)) /\ seq_ i Gamma (atom_ (term T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Gamma cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (ae_l_inv i Gamma M N H4); clear H4; intros [j [h1 h2]];
      subst.
    assert (h':forall x:uexp, proper x ->
        (seq_ j (term x::aeq x x::Gamma) (atom_ (term (M x))) /\
         seq_ j (term x::aeq x x::Gamma) (atom_ (term (N x))))).
    { intros x h1.
      apply h; eauto with hybrid; try lia.
      apply seq_thin_exch with (aeq x x::Gamma); auto.
      { intro a; simpl; tauto. }
      { apply h2; auto. }}
    split.
    * unfold seq_,atom_;
        apply s_bc with
            (All (fun x:uexp => (Imp (term x) (atom_ (term (M x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      specialize h' with (1:=h5); destruct h' as [h6 h7]; eauto with hybrid.
      apply d_str_xa2x_term; auto.
    * unfold seq_,atom_;
        apply s_bc with
            (All (fun x:uexp => (Imp (term x) (atom_ (term (N x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      specialize h' with (1:=h5); destruct h' as [h6 h7]; eauto with hybrid.
      apply d_str_xa2x_term; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (term M1)) (atom_ (term M2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (term N1)) (atom_ (term N2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- split; apply s_init; eauto with hybrid.
  (* applies memb_aeq_adeq1 and memb_aeq_adeq2 *)
Qed.

Lemma aeq_term_cor : forall T T':uexp, seq0 (atom_ (aeq T T')) ->
  (seq0 (atom_ (term T)) /\ seq0 (atom_ (term T'))).
Proof.
intros T T' [n h].
assert (h1:xaG nil); eauto with hybrid.
specialize aeq_term with (1:=h1) (2:=h); intros [h2 h3].
split; exists n; auto.
Qed.

End aeq_adeq.

(************)
(* Contexts *)
(************)

Section ctx_deq_adeq.

(* Context Relation for deq Adequacy and used in Completeness *)
Inductive dxG : list atm -> Prop :=
| nil_dx : dxG nil
| cons_dx : forall (Gamma:list atm) (x:uexp), proper x ->
    dxG Gamma ->
    dxG (deq x x::term x::Gamma).

(* Membership lemma used in adequacy of deq *)
Lemma memb_deq_adeq1 : forall (Gamma:list atm) (T T':uexp),
  dxG Gamma -> In (deq T T') Gamma -> In (term T) Gamma.
Proof.
intros Gamma T T'; induction 1; try (simpl; tauto).
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | h2]].
- injection h2; intros; subst; subst; simpl; auto.
- discriminate h2.
- simpl; right; auto with hybrid.
Qed.

(* Membership lemma used in adequacy of deq *)
Lemma memb_deq_adeq2 : forall (Gamma:list atm) (T T':uexp),
  dxG Gamma -> In (deq T T') Gamma -> In (term T') Gamma.
Proof.
intros Gamma; induction 1; try (simpl; tauto).
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | h2]].
- injection h2; intros; subst; subst; simpl; auto.
- discriminate h2.
- simpl; right; auto with hybrid.
Qed.

(* used in adequacy of deq *)
Lemma d_str_dx2x_term :
  forall (i:nat) (T x:uexp) (Gamma:list atm),
  seq_ i (deq x x::term x :: Gamma) (atom_ (term T)) ->
  seq_ i (term x :: Gamma) (atom_ (term T)).
Proof.
intros i T x Gamma h.
apply term_strengthen_weaken with (deq x x::term x::Gamma); auto.
clear h T i.
intro T; simpl; split.
- intros [h1 | [h1 | h1]]; try discriminate h1; auto.
- intros [h1 | h1]; auto.
Qed.

End ctx_deq_adeq.

(****************)
(* deq Adequacy *)
(****************)

Section deq_adeq.

Hint Resolve nil_dx cons_dx : hybrid.
Hint Resolve memb_deq_adeq1 memb_deq_adeq2 : hybrid.

Lemma deq_term :
  forall (i:nat) (T T':uexp) (Gamma:list atm),
  dxG Gamma ->
  seq_ i Gamma (atom_ (deq T T')) ->
  seq_ i Gamma (atom_ (term T)) /\ seq_ i Gamma (atom_ (term T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Gamma:list atm),
     dxG Gamma ->
     seq_ i Gamma (atom_ (deq T T')) ->
     seq_ i Gamma (atom_ (term T)) /\ seq_ i Gamma (atom_ (term T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Gamma cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (de_l_inv i Gamma M N H4); clear H4; intros [j [h1 h2]];
      subst.
    replace (j+2) with (j+1+1); try lia.
    assert (h':forall x:uexp, proper x ->
        (seq_ j (deq x x::term x::Gamma) (atom_ (term (M x))) /\
         seq_ j (deq x x::term x::Gamma) (atom_ (term (N x))))).
    { intros x h1.
      apply h; eauto with hybrid; try lia. }
    eauto with hybrid.
    split.
    * unfold seq_,atom_;
        apply s_bc with
            (All (fun x:uexp => (Imp (term x) (atom_ (term (M x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      apply seq_mono with j; auto; try lia.
      specialize h' with (1:=h5); destruct h' as [h6 h7]; eauto with hybrid.
      apply d_str_dx2x_term; auto.
    * unfold seq_,atom_;
        apply s_bc with
            (All (fun x:uexp => (Imp (term x) (atom_ (term (N x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      apply seq_mono with j; auto; try lia.
      specialize h' with (1:=h5); destruct h' as [h6 h7]; eauto with hybrid.
      apply d_str_dx2x_term; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (term M1)) (atom_ (term M2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (term N1)) (atom_ (term N2)));
        auto with hybrid.
      apply s_and; auto.
  (* refl case *)
  + split; apply seq_mono with i0; auto; try lia.
  (* symm case *)
  + assert (hi:i0<i0+1); try lia.
    specialize h with (1:=hi) (2:=cInv) (3:=H3); destruct h as [h1 h2].
    split; apply seq_mono with i0; auto; try lia.
  (* trans case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split; apply seq_mono with i; auto; try lia.
(* context case *)
- split; apply s_init; eauto with hybrid.
  (* applies memb_deq_adeq1 and memb_deq_adeq2 *)
Qed.

Lemma deq_term_cor : forall T T':uexp, seq0 (atom_ (deq T T')) ->
  (seq0 (atom_ (term T)) /\ seq0 (atom_ (term T'))).
Proof.
intros T T' [n h].
assert (h1:dxG nil); eauto with hybrid.
specialize deq_term with (1:=h1) (2:=h); intros [h2 h3].
split; exists n; auto.
Qed.

End deq_adeq.


Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.SetoidClass.
Require Export Coq.Classes.Morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.

Ltac app P := let H:= fresh "YMCA" in
     assert (H := P);
     simpl in H;
     apply H;
     clear H; simpl; auto.

Ltac rew P := let H:=fresh "YMCA" in
     assert (H := P);
     simpl in H;
     rewrite H;
     clear H;
     simpl;
     auto.

Ltac rerew P := let H:=fresh "YMCA" in
     assert (H := P);
     simpl in H;
     rewrite <- H;
     clear H;
     simpl;
     auto.

Ltac app_all := match goal with
        | [H:_|-_] => apply H end.

Ltac unf_Proper := match goal with
        | [ |- Proper _ _ ] => unfold Proper; repeat red end.

Ltac rew_hyp_2 := match goal with
        | [ H : forall _ _ , _ = _ |- _ ] => rewrite H end.

Ltac rew_hyp := match goal with
        | [ H : forall _ , _ = _ |- _ ] => rewrite H end.

Ltac rew_setoid := match goal with
	| [H : forall _ , _ == _ |- _ ] => rewrite H end.

Ltac rew_all := match goal with
        | [H : _ |- _ ] => rewrite H end.

Ltac rerew_all := match goal with
        | [H : _ |- _ ] => rewrite <- H end.

Ltac rew_set := match goal with
        | [H : _ == _ |- _ ] => rewrite H end.

Ltac elim_unit := match goal with
        | [ H : unit |- _ ] => destruct H end.

Ltac elim_conj := match goal with
        | [ H : _ /\ _  |- _  ] => destruct H; intros end.

Ltac elim_conjs := repeat elim_conj.

Ltac mauto := simpl; intros; try unf_Proper; simpl; intros;
              elim_conjs; auto.

Section setoid_lemmata.

Variable A:Type.
Variable R: Setoid A.

Lemma setoid_refl : forall a, a == a.
Proof.
  destruct R.
  apply setoid_equiv.
Qed.

Lemma setoid_sym : forall a b, a == b -> b == a.
Proof.
  destruct R.
  apply setoid_equiv.
Qed.

Lemma setoid_trans : forall a b c,
           a == b -> b == c -> a == c.
Proof.
  destruct R.
  apply setoid_equiv.
Qed.

End setoid_lemmata.

Hint Resolve setoid_refl setoid_sym setoid_trans : setoid.
Hint Rewrite setoid_trans : setoid.

Ltac setoid := intros; mauto; eauto with setoid.

Lemma eq_trans_2 (A:Type)(a b c : A) : a = b -> b = c -> c = a.
Proof.
  congruence.
Qed.

Lemma eq_eq_rect A (z : A) (P : A -> Type)
       (f g : P z) (y : A) (e : z = y):
   f = g -> eq_rect z P f y e = eq_rect z P g y e.
Proof.
  intros;
  subst;
  auto.
Qed.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Dots.

Require Import ValidationUtil.
Require Import NatLemmas.
Require Import LevelLemmas.

Hint Rewrite def_iexists : prepare.

Lemma iexistsForm_valid : iexistsForm_obligation.
Proof.
prepare.
intros G a i k ext1 ext0 Hk Ha.
apply tr_exist_formation; auto.
Qed.

Lemma iexistsEq_valid : iexistsEq_obligation.
Proof.
prepare.
intros G a b i k l ext1 ext0 Hkl Hab.
apply tr_exist_formation; auto.
Qed.

Lemma iexistsFormUniv_valid : iexistsFormUniv_obligation.
Proof.
prepare.
intros G a i j k ext2 ext1 ext0 Hk Hleq Ha.
so (lleq_explode _#5 Hleq) as (Hleq' & Hi & Hj).
apply tr_exist_formation_univ; auto.
Qed.

Lemma iexistsEqUniv_valid : iexistsEqUniv_obligation.
Proof.
prepare.
intros G a b i j k l ext2 ext1 ext0 Hkl Hleq Hab.
so (lleq_explode _#5 Hleq) as (Hleq' & Hi & Hj).
apply tr_exist_formation_univ; auto.
Qed.

Lemma iexistsIntroOf_valid : iexistsIntroOf_obligation.
Proof.
prepare.
intros G a b i k m ext3 ext2 ext1 ext0 Hk Ha Hb Hm.
eapply tr_exist_intro; eauto.
Qed.

Lemma iexistsIntroEq_valid : iexistsIntroEq_obligation.
Proof.
prepare.
intros G a b i k m n ext3 ext2 ext1 ext0 Hk Ha Hb Hmn.
eapply tr_exist_intro; eauto.
Qed.

Lemma iexistsIntro_valid : iexistsIntro_obligation.
Proof.
prepare.
intros G a b i k ext2 ext1 ext0 m Hk Ha Hb Hm.
eapply tr_exist_intro; eauto.
Qed.

Lemma iexistsElimOf_valid : iexistsElimOf_obligation.
Proof.
prepare.
intros G a b i k m p ext3 ext2 ext1 ext0 Hk Ha Hp Hm.
eapply tr_exist_elim; eauto.
Qed.

Lemma iexistsElimEq_valid : iexistsElimEq_obligation.
Proof.
prepare.
intros G a b i k m n p q ext3 ext2 ext1 ext0 Hk Ha Hpq Hmn.
eapply tr_exist_elim; eauto.
Qed.

Lemma iexistsElim_valid : iexistsElim_obligation.
Proof.
prepare.
intros G a b i k m ext2 ext1 p ext0 Hhyg Hk Ha Hp Hm.
replace (subst (dot m (dot triv (sh 0))) p) with (subst1 m (subst (under 1 (dot triv id)) p)) by (simpsub; auto).
eapply tr_exist_elim; eauto.
simpsub.
so (subst_into_absent_single _ 1 p triv Hhyg) as H.
simpsubin H.
cbn [Nat.add] in H.
rewrite -> H.
auto.
Qed.

Lemma iexistsElimIstype_valid : iexistsElimIstype_obligation.
Proof.
prepare.
intros G a b i k m ext3 ext2 ext1 ext0 Hk Ha Hb Hm.
eapply tr_exist_elim_eqtype; eauto.
Qed.

Lemma iexistsElimEqtype_valid : iexistsElimEqtype_obligation.
Proof.
prepare.
intros G a b c i k m n ext3 ext2 ext1 ext0 Hk Ha Hc Hmn.
eapply tr_exist_elim_eqtype; eauto.
Qed.


Require Import Essentials.Notations Essentials.Arith Essentials.Types.
Require Import Lattice.MLattice Metrics.UltraMetric
        Metrics.Cauchy Metrics.Limit
        Metrics.Mappings Metrics.Complete_UltraMetric.
Require Import Categories.Category.Category
        Categories.Basic_Cons.Terminal.

Require Import Metrics.CBULt.CBULt.

Section CBULt_Terminal.
  Context {L : MLattice}.

  Program Definition Terminal_UM : UltraMetric L :=
    {|
      UM_Carrier := Unit;
      UM_distance := fun x y => (⊥)%lattice
    |}.

  Next Obligation.
  Proof.
    apply Unit_Singleton.
  Qed.

  Program Definition Terminal_CUM : Complete_UltraMetric L :=
    {|
      CUM_UM := Terminal_UM;
      CUM_complete :=
        fun chs =>
          {|
            Lim := TT
          |}
    |}.

  Next Obligation.
  Proof.
    exists 0.
    intros n H.
    apply ML_appr_pos.
    apply (projT2 ε).
  Qed.

  Local Hint Extern 1 => apply NonExpansive_eq_simplify.
  Local Hint Extern 1 => apply Unit_Singleton.

  Program Instance CBULt_Terminal : Terminal (CBULt L) :=
    {|
      terminal := Terminal_CUM;
      t_morph := fun A => {|NE_fun := fun _ => TT|}
    |}.

End CBULt_Terminal.