(* Alumno: Agustín Mista *)
(* Fecha:        3/10/17 *)

(*
  Esta táctica elimina varios /\ a la vez, en goals de la forma:
       A1 ∧ A2 ∧ ... ∧ An
  generando un sub-goal para cada Ai.
*)
Ltac split_many :=
  match goal with
    |- _ => split; repeat try split
  end.

(* ------------------------------ *)
(*          Ejercicio 4           *)
(* ------------------------------ *)

Section Ejercicio3.
Variable A B C: Set.

Definition apply : (A -> B) -> A -> B :=
  fun f x => f x.

Definition o : (B -> C) -> (A -> B) -> (A -> C) :=
  fun f g x => f (g x).

Definition twice : (A -> A) -> A -> A :=
  fun f x => f (f x).

Definition apply' : forall X Y : Set, (X -> Y) -> X -> Y :=
  fun (X Y : Set) (f : X -> Y) (x : X) => f x.

Definition o' : forall X Y Z : Set, (Y -> Z) -> (X -> Y) -> (X -> Z) :=
  fun (X Y Z : Set) (f : Y -> Z) (g : X -> Y) (x : X) => f (g x).

Definition twice' : forall X : Set, (X -> X) -> X -> X :=
  fun (X : Set) (f : X -> X) (x : X) => f (f x).

End Ejercicio3.

Section Ejercicio4.

Variable A: Set.

Definition id : A -> A := fun (x : A) => x.

Theorem e4 : forall x : A, (o A A A id id) x = id x.
Proof. reflexivity. Qed.

Theorem e4' : forall x : A, (o A A A id id) x = id x.
Proof. reflexivity. Qed.

Theorem e4'' : forall x : A, (o A A A id id) x = id x.
Proof. reflexivity. Qed.

End Ejercicio4.

(* ------------------------------ *)
(*          Ejercicio 5           *)
(* ------------------------------ *)

Section Ejercicio5.

(* 5.1 *)
Definition opI : forall A : Set, A -> A
    := id.

Definition opK : forall A B : Set, A -> B -> A
  := fun (A B : Set) (a : A) (b : B) => a.

Definition opS : forall A B C : Set, (A -> B -> C) -> (A -> B) -> A -> C
  := fun (A B C : Set) (f : A -> B -> C) (g : A -> B) (x : A) => f x (g x).

(* 5.2 *)
(* Para formalizar el siguiente lema, determine los tipos ?1 ... ?8 adecuados *)
Lemma e52 : forall A B : Set, opS A (B -> A) A (opK A (B -> A)) (opK A B) = opI A.
Proof. reflexivity. Qed.

End Ejercicio5.

(* ------------------------------ *)
(*          Ejercicio 10          *)
(* ------------------------------ *)

Section Ejercicio10.

Parameter Array : Set -> nat -> Set.
Parameter emptyA : forall X : Set, Array X 0.
Parameter addA : forall (X : Set) (n : nat), X -> Array X n -> Array X (S n).

Parameter Matrix : Set -> nat -> Set.
Parameter emptyM : forall X : Set, Matrix X 0.
Parameter addM : forall (X : Set) (n : nat),
    Matrix X n -> Array X (n + 1) -> Matrix X (n + 1).

Definition M1 := addM nat 0 (emptyM nat) (addA nat 0 3 (emptyA nat)).
Definition M2 := addM nat 1 M1 (addA nat 1 2 (addA nat 0 3 (emptyA nat))).
Definition M3 := addM nat 2 M2 (addA nat 2 1 (addA nat 1 2 (addA nat 0 3 (emptyA nat)))).

Check M3.

End Ejercicio10.

(* ------------------------------ *)
(*          Ejercicio 11          *)
(* ------------------------------ *)

Section Ejercicio11.

Parameter AVLNat : forall n : nat, Set.

(* 11.1 *)
Parameter emptyAVL : AVLNat 0.

(* 11.2 *)
Parameter addAVL_eq : forall n, AVLNat n -> nat -> AVLNat n -> AVLNat (n + 1).
Parameter addAVL_lt : forall n, AVLNat n -> nat -> AVLNat (n + 1) -> AVLNat (n + 1).
Parameter addAVL_gt : forall n, AVLNat (n + 1) -> nat -> AVLNat n -> AVLNat (n + 1).

(* 11.3 *)
Definition avl : AVLNat 2
  := addAVL_eq 1
       (addAVL_eq 0 emptyAVL 2 emptyAVL)
       1
       (addAVL_eq 0 emptyAVL 3 emptyAVL).

(* 11.4 *)
Parameter AVL : forall (T : Type) (n : nat), Set.
Parameter emptyAVL' : forall (T : Type), AVL T 0.
Parameter addAVL_eq' : forall T n, AVL T n -> T -> AVL T n -> AVL T (n + 1).
Parameter addAVL_lt' : forall T n, AVL T n -> T -> AVL T (n + 1) -> AVL T (n + 1).
Parameter addAVL_gt' : forall T n, AVL T (n + 1) -> T -> AVL T n -> AVL T (n + 1).

End Ejercicio11.

(* ------------------------------ *)
(*          Ejercicio 15          *)
(* ------------------------------ *)

Section Ejercicio15.

Variable U : Set.
Variable e : U.
Variable A B : U -> Prop.
Variable P : Prop.
Variable R : U -> U -> Prop.

Lemma Ej315_1 : (forall x : U, A x -> B x) -> (forall x : U, A x)
                -> forall x : U, B x.
Proof.
  intros. exact (H x (H0 x)).
Qed.

Lemma Ej315_2 : forall x : U, A x -> ~ (forall x : U, ~ A x).
Proof.
  unfold not.
  intros. exact (H0 x H).
Qed.

Lemma Ej315_3 : (forall x : U, P -> A x) -> P -> forall x : U, A x.
Proof. intros. exact (H x H0). Qed.

Lemma Ej315_4 : (forall x y : U, R x y) -> forall x : U, R x x.
Proof. intros. exact (H x x). Qed.

Lemma Ej315_5 : (forall x y: U, R x y -> R y x) -> forall z : U, R e z -> R z e.
Proof. intros. exact (H e z H0). Qed.

End Ejercicio15.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (mult lv1 (Succ lv2))) (plus (plus (mult lv2 lv1) lv1) lv0)).
Admitted.
QuickChick conj13synthconj6.


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Proofs                   *
* Brian Aydemir & Arthur Charguéraud, July 2007, Coq v8.1                  *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory
  STLC_Core_Definitions
  STLC_Core_Infrastructure.

(* ********************************************************************** *)
(** * Proofs *)

(** Typing is preserved by weakening. *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. gen_eq (E & G) as H. gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply* typing_app.
Qed.

(** Typing is preserved by substitution. *)

Lemma typing_subst : forall F U E t T z u,
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Typt Typu. gen_eq (E & z ~ U & F) as G. gen F.
  induction Typt; introv Equ; subst; simpl subst.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs as y.
   rewrite* subst_open_var. apply_ih_bind* H0.
  apply* typing_app.
Qed.

(** Preservation (typing is preserved by reduction). *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen t'.
  induction Typ; introv Red; inversions Red.
  inversions Typ1. pick_fresh x. rewrite* (@subst_intro x).
   apply_empty* typing_subst.
  apply* typing_app.
  apply* typing_app.
Qed.

(** Progress (a well-typed term is either a value or it can
  take a step of reduction). *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq (empty : env) as E. poses Typ' Typ.
  induction Typ; intros; subst.
  contradictions.
  left*.
  right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      inversions Typ1; inversions Val1. exists* (t0 ^^ t2).
      exists* (trm_app t1 t2').
    exists* (trm_app t1' t2).
Qed.


Require Import Coq.Arith.Arith.

Require Import Axioms.

Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Ordinal.
Require Import Page.

Import List.ListNotations.

Section object.

Variable object : Type.

Inductive operator : list nat -> Type :=
| oper_univ        : operator [0]
| oper_cty         : operator [0]
| oper_con         : operator [0; 0]

| oper_karrow      : operator [0; 0]
| oper_arrow       : operator [0; 0]
| oper_pi          : operator [0; 1]
| oper_clam        : operator [0; 1]
| oper_capp        : operator [0; 0]
| oper_ctlam       : operator [0; 1; 0]
| oper_ctapp       : operator [0; 0]
| oper_lam         : operator [1]
| oper_app         : operator [0; 0]

| oper_intersect   : operator [0; 1]

| oper_fut         : operator [0]
| oper_cnext       : operator [0]
| oper_cprev       : operator [0]
| oper_next        : operator [0]
| oper_prev        : operator [0]

| oper_rec         : operator [1]

| oper_equal       : operator [0; 0; 0]
| oper_triv        : operator nil

| oper_eqtype      : operator [0; 0]

| oper_subtype     : operator [0; 0]

| oper_kuniv       : operator [0]

| oper_all         : operator [0; 0; 1]
| oper_alltp       : operator [1]

| oper_exist       : operator [0; 0; 1]

| oper_mu          : operator [1]
| oper_ispositive  : operator [1]
| oper_isnegative  : operator [1]

| oper_voidtp      : operator nil

| oper_unittp      : operator nil
| oper_cunit       : operator nil

| oper_booltp      : operator nil
| oper_btrue       : operator nil
| oper_bfalse      : operator nil
| oper_bite        : operator [0; 0; 0]

| oper_prod        : operator [0; 0]
| oper_sigma       : operator [0; 1]
| oper_cpair       : operator [0; 0]
| oper_cpi1        : operator [0]
| oper_cpi2        : operator [0]
| oper_ppair       : operator [0; 0]
| oper_ppi1        : operator [0]
| oper_ppi2        : operator [0]

| oper_set         : operator [0; 1]

| oper_quotient    : operator [0; 2]

| oper_guard       : operator [0; 0]

| oper_wt          : operator [0; 1]

(* Candidates used for impredicative quantification. *)
| oper_ext         : object -> operator nil

(* Degenerate candidates used for inductive types. *)
| oper_extt        : object -> operator nil
.

Inductive term : Type :=
| var : nat -> term
| oper : forall a, operator a -> row a -> term

with row : list nat -> Type :=
| rw_nil : row nil
| rw_cons : forall i a, term -> row a -> row (i :: a)
.

Scheme term_mut_ind := Induction for term Sort Prop
with   row_mut_ind := Induction for row Sort Prop.
Combined Scheme syntax_ind from term_mut_ind, row_mut_ind.

Scheme term_mut_rect := Induction for term Sort Type
with   row_mut_rect := Induction for row Sort Type.

Lemma row_nil_invert : forall (r : row nil), r = rw_nil.
Proof.
intros r.
apply eq_dep_impl_eq_snd.
set (a := nil) in r |- * at 1.
assert (a = nil) as Heq by reflexivity.
clearbody a.
revert Heq.
cases r; auto.
intros; discriminate.
Qed.

Lemma row_cons_invert :
  forall i a (r : row (cons i a)),
    exists m (s : row a),
      r = rw_cons i a m s.
Proof.
intros i a r.
cut (exists m s, eq_dep _ row (cons i a) r (cons i a) (rw_cons i a m s)).
  {
  intros (m & s & Heq).
  exists m, s.
  exact (eq_dep_impl_eq_snd _#5 Heq).
  }
set (b := cons i a) in r |- * at 1.
assert (b = cons i a) as Heq by reflexivity.
clearbody b.
revert Heq.
cases r; try (intros; discriminate).
intros i' a' m r Heq.
injection Heq.
intros -> ->.
exists m, r.
apply eq_dep_refl.
Qed.

Lemma row_invert_auto :
  forall a (r : row a),
    list_rect (fun a => (row a -> Prop) -> Prop)
      (fun P => P rw_nil)
      (fun i a IH P =>
         exists m,
           IH (fun r => P (rw_cons i a m r)))
      a
      (eq r).
Proof.
intros a.
induct a.

(* nil *)
{
intro r.
cbn.
apply row_nil_invert.
}

(* cons *)
{
intros i a IH rr.
cbn.
so (row_cons_invert _ _ rr) as (m & r & ->).
exists m.
force_exact (IH r).
f_equal.
fextensionality 1.
intro r'.
pextensionality.
  {
  intros <-; auto.
  }

  {
  intros Heq.
  injection Heq.
  intro H.
  injectionT H.
  auto.
  }
}
Qed.

Inductive hyp : Type :=
| hyp_tpl : hyp
| hyp_tp  : hyp
| hyp_tml : term -> hyp
| hyp_tm  : term -> hyp
| hyp_emp : hyp
.

Definition context := list hyp.

Inductive judgement : Type :=
| deq : (* tm *) term -> term -> (* cn *) term -> judgement
.

Fixpoint traverse (resolve : nat -> nat -> term) (i : nat) (m : term) {struct m} : term
  :=
  (match m with
   | var j => resolve i j
   | oper a t r => oper a t (traverse_row resolve i a r)
   end)

with traverse_row (resolve : nat -> nat -> term) (i : nat) (a : list nat) (r : row a) {struct r} : row a
  :=
  (match r
   in row a
   return row a
   with
   | rw_nil => rw_nil
   | rw_cons j a m r => rw_cons j a (traverse resolve (j+i) m) (traverse_row resolve i a r)
   end)
.

Lemma traverse_var :
  forall resolve i j,
    traverse resolve i (var j) = resolve i j.
Proof.
auto.
Qed.

Lemma traverse_oper :
  forall resolve i a t r,
    traverse resolve i (oper a t r)
    =
    oper a t (traverse_row resolve i a r).
Proof.
intros; reflexivity.
Qed.

Lemma traverse_row_cons :
  forall resolve i j a m r,
    traverse_row resolve i (cons j a) (rw_cons j a m r)
    =
    rw_cons j a
      (traverse resolve (j+i) m)
      (traverse_row resolve i a r).
Proof.
intros; reflexivity.
Qed.

Lemma traverse_row_nil :
  forall resolve i,
    traverse_row resolve i nil rw_nil = rw_nil.
Proof.
intros; reflexivity.
Qed.

Lemma traverse_parametric :
  forall (P : nat -> nat -> Prop) resolve resolve',
    (forall i i', P i i' -> P (S i) (S i'))
    -> (forall i i' j, P i i' -> resolve i j = resolve' i' j)
    -> forall i i' t, P i i' -> traverse resolve i t = traverse resolve' i' t.
Proof.
intros P resolve resolve' Pcomp.
revert resolve resolve'.
assert (forall j i i', P i i' -> P (j + i) (j + i')) as Hcomp'.
  intro j.
  induct j.
  (* 0 *)
  intros i i' H.
  exact H.

  (* S *)
  intros j IH i i' HP.
  simpl.
  auto; done.
intros resolve resolve' Hres i i' t.
revert t i i'.
apply
  (term_mut_ind
     (fun m => forall i i', P i i' -> traverse resolve i m = traverse resolve' i' m)
     (fun a r => forall i i', P i i' -> traverse_row resolve i a r = traverse_row resolve' i' a r));
try (intros; simpl; eauto; f_equal; eauto; done).
Qed.

Lemma traverse_id :
  forall resolve,
    (forall i j, resolve i j = var j)
    -> forall i t, traverse resolve i t = t.
Proof.
intros resolve Hres i m.
revert m i.
apply
  (term_mut_ind
     (fun m => forall i, traverse resolve i m = m)
     (fun a r => forall i, traverse_row resolve i a r = r));
intros; simpl; f_equal; eauto.
Qed.

Lemma traverse_compose :
  forall resolve resolve' i t,
    traverse resolve i (traverse resolve' i t)
    = traverse
      (fun i' j => traverse resolve i' (resolve' i' j))
      i t.
Proof.
intros resolve resolve' i m.
revert m i.
apply
  (term_mut_ind
     (fun m =>
        forall i,
          traverse resolve i (traverse resolve' i m)
          = traverse (fun i' j => traverse resolve i' (resolve' i' j)) i m)
     (fun a r =>
        forall i,
          traverse_row resolve i a (traverse_row resolve' i a r)
          = traverse_row (fun i' j => traverse resolve i' (resolve' i' j)) i a r));
intros; simpl; f_equal; eauto.
Qed.

(* Obsolete *)
Ltac invert_row_cons r :=
match type of r with
| row ?a =>
    let i := fresh "i"
    in let x := fresh "a"
    in let m := fresh "m"
    in let Heq := fresh "Heq"
    in
      remember a as x eqn:Heq in r;
      revert Heq;
      cases r; [intro Heq; discriminate Heq |];
      intros i' x m r Heq;
      injection Heq;
      clear Heq;
      intros -> ->;
      revert m r
end.

(* Obsolete *)
Ltac invert_row_nil r :=
let x := fresh "a"
in let Heq := fresh "Heq"
in
  remember (@nil nat) as x eqn:Heq in r;
  revert Heq;
  cases r; [| intros ? ? ? ? Heq; discriminate Heq];
  intros _.

Inductive Forallr (P : term -> Type) : forall a, row a -> Type :=
| Forallr_nil
    : Forallr P nil rw_nil

| Forallr_cons {i a m r}
    : P m
      -> Forallr P a r
      -> Forallr P (cons i a) (rw_cons i a m r)
.

Lemma term_row_rect :
  forall (P : term -> Type),
    (forall i, P (var i))
    -> (forall a t r, Forallr P a r -> P (oper a t r))
    -> forall m, P m.
Proof.
intros P H1 H2 m.
apply (term_mut_rect P (Forallr P)); eauto using Forallr.
Qed.

Lemma oper_injection :
  forall a t t' r r',
    oper a t r = oper a t' r'
    -> t = t' /\ r = r'.
Proof.
intros a t t' r r' Heq.
injection Heq.
intros Heqr Heqt.
destruct (eq_dep_impl_eq _#6 (EqdepFacts.eq_sigT_eq_dep _#6 Heqt)) as (h & Heqt').
substrefl h.
cbn in Heqt'.
destruct (eq_dep_impl_eq _#6 (EqdepFacts.eq_sigT_eq_dep _#6 Heqr)) as (h & Heqr').
substrefl h.
cbn in Heqr'.
auto.
Qed.

Lemma rw_cons_injection :
  forall j a m m' r r',
    rw_cons j a m r = rw_cons j a m' r'
    -> m = m' /\ r = r'.
Proof.
intros j a m m' r r' Heq.
injection Heq.
intros Heq' Heqm.
destruct (eq_dep_impl_eq _#6 (EqdepFacts.eq_sigT_eq_dep _#6 Heq')) as (h & Heq'').
substrefl h.
cbn in Heq''.
auto.
Qed.

(* obsolete *)
Lemma invertrow :
  forall l (r : row l),
    (fix P (l : list nat) : (row l -> Type) -> Type :=
       match l
         as l
         return (row l -> Type) -> Type
       with
       | nil => fun Q => Q rw_nil

       | cons a l' =>
           fun Q =>
             existsT x,
               P l' (fun r => Q (rw_cons _ _ x r))
       end)
    l (fun r' => r = r').
Proof.
intros l.
induct l.

(* nil *)
{
intro r.
cases r.
reflexivity.
}

(* cons *)
{
intros n a IH r.
cases r.
intros n' a' t r Heq.
injection Heq.
intros -> ->.
substrefl Heq.
exists t.
so (IH r) as H.
replace (fun r' => rw_cons n a t r = rw_cons n a t r') with (fun r' => r = r').
2:{
  fextensionality 1.
  intro r''.
  pextensionality.
  - intro.
    subst r''.
    reflexivity.

  - intro Heq.
    injectionc Heq.
    intro Heq.
    eapply inj_pair2_UIP; eauto.
    intros; apply proof_irrelevance; done.
  }
exact H.
}
Qed.

End object.

Arguments var {object}.
Arguments oper {object}.
Arguments rw_nil {object}.
Arguments rw_cons {object}.

Arguments hyp {object}.
Arguments context {object}.
Arguments judgement {object}.

Definition univ {obj} m            : @term obj := oper _ (oper_univ _) (rw_cons _ _ m rw_nil).
Definition cty {obj} m             : @term obj := oper _ (oper_cty _) (rw_cons _ _ m rw_nil).
Definition con {obj} m1 m2         : @term obj := oper _ (oper_con _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition karrow {obj} m1 m2       : @term obj := oper _ (oper_karrow _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition arrow {obj} m1 m2       : @term obj := oper _ (oper_arrow _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition pi {obj} m1 m2          : @term obj := oper _ (oper_pi _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition clam {obj} m1 m2        : @term obj := oper _ (oper_clam _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition capp {obj} m1 m2        : @term obj := oper _ (oper_capp _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition ctlam {obj} m1 m2 m3  : @term obj := oper _ (oper_ctlam _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition ctapp {obj} m1 m2       : @term obj := oper _ (oper_ctapp _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition lam {obj} m             : @term obj := oper _ (oper_lam _) (rw_cons _ _ m rw_nil).
Definition app {obj} m1 m2         : @term obj := oper _ (oper_app _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition intersect {obj} m1 m2   : @term obj := oper _ (oper_intersect _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition fut {obj} m             : @term obj := oper _ (oper_fut _) (rw_cons _ _ m rw_nil).
Definition cnext {obj} m           : @term obj := oper _ (oper_cnext _) (rw_cons _ _ m rw_nil).
Definition cprev {obj} m           : @term obj := oper _ (oper_cprev _) (rw_cons _ _ m rw_nil).
Definition next {obj} m            : @term obj := oper _ (oper_next _) (rw_cons _ _ m rw_nil).
Definition prev {obj} m            : @term obj := oper _ (oper_prev _) (rw_cons _ _ m rw_nil).
Definition rec {obj} m             : @term obj := oper _ (oper_rec _) (rw_cons _ _ m rw_nil).
Definition equal {obj} m1 m2 m3    : @term obj := oper _ (oper_equal _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition triv {obj}              : @term obj := oper _ (oper_triv _) rw_nil.
Definition eqtype {obj} m1 m2      : @term obj := oper _ (oper_eqtype _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition subtype {obj} m1 m2     : @term obj := oper _ (oper_subtype _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition kuniv {obj} m           : @term obj := oper _ (oper_kuniv _) (rw_cons _ _ m rw_nil).
Definition all {obj} m1 m2 m3      : @term obj := oper _ (oper_all _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition alltp {obj} m1          : @term obj := oper _ (oper_alltp _) (rw_cons _ _ m1 rw_nil).
Definition exist {obj} m1 m2 m3    : @term obj := oper _ (oper_exist _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition mu {obj} m              : @term obj := oper _ (oper_mu _) (rw_cons _ _ m rw_nil).
Definition ispositive {obj} m      : @term obj := oper _ (oper_ispositive _) (rw_cons _ _ m rw_nil).
Definition isnegative {obj} m      : @term obj := oper _ (oper_isnegative _) (rw_cons _ _ m rw_nil).
Definition voidtp {obj}            : @term obj := oper _ (oper_voidtp _) rw_nil.
Definition unittp {obj}            : @term obj := oper _ (oper_unittp _) rw_nil.
Definition cunit {obj}             : @term obj := oper _ (oper_cunit _) rw_nil.
Definition booltp {obj}            : @term obj := oper _ (oper_booltp _) rw_nil.
Definition btrue {obj}             : @term obj := oper _ (oper_btrue _) rw_nil.
Definition bfalse {obj}            : @term obj := oper _ (oper_bfalse _) rw_nil.
Definition bite {obj} m1 m2 m3     : @term obj := oper _ (oper_bite _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition prod {obj} m1 m2        : @term obj := oper _ (oper_prod _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition sigma {obj} m1 m2       : @term obj := oper _ (oper_sigma _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition cpair {obj} m1 m2       : @term obj := oper _ (oper_cpair _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition cpi1 {obj} m            : @term obj := oper _ (oper_cpi1 _) (rw_cons _ _ m rw_nil).
Definition cpi2 {obj} m            : @term obj := oper _ (oper_cpi2 _) (rw_cons _ _ m rw_nil).
Definition ppair {obj} m1 m2       : @term obj := oper _ (oper_ppair _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition ppi1 {obj} m            : @term obj := oper _ (oper_ppi1 _) (rw_cons _ _ m rw_nil).
Definition ppi2 {obj} m            : @term obj := oper _ (oper_ppi2 _) (rw_cons _ _ m rw_nil).
Definition set {obj} m1 m2         : @term obj := oper _ (oper_set _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition quotient {obj} m1 m2    : @term obj := oper _ (oper_quotient _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition guard {obj} m1 m2       : @term obj := oper _ (oper_guard _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition wt {obj} m1 m2          : @term obj := oper _ (oper_wt _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition ext {obj} x             : @term obj := oper _ (oper_ext _ x) rw_nil.
Definition extt {obj} x            : @term obj := oper _ (oper_extt _ x) rw_nil.

Definition deqtype {object} a b := @deq object triv triv (eqtype a b).
Definition dsubtype {object} a b := @deq object triv triv (subtype a b).

Arguments hyp_tpl  {object}.
Arguments hyp_tp {object}.
Arguments hyp_tml {object}.
Arguments hyp_tm {object}.
Arguments hyp_emp {object}.
Arguments deq {object}.

(* The choice here is arbitrary.  Any value would do. *)
Definition arb {object} := @triv object.

Inductive same_operator {A B : Type} : forall a b, operator A a -> operator B b -> Prop :=
| same_univ :
    same_operator [0] [0] (oper_univ A) (oper_univ B)

| same_cty :
    same_operator [0] [0] (oper_cty A) (oper_cty B)

| same_con :
    same_operator [0; 0] [0; 0] (oper_con A) (oper_con B)

| same_karrow :
    same_operator [0; 0] [0; 0] (oper_karrow A) (oper_karrow B)

| same_arrow :
    same_operator [0; 0] [0; 0] (oper_arrow A) (oper_arrow B)

| same_pi :
    same_operator [0; 1] [0; 1] (oper_pi A) (oper_pi B)

| same_clam :
    same_operator [0; 1] [0; 1] (oper_clam A) (oper_clam B)

| same_capp :
    same_operator [0; 0] [0; 0] (oper_capp A) (oper_capp B)

| same_ctlam :
    same_operator [0; 1; 0] [0; 1; 0] (oper_ctlam A) (oper_ctlam B)

| same_ctapp :
    same_operator [0; 0] [0; 0] (oper_ctapp A) (oper_ctapp B)

| same_lam :
    same_operator [1] [1] (oper_lam A) (oper_lam B)

| same_app :
    same_operator [0; 0] [0; 0] (oper_app A) (oper_app B)

| same_intersect :
    same_operator [0; 1] [0; 1] (oper_intersect A) (oper_intersect B)

| same_fut :
    same_operator [0] [0] (oper_fut A) (oper_fut B)

| same_cnext :
    same_operator [0] [0] (oper_cnext A) (oper_cnext B)

| same_cprev :
    same_operator [0] [0] (oper_cprev A) (oper_cprev B)

| same_next :
    same_operator [0] [0] (oper_next A) (oper_next B)

| same_prev :
    same_operator [0] [0] (oper_prev A) (oper_prev B)

| same_rec :
    same_operator [1] [1] (oper_rec A) (oper_rec B)

| same_equal :
    same_operator [0; 0; 0] [0; 0; 0] (oper_equal A) (oper_equal B)

| same_triv :
    same_operator nil nil (oper_triv A) (oper_triv B)

| same_eqtype :
    same_operator [0; 0] [0; 0] (oper_eqtype A) (oper_eqtype B)

| same_subtype :
    same_operator [0; 0] [0; 0] (oper_subtype A) (oper_subtype B)

| same_kuniv :
    same_operator [0] [0] (oper_kuniv A) (oper_kuniv B)

| same_all :
    same_operator [0; 0; 1] [0; 0; 1] (oper_all A) (oper_all B)

| same_alltp :
    same_operator [1] [1] (oper_alltp A) (oper_alltp B)

| same_exist :
    same_operator [0; 0; 1] [0; 0; 1] (oper_exist A) (oper_exist B)

| same_mu :
    same_operator [1] [1] (oper_mu A) (oper_mu B)

| same_ispositive :
    same_operator [1] [1] (oper_ispositive A) (oper_ispositive B)

| same_isnegative :
    same_operator [1] [1] (oper_isnegative A) (oper_isnegative B)

| same_voidtp :
    same_operator nil nil (oper_voidtp A) (oper_voidtp B)

| same_unittp :
    same_operator nil nil (oper_unittp A) (oper_unittp B)

| same_cunit :
    same_operator nil nil (oper_cunit A) (oper_cunit B)

| same_booltp :
    same_operator nil nil (oper_booltp A) (oper_booltp B)

| same_btrue :
    same_operator nil nil (oper_btrue A) (oper_btrue B)

| same_bfalse :
    same_operator nil nil (oper_bfalse A) (oper_bfalse B)

| same_bite :
    same_operator [0; 0; 0] [0; 0; 0] (oper_bite A) (oper_bite B)

| same_prod :
    same_operator [0; 0] [0; 0] (oper_prod A) (oper_prod B)

| same_sigma :
    same_operator [0; 1] [0; 1] (oper_sigma A) (oper_sigma B)

| same_cpair :
    same_operator [0; 0] [0; 0] (oper_cpair A) (oper_cpair B)

| same_cpi1 :
    same_operator [0] [0] (oper_cpi1 A) (oper_cpi1 B)

| same_cpi2 :
    same_operator [0] [0] (oper_cpi2 A) (oper_cpi2 B)

| same_ppair :
    same_operator [0; 0] [0; 0] (oper_ppair A) (oper_ppair B)

| same_ppi1 :
    same_operator [0] [0] (oper_ppi1 A) (oper_ppi1 B)

| same_ppi2 :
    same_operator [0] [0] (oper_ppi2 A) (oper_ppi2 B)

| same_set :
    same_operator [0; 1] [0; 1] (oper_set A) (oper_set B)

| same_quotient :
    same_operator [0; 2] [0; 2] (oper_quotient A) (oper_quotient B)

| same_guard :
    same_operator [0; 0] [0; 0] (oper_guard A) (oper_guard B)

| same_wt :
    same_operator [0; 1] [0; 1] (oper_wt A) (oper_wt B)

| same_ext {x y} :
    same_operator nil nil (oper_ext A x) (oper_ext B y)

| same_extt {x y} :
    same_operator nil nil (oper_extt A x) (oper_extt B y)
.

Hint Constructors same_operator : same_operator.


(* begin hide *)
(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)
(* end hide *)
(** * Normalization of Simply Typed Lambda-Calculus through Hereditary Substitutions.

  Uses extrinsic encoding of terms, with de Bruijn indices, lifting and
  substitution. Derive hereditary substitution function justified by a
  well-founded order on typable terms and conclude with a normalizer building
  beta-short eta-long normal forms, typable in a bidirectional type system. *)

Require Program.
From Equations Require Import Equations.
Require Import Lia.
Require Import List Utf8.

Import ListNotations.

Set Keyed Unification.

Derive Signature for le CompareSpec.

Inductive term :=
| Var (n : nat)
| Lambda (t : term)
| App (t u : term)
| Pair (t u : term)
| Fst (t : term) | Snd (t : term)
| Tt.

Derive NoConfusion Subterm EqDec for term.

Coercion Var : nat >-> term.

Declare Scope term_scope.
Delimit Scope term_scope with term.
Bind Scope term_scope with term.

Notation " @( f , x ) " := (App (f%term) (x%term)).
Notation " 'λ' t " := (Lambda (t%term)) (at level 0).
Notation " << t , u >> " := (Pair (t%term) (u%term)).

Parameter atomic_type : Set.
Parameter atomic_type_eqdec : EqDec atomic_type.
#[export] Existing Instance atomic_type_eqdec.

Inductive type :=
| atom (a : atomic_type)
| product (a b : type)
| unit
| arrow (a b : type).

Derive NoConfusion Subterm EqDec for type.

Coercion atom : atomic_type >-> type.
Notation " x × y " := (product x y) (at level 90).
Notation " x ---> y " := (arrow x y) (at level 30).

Require Import Arith.

Equations lift (k n : nat) (t : term) : term :=
lift k n (Var i) with Nat.compare i k := {
  | Lt := Var i ;
  | _ := Var (i + n) } ;
lift k n (Lambda t) := Lambda (lift (S k) n t) ;
lift k n (App t u) := @(lift k n t, lift k n u) ;
lift k n (Pair t u) := << lift k n t, lift k n u >> ;
lift k n (Fst t) := Fst (lift k n t) ;
lift k n (Snd t) := Snd (lift k n t) ;
lift k n Tt := Tt.

Tactic Notation "absurd"  tactic(tac) := exfalso; tac.

Ltac term_eq :=
  match goal with
    | |- Var _ = Var _ => f_equal ; lia
    | |- @eq nat _ _ => lia || absurd lia
    | |- lt _ _ => lia || absurd lia
    | |- le _ _ => lia || absurd lia
    | |- gt _ _ => lia || absurd lia
    | |- ge _ _ => lia || absurd lia
  end.

#[local] Hint Extern 4 => term_eq : term.

Ltac term := typeclasses eauto with term core arith.

Ltac do_rewrites :=
  repeat
    match goal with
        H : ?lhs = ?rhs |- context [?lhs] => rewrite H; clear H
    end.

Ltac crush := do_rewrites; auto; try term.

Lemma lift0 k t : lift k 0 t = t.
Proof.
  funelim (lift k 0 t); term || rewrite ?H; crush.
Qed.
#[local] Hint Rewrite lift0 : lift.
Require Import Lia.

Lemma lift_k_lift_k k n m t : lift k n (lift k m t) = lift k (n + m) t.
Proof.
  funelim (lift k m t); intros; simp lift; try rewrite H ; try rewrite H0; auto.

  destruct (Nat.compare_spec i k); try discriminate. subst.
  case_eq (Nat.compare (k + n) k); intro H; simp lift; try term.
  rewrite Nat.compare_lt_iff in H; term.
  rewrite Heq; simp lift; term.

  rewrite Heq. rewrite Nat.compare_gt_iff in Heq. simp lift.
  destruct (Nat.compare_spec (i + n) k); try discriminate; simp lift; term.
Qed.
#[local] Hint Rewrite lift_k_lift_k : lift.

Equations subst (k : nat) (t : term) (u : term) : term :=
subst k (Var i) u with Nat.compare i k := {
  | Eq := lift 0 k u ;
  | Lt := i ;
  | Gt := Var (pred i) } ;
subst k (Lambda t) u := Lambda (subst (S k) t u) ;
subst k (App a b) u := @(subst k a u, subst k b u) ;
subst k (Pair a b) u := << subst k a u, subst k b u >> ;
subst k (Fst t) u := Fst (subst k t u) ;
subst k (Snd t) u := Snd (subst k t u) ;
subst k Tt _ := Tt.

Lemma substnn n t : subst n n t = lift 0 n t.
Proof. funelim (subst n n t) ; try rewrite H ; try rewrite H0; simp lift; auto.
  rewrite Nat.compare_lt_iff in Heq; absurd lia.
  rewrite Nat.compare_gt_iff in Heq; absurd lia.
Qed.
#[local] Hint Rewrite substnn : subst.
Notation ctx := (list type).

Reserved Notation " Γ |-- t : A " (at level 70, t, A at next level).

Inductive types : ctx -> term -> type -> Prop :=
| axiom Γ i : i < length Γ -> (Γ |-- i : nth i Γ unit)

| abstraction Γ A B t :
  A :: Γ |-- t : B -> Γ |-- λ t : A ---> B

| application Γ A B t u :
  Γ |-- t : A ---> B -> Γ |-- u : A -> Γ |-- @(t, u) : B

| unit_intro Γ : Γ |-- Tt : unit

| pair_intro Γ A B t u :
  Γ |-- t : A -> Γ |-- u : B ->
    Γ |-- << t , u >> : (A × B)

| pair_elim_fst Γ A B t : Γ |-- t : (A × B) -> Γ |-- Fst t : A

| pair_elim_snd Γ A B t : Γ |-- t : (A × B) -> Γ |-- Snd t : B

where "Γ |-- i : A " := (types Γ i A).

Derive Signature for types.

Notation " [ t ] u " := (subst 0 u t) (at level 10).

Notation " x @ y " := (app x y) (at level 30, right associativity).

Lemma nth_length {A} x t (l l' : list A) : nth (length l) (l @ (t :: l')) x = t.
Proof. induction l; simpl; auto. Qed.

#[local] Hint Constructors types : term.

Lemma nat_compare_elim (P : nat -> nat -> comparison -> Prop)
  (PEq : forall i, P i i Eq)
  (PLt : forall i j, i < j -> P i j Lt)
  (PGt : forall i j, i > j -> P i j Gt) :
  forall i j, P i j (Nat.compare i j).
Proof. intros. case (Nat.compare_spec i j); intros; subst; auto. Qed.

Lemma nth_extend_left {A} (a : A) n (l l' : list A) : nth n l a = nth (length l' + n) (l' @ l) a.
Proof. induction l'; auto. Qed.

Lemma nth_app_l {A} (a : A) {n} (l l' : list A) : n < length l -> nth n (l @ l') a = nth n l a.
Proof.
  revert l l' n; induction l; intros; auto. depelim H. destruct n; trivial.
  simpl. eapply IHl. simpl in H. lia.
Qed.

Lemma nth_app_r {A} (a : A) {n} (l l' : list A) : length l <= n ->
  nth n (l @ l') a = nth (n - length l) l' a.
Proof.
  revert l l' n; induction l; intros; auto. simpl in H. depelim H; auto.
  destruct n; simpl in H. depelim H. simpl; apply IHl; lia.
Qed.

Lemma nth_extend_middle {A} (a : A) n (l l' l'' : list A) :
  match Nat.compare n (length l') with
    | Lt => nth n (l' @ l) a = nth n (l' @ l'' @ l) a
    | _ => nth n (l' @ l) a = nth (n + length l'') (l' @ l'' @ l) a
  end.
Proof.
  assert (foo:=Nat.compare_spec n (length l')).
  depelim foo; fold (length l') in H;
  try rewrite H0; try rewrite H. rewrite <- nth_extend_left.
  replace (length l'') with (length l'' + 0) by auto with arith. rewrite <- nth_extend_left.
  replace (length l') with (length l' + 0) by auto with arith.
  now rewrite <- nth_extend_left.

  clear H0. now rewrite !nth_app_l by trivial.
  clear H0. rewrite !nth_app_r by lia. f_equal. lia.
Qed.

#[local] Hint Rewrite <- app_assoc in_app_iff in_inv : list.

Lemma type_lift Γ t T Γ' : Γ' @ Γ |-- t : T ->
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t : T.
Proof.
  intros H.
  depind H; intros; simp lift; eauto with term.

  generalize (nth_extend_middle unit i Γ0 Γ' Γ'').
  destruct Nat.compare; intros H'; rewrite H'; simp lift;
    apply axiom; autorewrite with list in H |- *; lia.

  apply abstraction. rewrite app_comm_cons. now apply IHtypes.
Qed.

Lemma type_lift1 Γ t T A : Γ |-- t : T -> A :: Γ |-- lift 0 1 t : T.
Proof. intros. apply (type_lift Γ t T [] H [A]). Qed.

Lemma type_liftn Γ Γ' t T : Γ |-- t : T -> Γ' @ Γ |-- lift 0 (length Γ') t : T.
Proof. intros. apply (type_lift Γ t T [] H Γ'). Qed.
#[local] Hint Resolve type_lift1 type_lift type_liftn : term.

Ltac crush ::= do_rewrites; simpl; do_rewrites; auto; try term.

Lemma app_cons_snoc_app {A} l (a : A) l' : l ++ (a :: l') = (l ++ a :: nil) ++ l'.
Proof. induction l; crush. Qed.

#[local] Hint Extern 5 => progress (simpl ; autorewrite with list) : term.
Ltac term ::= simp lift subst; try typeclasses eauto with core term.

Lemma substitutive Γ t T Γ' u U :
  (Γ' @ (U :: Γ)) |-- t : T -> Γ |-- u : U ->
  Γ' @ Γ |-- subst (length Γ') t u : T.
Proof with term.
  intros H. depind H; term. intros.

  (* Var *)
  assert (spec:=Nat.compare_spec i (length Γ')).
  depelim spec; try fold (length Γ') in H1; subst;
  try rewrite H1; try rewrite H2 ; simp subst.

  (* Eq *)
  generalize (type_lift Γ0 u U [] H0 Γ'); simpl; intros.
  rewrite app_cons_snoc_app, app_nth1, app_nth2; try (simpl; lia).
  now rewrite <- minus_n_n. term.

  (* Lt *)
  rewrite app_nth1 by lia. rewrite <- (app_nth1 _ Γ0); term.

  (* Gt *)
  rewrite app_nth2; term.
  change (U :: Γ0) with ((cons U nil) @ Γ0). rewrite app_nth2; term.
  simpl. rewrite (nth_extend_left unit _ Γ0 Γ').
  replace (length Γ' + (i - length Γ' - 1)) with (pred i); term.
  apply axiom. autorewrite with list in H |- *. simpl in H. lia.

  (* Abstraction *)
  intros. apply abstraction. now eapply (IHtypes _ _ _ (A :: Γ')).
Qed.

Lemma subst1 Γ t T u U : U :: Γ |-- t : T -> Γ |-- u : U -> Γ |-- subst 0 t u : T.
Proof. intros; now apply (substitutive Γ t T [] u U). Qed.

Reserved Notation " t --> u " (at level 55, right associativity).

Inductive reduce : term -> term -> Prop :=
| red_beta t u : @((Lambda t) , u) --> subst 0 t u
| red_fst t u : Fst << t , u >> --> t
| red_snd t u : Snd << t , u >> --> u

where " t --> u " := (reduce t u).
Derive Signature for reduce.

Require Import Relations.

Definition reduces := clos_refl_trans term reduce.
Notation " t -->* u " := (reduces t u) (at level 55).

Require Import Setoid.

#[local]
Instance: Transitive reduces.
Proof. red; intros. econstructor 3; eauto. Qed.

#[local]
Instance: Reflexive reduces.
Proof. red; intros. econstructor 2; eauto. Qed.

Inductive value : term -> Prop :=
| val_var (i : nat) : value i
| val_unit : value Tt
| val_pair a b : value a -> value b -> value << a, b >>
| val_lambda t : value λ t.
Derive Signature for value.

#[local] Hint Constructors value : term.

Inductive reduce_congr : relation term :=
| reduce1 t u : reduce t u -> reduce_congr t u
| reduce_app_l t t' u : reduce_congr t t' ->
  reduce_congr (@(t, u)) (@(t', u))
| reduce_app_r t u u' : reduce_congr u u' ->
  reduce_congr (@(t, u)) (@(t, u'))
| reduce_pair_l t t' u : reduce_congr t t' ->
  reduce_congr (<< t, u >>) (<< t', u >>)
| reduce_pair_r t u u' : reduce_congr u u' ->
  reduce_congr (<< t, u >>) (<< t, u' >>)
| reduce_fst t t' : reduce_congr t t' -> reduce_congr (Fst t) (Fst t')
| reduce_snd t t' : reduce_congr t t' -> reduce_congr (Snd t) (Snd t').
Derive Signature for reduce_congr.

Ltac find_empty :=
  match goal with
      [ H : _ |- _ ] => solve [ depelim H ]
  end.

Lemma preserves_red1 Γ t τ : Γ |-- t : τ → forall u, t --> u → Γ |-- u : τ.
Proof.
  intros H; induction H; intros t' redtt'; term; try find_empty; depelim redtt'.
  apply subst1 with A. now depelim H. apply H0.
  now depelim H.
  now depelim H.
Qed.

Lemma preserves_redpar Γ t τ : Γ |-- t : τ → forall u, reduce_congr t u → Γ |-- u : τ.
Proof.
  intros H. induction H; intros t' rtt'; depelim rtt'; term; try find_empty.

  depelim H1. depelim H. eapply subst1; eauto.

  depelim H0; depelim H; term.
  depelim H0; depelim H; term.
Qed.

Lemma subject_reduction Γ t τ : Γ |-- t : τ → forall u, t -->* u → Γ |-- u : τ.
Proof. induction 2; eauto using preserves_red1. Qed.
#[local] Hint Constructors reduce reduce_congr : term.
Lemma progress_ t τ : nil |-- t : τ → (exists t', reduce_congr t t') \/ value t.
Proof.
  intros H; depind H; auto with term.

  destruct IHtypes1 as [[t' tt']|vt].
  left; eauto with term.
  destruct IHtypes2 as [[u' uu']|vu].
  left; eauto with term.
  depelim H; [depelim H|depelim vt..].
  left. exists ([u]t0). eauto with term.

  destruct IHtypes1 as [[t' tt']|vt]; eauto with term.
  destruct IHtypes2 as [[u' uu']|vu]; eauto with term.

  destruct IHtypes as [[t' tt']|vt]; eauto with term.
  depelim vt; depelim H;
  eauto with term. depelim H.

  destruct IHtypes as [[t' tt']|vt]; eauto with term.
  depelim vt; depelim H;
  eauto with term. depelim H.
Qed.

Reserved Notation " Γ |-- t => A " (at level 70, t, A at next level).
Reserved Notation " Γ |-- t <= A " (at level 70, t, A at next level).

Inductive atomic : type -> Prop :=
| atomic_atom a : atomic (atom a).

Derive Signature for atomic.
#[local] Hint Constructors atomic : term.

(* FIXME bug *)
Equations? atomic_dec (t : type) : { atomic t } + { ~ atomic t } :=
atomic_dec (atom a) := left (atomic_atom a) ;
atomic_dec t := right _.
Proof. all:(intro H; depelim H). Qed.

Inductive check : ctx -> term -> type -> Prop :=
| abstraction_check Γ A B t :
  A :: Γ |-- t <= B ->
  Γ |-- λ t <= A ---> B

| pair_intro_check Γ A B t u :
  Γ |-- t <= A -> Γ |-- u <= B ->
    Γ |-- << t , u >> <= (A × B)

| unit_intro_check Γ : Γ |-- Tt <= unit

| check_synth Γ t T : atomic T -> Γ |-- t => T -> Γ |-- t <= T

with synthetize : ctx -> term -> type -> Prop :=

| axiom_synth Γ i : i < length Γ ->
  Γ |-- i => nth i Γ unit

| application_synth {Γ A B t u} :
  Γ |-- t => A ---> B -> Γ |-- u <= A -> Γ |-- @(t, u) => B

| pair_elim_fst_synth {Γ A B t} : Γ |-- t => (A × B) -> Γ |-- Fst t => A

| pair_elim_snd_synth {Γ A B t} : Γ |-- t => (A × B) -> Γ |-- Snd t => B

where "Γ |-- i => A " := (synthetize Γ i A)
and  "Γ |-- i <= A " := (check Γ i A).
Derive Signature for check synthetize.

#[local] Hint Constructors synthetize check : term.

Scheme check_mut_ind := Elimination for check Sort Prop
  with synthetize_mut_ind := Elimination for synthetize Sort Prop.

Combined Scheme check_synthetize from check_mut_ind, synthetize_mut_ind.

Lemma synth_arrow {Γ t T} : forall A : Prop, Γ |-- λ (t) => T -> A.
Proof. intros A H. depelim H. Qed.

Lemma synth_pair {Γ t u T} : forall A : Prop, Γ |-- << t, u >> => T -> A.
Proof. intros A H. depelim H. Qed.

Lemma synth_unit {Γ T} : forall A : Prop, Γ |-- Tt => T -> A.
Proof. intros A H. depelim H. Qed.

#[local] Hint Extern 3 =>
  match goal with
    | H : ?Γ |-- ?t => ?T |- _ => apply (synth_arrow _ H) || apply (synth_pair _ H) || apply (synth_unit _ H)
  end : term.

Lemma check_types : (forall Γ t T, Γ |-- t <= T -> Γ |-- t : T)
with synthetizes_types : (forall Γ t T, Γ |-- t => T -> Γ |-- t : T).
Proof. intros. destruct H; try econstructor; term.
  intros. destruct H; try solve [ econstructor; term ].
Qed.

#[local] Hint Resolve check_types synthetizes_types : term.

Inductive normal : term -> Prop :=
| normal_unit : normal Tt
| normal_pair a b : normal a -> normal b -> normal << a, b >>
| normal_abs t : normal t -> normal λ t
| normal_neutral r : neutral r -> normal r

with neutral : term -> Prop :=
| neutral_var i : neutral (Var i)
| neutral_fst t : neutral t -> neutral (Fst t)
| neutral_snd t : neutral t -> neutral (Snd t)
| neutral_app t n : neutral t -> normal n -> neutral (@(t, n)).

Derive Signature for normal neutral.
#[local] Hint Constructors normal neutral : term.

Lemma check_lift_gen Δ t T (H : Δ |-- t <= T) : forall Γ Γ', Δ = Γ' @ Γ ->
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t <= T
with synthetize_lift_gen Δ t T (H : Δ |-- t => T) : forall Γ Γ', Δ = Γ' @ Γ ->
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t => T.
Proof.
  destruct H; intros; simp lift.

  econstructor.
  change (S (length Γ')) with (length (A :: Γ')). change (A :: Γ' @ Γ'' @ Γ0) with ((A :: Γ') @ Γ'' @ Γ0).
  eapply check_lift_gen; try eassumption. subst. rewrite app_comm_cons; subst; try eassumption; trivial.

  econstructor; eapply check_lift_gen; eassumption.
  econstructor.

  econstructor. eassumption.
  eapply synthetize_lift_gen; eassumption.

  destruct H; intros; simp lift; try solve [econstructor; term].
  clear check_lift_gen synthetize_lift_gen. subst.
  generalize (nth_extend_middle unit i Γ0 Γ' Γ'').
  destruct Nat.compare; intros H'; rewrite H'; simp lift; apply axiom_synth; autorewrite with list in H |- *; lia.
Qed.

Definition check_lift Γ t T Γ' (H : Γ' @ Γ |-- t <= T) :
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t <= T :=
  check_lift_gen (Γ' @ Γ) _ _ H _ _ eq_refl.
Definition synthetize_lift Γ t T Γ' (H : Γ' @ Γ |-- t => T) :
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t => T :=
  synthetize_lift_gen (Γ' @ Γ) _ _ H _ _ eq_refl.

Lemma check_lift1 {Γ t T A} : Γ |-- t <= T -> A :: Γ |-- lift 0 1 t <= T.
Proof. intros. apply (check_lift Γ t T [] H [A]). Qed.

Lemma synth_lift1 {Γ t T A} : Γ |-- t => T -> A :: Γ |-- lift 0 1 t => T.
Proof. intros. apply (synthetize_lift Γ t T [] H [A]). Qed.
#[local] Hint Resolve check_lift1 synth_lift1 : term.

Lemma check_lift_ctx {Γ t T Γ'} : Γ |-- t <= T -> Γ' @ Γ |-- lift 0 (length Γ') t <= T.
Proof. intros. apply (check_lift Γ t T [] H Γ'). Qed.

Lemma synth_lift_ctx {Γ t T Γ'} : Γ |-- t => T -> Γ' @ Γ |-- lift 0 (length Γ') t => T.
Proof. intros. apply (synthetize_lift Γ t T [] H Γ'). Qed.
#[local] Hint Resolve check_lift_ctx synth_lift_ctx : term.

Equations η (a : type) (t : term) : term :=
η (atom _) t := t ;
η (product a b) t := << η a (Fst t), η b (Snd t) >> ;
η (arrow a b) t := (Lambda (η b @(lift 0 1 t, η a 0)))%term ;
η unit t := Tt.

Lemma checks_arrow Γ t A B : Γ |-- t <= A ---> B → ∃ t', t = λ t' ∧ A :: Γ |-- t' <= B.
Proof. intros H; inversion H; subst.
  exists t0; term.
  inversion H0.
Qed.

Lemma normal_lift {t k n} : normal t → normal (lift k n t)
  with neutral_lift {t k n} : neutral t -> neutral (lift k n t).
Proof. destruct 1; simp lift; constructor; term.
  destruct 1; simp lift; try (constructor; term).
  destruct Nat.compare; term.
Qed.
#[local] Hint Resolve normal_lift neutral_lift : term.

Lemma check_normal {Γ t T} : Γ |-- t <= T -> normal t
 with synth_neutral {Γ t T} : Γ |-- t => T -> neutral t.
Proof. destruct 1; constructor; term. destruct 1; constructor; term. Qed.
#[local] Hint Resolve check_normal synth_neutral : term.

Lemma eta_expand Γ t A : neutral t → Γ |-- t => A -> Γ |-- η A t <= A.
Proof. revert Γ t; induction A; intros; simp η; constructor; term.

  assert(0 < length (A1 :: Γ)) by (simpl; lia).
  specialize (IHA1 (A1 :: Γ) 0 (neutral_var _) (axiom_synth (A1 :: Γ) 0 H1)).
  apply (IHA2 (A1 :: Γ) @(lift 0 1 t, η A1 0)); term.
Qed.

Lemma η_normal : forall Γ A t, neutral t -> Γ |-- t => A -> normal (η A t).
Proof. intros. now apply eta_expand in H0; term. Qed.

(** Going to use the subterm order *)

Require Import Arith Wf_nat.
#[export] Instance wf_nat : Classes.WellFounded lt := lt_wf.

#[local] Hint Constructors Subterm.lexprod : subterm_relation.

Derive Signature for Acc.
Notation lexicographic R S := (Subterm.lexprod _ _ R S).

Definition her_order : relation (type * term * term) :=
  lexicographic (lexicographic type_subterm term_subterm) term_subterm.

#[local] Hint Unfold her_order : subterm_relation.

Import Program.Tactics.
Obligation Tactic := program_simpl.

Arguments exist [A] [P].

Definition hereditary_type (t : type * term * term) :=
  (term * option { u : type | u = (fst (fst t)) \/ type_subterm u (fst (fst t)) })%type.

Inductive IsLambda {t} : hereditary_type t -> Set :=
| isLambda abs a b prf : IsLambda (Lambda abs, Some (exist (arrow a b) prf)).

Equations is_lambda {t} (h : hereditary_type t) : IsLambda h + term :=
is_lambda (pair (Lambda abs) (Some (exist (arrow a b) prf))) := inl (isLambda abs a b prf) ;
is_lambda (pair t' _) := inr t'.
Arguments is_lambda : simpl never.
Lemma is_lambda_inr {t} (h : hereditary_type t) : forall t', is_lambda h = inr t' -> fst h = t'.
Proof.
  let elim := constr:(fun_elim (f:=@is_lambda)) in apply elim; simpl; intros; try congruence.
Qed.

Inductive IsPair {t} : hereditary_type t -> Set :=
| isPair u v a b prf : IsPair (Pair u v, Some (exist (product a b) prf)).

Equations is_pair {t} (h : hereditary_type t) : IsPair h + term :=
is_pair (pair (Pair u v) (Some (exist (product a b) prf))) := inl (isPair u v a b prf) ;
is_pair (pair t' _) := inr t'.
Arguments is_pair : simpl never.

Lemma is_pair_inr {t} (h : hereditary_type t) : forall t', is_pair h = inr t' -> fst h = t'.
Proof.
  let elim := constr:(fun_elim (f:=@is_pair)) in apply elim; simpl; intros; try congruence.
Qed.

Lemma nth_extend_right {A} (a : A) n (l l' : list A) : n < length l ->
  nth n l a = nth n (l @ l') a.
Proof. revert n l'. induction l; simpl; intros; auto. depelim H. destruct n; auto.
  apply IHl. auto with arith.
Qed.

Definition her_type (t : type * term * term) :=
  let u' := fst (fst t) in
   { u : type | u = u' \/ type_subterm u u' }.

#[local] Remove Hints t_step : subterm_relation.
#[local] Remove Hints Subterm.clos_trans_stepr : subterm_relation.

Ltac apply_step :=
  match goal with
    |- clos_trans ?A ?R ?x ?y => not_evar y; eapply t_step
  end.
#[local] Hint Extern 30 (clos_trans _ _ _ _) => apply_step : subterm_relation.

Lemma clos_trans_inv {A} R (x y z : A) :
  clos_trans A R y z → clos_trans A R x y → clos_trans A R x z.
Proof. eauto using t_trans. Qed.

Ltac apply_transitivity :=
  match goal with
    |- clos_trans ?A ?R ?x ?y =>
    not_evar x; not_evar y; eapply clos_trans_inv
  end.
#[local] Hint Extern 31 (clos_trans _ _ _ _) => apply_transitivity : subterm_relation.

Equations? hereditary_subst (t : type * term * term) (k : nat) :
  term * option (her_type t)
  by wf t her_order :=

hereditary_subst (pair (pair A a) t) k with t := {
  | Var i with Nat.compare i k := {
    | Eq := (lift 0 k a, Some (exist A _)) ;
    | Lt := (Var i, None) ;
    | Gt := (Var (pred i), None) } ;

  | Lambda t' := (Lambda (fst (hereditary_subst (A, a, t') (S k))), None) ;

  | App f arg with hereditary_subst (A, a, f) k := {
    | p with is_lambda p := {
        | inl (isLambda f' A' B' prf) :=
          let (f'', y) := hereditary_subst (A', fst (hereditary_subst (A, a, arg) k), f') 0 in
            (f'', Some (exist B' _)) ;
        | inr f' := (@(f', fst (hereditary_subst (A, a, arg) k)), None) } } ;

  | Pair i j :=
    (<< fst (hereditary_subst (A, a, i) k), fst (hereditary_subst (A, a, j) k) >>, None) ;

  | Fst t' with hereditary_subst (A, a, t') k := {
    | p with is_pair p := {
      | inl (isPair u v a' b' prf) := (u, Some (exist a' _)) ;
      | inr p' := (Fst p', None) } } ;

  | Snd t' with hereditary_subst (A, a, t') k := {
    | p with is_pair p := {
      | inl (isPair u v a' b' prf) := (v, Some (exist b' _)) ;
      | inr p' := (Snd p', None) } } ;

  | Tt := (Tt, None) }.
Proof.
  all:(try match goal with |- her_order _ _ =>
                       unfold her_type in *; simpl in *; try (clear; constructor 2; do 2 constructor)
       end).
  1:(destruct prf; subst; eauto 10 with subterm_relation).
  all:(clear -prf; simpl in *; destruct prf; subst; eauto 5 with subterm_relation).
Defined.

#[local] Hint Unfold her_type : subterm_relation.
#[local] Hint Unfold Program.Basics.const : subterm_relation.

Ltac autoh :=
  unfold type_subterm in * ; try typeclasses eauto with hereditary_subst subterm_relation.
Ltac simph :=
  try (rewrite_strat (innermost (hints hereditary_subst)));
  autoh.

#[local] Hint Transparent type_subterm : subterm_relation.

Ltac invert_term :=
  match goal with
    | [ H : check _ (Lambda _) _ |- _ ] => depelim H
    | [ H : check _ (Pair _ _) _ |- _ ] => depelim H
    | [ H : check _ Tt _ |- _ ] => depelim H
    | [ H : types _ ?t _ |- _ ] =>
      match t with
        | Var _ => depelim H
        | Lambda _ => depelim H
        | App _ _ => depelim H
        | Pair _ _ => depelim H
        | Fst _ => depelim H
        | Snd _ => depelim H
        | Tt => depelim H
      end
  end.

Set Regular Subst Tactic.

Lemma hereditary_subst_type Γ Γ' t T u U : Γ |-- u : U -> Γ' @ (U :: Γ) |-- t : T ->
  let (t', o) := hereditary_subst (U, u, t) (length Γ') in
    (Γ' @ Γ |-- t' : T /\ (forall ty prf, o = Some (exist ty prf) -> ty = T)).
Proof.
  intros.
  funelim (hereditary_subst (U, u, t) (length Γ'));
    DepElim.simpl_dep_elim; subst;
    try (split; [ (intros; try discriminate) | solve [ intros; discriminate ] ]);
    DepElim.simplify_dep_elim.

  invert_term. simpl in *. apply abstraction.
  specialize (H Γ (A0 :: Γ')). simpl in H. eqns_specialize_eqs H.
  simpl in H.
  on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
  specialize (H _ H0 H1).
  apply H; auto.

  on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
  on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
  depelim H2. constructor. now apply H. now apply H0.
  depelim H0. term.

  (* Var *) simpl.
  apply Nat.compare_eq in Heq; subst.
  depelim H0.
  rewrite !nth_length. split. term. intros.
  noconf H1. auto.

  (* Lt *)
  apply Nat.compare_lt_iff in Heq. depelim H0.
  replace (nth i (Γ' @ (_ :: Γ)) unit) with (nth i (Γ' @ Γ) unit).
  constructor. rewrite app_length. auto with arith.
  now do 2 rewrite <- nth_extend_right by auto.

  (* Gt *)
  pose (substitutive _ _ _ _ _ _ H0 H).
  simp subst in t. rewrite Heq in t. simp subst in t.

  (* App *)
  simpl in *.
  - on_call (hereditary_subst (A, a, arg)) ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    dependent elimination H2 as [application _ U T f arg tyfn tyu].
    specialize (H _ _ H1 tyu).
    specialize (Hind _ _ H1 tyfn). rewrite Heq in Hind.
    destruct Hind as [Ht' Ht''].
    dependent elimination Ht' as [abstraction _ U T abs tyabs].
    eqns_specialize_eqs Ht''. noconf Ht''.
    destruct H as [Ht tty].
    specialize (H0 _ [] _ _ _ _ Ht tyabs eq_refl).
    destruct H0 as [H0 H5].
    split; auto.
    intros ty prf0 Heq'.
    noconf Heq'. auto.

  (* App no redex *)
  - apply is_lambda_inr in Heq. revert Heq.
    intros <-. depelim H1.
    specialize (H _ _ H0 H1_0).
    specialize (Hind _ _ H0 H1_).
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    on_call (hereditary_subst (A, a, arg)) ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    destruct H, Hind. econstructor; eauto.

  (* Fst redex *)
  - simpl in *.
    depelim H0. specialize (Hind _ _ H H0).
    rewrite Heq in Hind.
    destruct Hind. depelim H1. intuition auto.
    eqns_specialize_eqs H2. noconf H2.
    now noconf H1.

  (* Fst no redex *)
  - apply is_pair_inr in Heq. revert Heq.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    depelim H0. intros <-.
    specialize (Hind _ _ H H0); eauto.
    destruct Hind. now apply pair_elim_fst with B.

  (* Snd redex *)
  - simpl. depelim H0. specialize (Hind _ _ H H0).
    rewrite Heq in Hind.
    destruct Hind. depelim H1. intuition auto.
    eqns_specialize_eqs H2. noconf H2.
    now noconf H1.

  (* Snd no redex *)
  - apply is_pair_inr in Heq. revert Heq.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    intros Ht2; subst t. simpl in *. depelim H0.
    specialize (Hind _ _ H H0); eauto. now apply pair_elim_snd with A0.
Qed.
Print Assumptions hereditary_subst_type.
Import Program.Basics.
#[export] Instance: subrelation eq (flip impl).
Proof. reduce. subst; auto. Qed.

Lemma nth_pred Γ' Γ U n : n > length Γ' -> nth (pred n) (Γ' @ Γ) unit = nth n (Γ' @ (U :: Γ)) unit.
Proof.
  revert_until Γ'. induction Γ'; intros.

  destruct n; auto. depelim H.
  destruct n; auto. simpl pred. simpl.
  rewrite <- IHΓ'. destruct n; auto. simpl in H. depelim H. depelim H.
  simpl in *; lia.
Qed.

Lemma hereditary_subst_subst U u t Γ' :
  (forall Γ T, Γ |-- u <= U ->
    match hereditary_subst (U, u, t) (length Γ') with
      | (t', Some (exist ty _)) =>
         ((Γ' @ (U :: Γ) |-- t <= T -> Γ' @ Γ |-- t' <= T /\ ty = T) /\
          (Γ' @ (U :: Γ) |-- t => T -> Γ' @ Γ |-- t' <= T /\ ty = T))
      | (t', None) =>
        (Γ' @ (U :: Γ) |-- t <= T -> Γ' @ Γ |-- t' <= T) /\
        (Γ' @ (U :: Γ) |-- t => T -> Γ' @ Γ |-- t' => T)
    end).
Proof.
  funelim (hereditary_subst (U, u, t) (length Γ')); simpl in *.
  let Hind := fresh "Hind" in rename H into Hind; intros ?? Hu.
  simpl. simpl in *.

  (** Lambda *)
  - on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    split; intros Hsyn; [| elim (synth_arrow False Hsyn)].

    invert_term. constructor.
    specialize (Hind _ _ _ (A0 :: Γ') eq_refl). simpl in *.
    specialize (Hind _ B Hu).
    destruct o as [[ty prf]|], Hind as [Hind0 Hind1].
    apply Hind0; eauto. eauto.
    elim (synth_arrow False H0).

  (** Pairs *)
  - do 2 on_call hereditary_subst
          ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    split; intros Hsyn; [|elim (synth_pair False Hsyn)].
    invert_term.
    specialize (H0 _ B H1). specialize (H _ A0 H1).
    destruct o as [[ty prf]|], o0 as [[ty' prf']|], H, H0;
      destruct_conjs; constructor; eauto.
    now apply H. now apply H0. now apply H. now apply H0.

    elim (synth_pair False H3).

  (* Unit *)
  - split; intros Hsyn; [|elim (synth_unit False Hsyn)].
    depelim Hsyn. term.
    elim (synth_unit False H1).

  (* Var: eq *)
  - apply Nat.compare_eq in Heq; subst i.
    split; intros Hsyn; depelim Hsyn; rewrite ?nth_length.
    depelim H1; rewrite !nth_length.
    now split; term. split; term.

  (* Lt *)
  - apply Nat.compare_lt_iff in Heq.
    split; intros Hsyn; depelim Hsyn;
    [depelim H1;constructor;auto|];
    (rewrite nth_app_l by lia; rewrite <- nth_app_l with (l':=Γ) by lia;
     constructor; rewrite app_length; auto with arith).

  (* Gt *)
  - apply Nat.compare_gt_iff in Heq.
    split; intros Hsyn; depelim Hsyn.
    depelim H1. constructor. auto.
    replace (nth i (Γ' @ (A :: Γ)) unit) with (nth (pred i) (Γ' @ Γ) unit).
    constructor. rewrite app_length in *. simpl in H1. lia.
    now apply nth_pred.

    replace (nth _ (Γ' @ (_ :: _)) unit) with (nth (pred i) (Γ' @ Γ) unit).
    constructor. rewrite app_length in *. simpl in H0. lia.
    now apply nth_pred.

  (* App *)
  - cbn. on_call (hereditary_subst (A,a,arg))
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    specialize (H0 _ _ _ [] eq_refl).
    rewrite Heq in Hind.
    revert H0.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    intros.

    (* Redex *)
    assert((Γ' @ (A :: Γ) |-- @(f, arg) => T → Γ' @ Γ |-- t0 <= T ∧ B' = T)).
    intros Ht; depelim Ht.
    destruct (Hind Γ (A0 ---> T) H1).
    specialize (H _ A' H1).
    destruct (H4 Ht). noconf H6.
    depelim H5. split; auto.

    destruct o; try destruct h; destruct H.
    destruct (H H2). subst x.
    specialize (H0 _ B' H7).
    destruct o0 as [[ty typrf]|]; destruct H0 as [Hcheck Hinf].
    now apply Hcheck. now apply Hcheck.

    specialize (H0 _ B' (H H2)).
    destruct o0 as [[ty typrf]|]; destruct H0 as [Hcheck Hinf].
    now apply Hcheck. now apply Hcheck.

    split; auto.
    depelim H6.

    split; eauto.
    intros Ht3u; apply H2.
    now depelim Ht3u.

  (* No redex *)
  - intros Γ T Hu.
    assert(Γ' @ (A :: Γ) |-- @( f, arg) => T
      → Γ' @ Γ |-- @( f', fst (hereditary_subst (A, a, arg) (length Γ'))) => T).
    intros Ht; depelim Ht.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    revert Heq.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    intros.
    pose (Hind _ (A0 ---> T) Hu).
    destruct o0 as [[ty prf']|].
    + destruct y as [Hind' Hind''].
      specialize (Hind'' Ht). destruct Hind''; subst ty.
      specialize (H _ A0 Hu).
      destruct o as [[ty' prf'']|].
      ++ destruct H as [Hind0 Hind0'].
        specialize (Hind0 H0). destruct Hind0. subst ty'.
        eapply application_synth; eauto. simpl in *.
        depelim H1. simp is_lambda in Heq. noconf Heq.
        depelim H1.

      ++ depelim H1. simp is_lambda in Heq. noconf Heq. depelim H1.
    + clear y. specialize (H _ A0 Hu).
      destruct (Hind _ (A0 ---> T) Hu).
      apply is_lambda_inr in Heq. cbn in Heq; subst t0. simpl.
      destruct o as [[ty prf]|]; destruct H as [Hindt0 Hindt0'].
      eapply application_synth; eauto.
      now apply Hindt0.
      eapply application_synth; eauto.

    + split; auto. intros H2.
      depelim H2.
      constructor; auto.

  (* Pair *)
  - simpl in Heq. autorewrite with is_pair in Heq. simpl in prf.
    intros Γ T Hu.
    assert( (Γ' @ (A :: Γ) |-- Fst t' => T → Γ' @ Γ |-- u <= T ∧ a' = T)).
    intros Ht; depelim Ht. specialize (Hind _ (T × B) Hu). revert Hind.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    noconf Heq.
    intros [Hind Hind'].
    specialize (Hind' Ht). destruct Hind' as [H0 H1]. noconf H1.
    depelim H0. split; auto.
    depelim H0.
    split; auto.
    intros H1. depelim H1. intuition.

  - intros Γ T Hu.
    assert (Γ' @ (A :: Γ) |-- Fst t' => T → Γ' @ Γ |-- Fst p' => T).
    intros Ht; depelim Ht.
    specialize (Hind _ (T × B) Hu). revert Hind.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    destruct o as [[ty prf]|]. intros [Hind Hind'].
    destruct (Hind' Ht). subst ty.
    depelim H. simp is_pair in Heq. discriminate.
    depelim H.

    apply is_pair_inr in Heq. simpl in Heq ; subst p'.
    intros [Hind Hind']. eapply pair_elim_fst_synth. now apply Hind'.
    split; auto. intros H2. depelim H2. intuition auto with term.

  (* Snd *)
  - intros Γ T Hu.
    assert((Γ' @ (A :: Γ) |-- Snd t' => T → Γ' @ Γ |-- v <= T ∧ b' = T)).

    intros Ht; depelim Ht. specialize (Hind _ (A0 × T) Hu). revert Hind.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    noconf Heq.
    intros [Hind Hind'].
    specialize (Hind' Ht). destruct Hind' as [H0 H1]. noconf H1.
    depelim H0. split; auto. depelim H0.
    split; auto.
    intros H1. depelim H1. intuition auto with term.

  - intros Γ T Hu.
    assert (Γ' @ (A :: Γ) |-- Snd t' => T → Γ' @ Γ |-- Snd p' => T).
    intros Ht; depelim Ht.
    specialize (Hind _ (A0 × T) Hu). revert Hind.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    destruct o as [[ty prf]|]. intros [Hind Hind'].
    destruct (Hind' Ht). subst ty.
    depelim H. simp is_pair in Heq. discriminate.
    depelim H.

    intros [Hind Hind'].
    apply is_pair_inr in Heq. subst p'. simpl in *.
    specialize (Hind' Ht). econstructor; eauto.

    split; auto. intros H1. depelim H1. term.
Qed.

Print Assumptions hereditary_subst_subst.

Lemma check_liftn {Γ Γ' t T} : Γ |-- t <= T -> Γ' @ Γ |-- lift 0 (length Γ') t <= T.
Proof. intros. apply (check_lift Γ t T [] H Γ'). Qed.

Lemma synth_liftn {Γ Γ' t T} : Γ |-- t => T -> Γ' @ Γ |-- lift 0 (length Γ') t => T.
Proof. intros. apply (synthetize_lift Γ t T [] H Γ'). Qed.
#[local] Hint Resolve check_liftn synth_liftn : term.

(* Write normalization function *)
Lemma types_normalizes Γ t T : Γ |-- t : T → ∃ u, Γ |-- u <= T.
Proof. induction 1. (* eta-exp *)

  exists (η (nth i Γ unit) i).
  apply (eta_expand Γ i (nth i Γ unit) (neutral_var _)); term.

  destruct IHtypes as [t' tt'].
  exists λ t'; term.

  destruct IHtypes1 as [t' tt'].
  destruct IHtypes2 as [u' uu'].

  (* Hereditary substitution *)
  apply checks_arrow in tt'. destruct tt' as [t'' [t't'' t'B]]. subst.

  generalize (hereditary_subst_subst _ _ t'' [] Γ B uu').
  destruct_call hereditary_subst. destruct o. destruct h.
  simpl in *. intros. destruct H1. exists t0; intuition.
  simpl in *. intros. destruct H1. exists t0; intuition.

  (* Unit *)
  exists Tt; term.

  (* Pair *)
  destruct IHtypes1 as [t' tt'].
  destruct IHtypes2 as [u' uu'].
  exists << t' , u' >>. term.

  (* Fst *)
  destruct IHtypes as [t' tt'].
  depelim tt'. exists t0; term.

  depelim H0.

  (* Snd *)
  destruct IHtypes as [t' tt'].
  depelim tt'. exists u; term.

  depelim H0.
Qed.

Print Assumptions types_normalizes.


Require Export Db.Spec.
Require Export Db.Tactics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

Create HintDb ws.
Hint Constructors wsIx : ws.

Local Tactic Notation "crush'" tactic(T) :=
  cbn; intros;
  repeat
    (cbn;
     repeat crushDbSyntaxMatchH;
     crushRewriter;
     T);
  auto.

Lemma ap_wks {X Y} {vrX: Vr X} {wkX: Wk X} {vrY: Vr Y} {wkY: Wk Y}
  {apXY: Ap X Y} {apWkXY: LemApWk X Y} {apYY: Ap Y Y}
  {apCompXY: LemApComp X Y Y} {apWkYY: LemApWk Y Y} :
  ∀ (δ: Dom) (x: X), @wks X _ _ δ x = x[@wkms Y _ _ δ].
Proof.
  induction δ; crush' rewrite ?ap_wk, ?ap_comp.
  f_equal; extensionality i;
    cbn; now rewrite ap_wk.
Qed.

Definition ap_id'      := @ap_id.
Definition ap_comp'    := @ap_comp.
Definition ap_vr'      := @ap_vr.
Definition ap_lift'    := @ap_lift.
Definition ap_wk'      := @ap_wk.
Definition ap_wks'     := @ap_wks.
Definition comp_up'    := @comp_up.
Definition lift_vr'    := @lift_vr.
Definition ap_liftSub' := @ap_liftSub.

Arguments ap_id _ _ {_ _} x.
Arguments ap_comp' _ _ _ {_ _ _ _ _ _} x ξ ζ.
Arguments ap_vr' _ _ {_ _ _ _ _} ξ i.
Arguments ap_lift' _ _ _ {_ _ _ _ _ _ _} ζ x.
Arguments ap_wk' _ _ {_ _ _ _ _ _} x.
Arguments ap_wks' _ _ {_ _ _ _ _ _ _ _ _} δ x.
Arguments comp_up' _ _ {_ _ _ _ _ _} ξ ζ.
Arguments lift_vr' _ _ {_ _ _} i.
Arguments ap_liftSub' _ _ {_ _ _ _} t ξ.

(** *** Domains *)

Lemma dunion_assoc (δ₁ δ₂ δ₃: Dom) :
  δ₁ ∪ (δ₂ ∪ δ₃) = (δ₁ ∪ δ₂) ∪ δ₃.
Proof. induction δ₃; cbn; congruence. Qed.

Section Lemmas.

  Local Ltac crush :=
    crush' rewrite ?ap_vr, ?comp_up.

  (* Injectivity is closed under up. *)
  Lemma InjSubIxUp (ξ: Sub Ix) :
    Inj ξ → Inj (ξ ↑).
  Proof.
    intros ? [|?] [|?] ?; cbn in *;
      auto; discriminate.
  Qed.

  (* The following lemmas have more generic versions, but we stick to the
     specialized Ix versions to make proof search easier. *)
  Section Indices.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    (* Up commutes with lift. *)
    Lemma up_liftSub (ξ: Sub Ix) : ⌈ξ⌉↑ = ⌈ξ↑⌉.
    Proof.
      extensionality i; destruct i;
        cbn; now rewrite ?wk_vr.
    Qed.

    Lemma ups_liftSub (δ: Dom) :
      ∀ (ξ: Sub Ix), ⌈ξ⌉ ↑⋆ δ = ⌈ξ ↑⋆ δ⌉.
    Proof.
      induction δ; cbn; intros.
      - reflexivity.
      - now rewrite ?IHδ, ?up_liftSub.
    Qed.
    (* (* Lifting the identity yields the identity. *) *)
    (* Lemma liftSub_id : ⌈idm Ix⌉ = idm X. *)
    (* Proof. reflexivity. Qed. *)

    (* The weakening substitution is just the lifted
         weakening renaming. *)
    Lemma liftSub_wkm : ⌈@wkm Ix _ _⌉ = @wkm X _ _.
    Proof. extensionality i; crush. Qed.

    Lemma liftSub_wkms (δ: Dom) : ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ.
    Proof.
      extensionality i; induction δ; cbn in *.
      - reflexivity.
      - rewrite <- IHδ; cbn.
        rewrite wk_vr; reflexivity.
    Qed.

    Context {apX : Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma liftSub_comp (ξ ζ: Sub Ix) :
      @liftSub Ix _ X _  _ (ξ >=> ζ) = ⌈ξ⌉ >=> ⌈ζ⌉.
    Proof. extensionality i; crush. Qed.

    (* Up commutes with the composition with a lifting
       on the left-hand side .*)
    Lemma up_comp_lift (ξ: Sub Ix) (ζ: Sub X):
      (⌈ξ⌉ >=> ζ)↑ = ⌈ξ↑⌉ >=> ζ↑.
    Proof. extensionality i; destruct i; crush. Qed.

  End Indices.

  Section Weakening.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    Lemma up_idm : up (idm X) = idm X.
    Proof.
      extensionality i; destruct i; cbn;
        now rewrite ?wk_vr.
    Qed.

    Lemma ups_idm (δ: Dom) : ups (idm X) δ = idm X.
    Proof.
      induction δ; cbn;
        now rewrite ?IHδ, ?up_idm.
    Qed.

    Lemma ups_dunion (ξ: Sub X) δ₁ δ₂ :
       ξ ↑⋆ (δ₁ ∪ δ₂) = (ξ ↑⋆ δ₁) ↑⋆ δ₂.
    Proof. induction δ₂; crush. Qed.

    Lemma ups_up (ξ : Sub X) δ : (ξ ↑⋆ δ) ↑ = ξ ↑⋆ (S δ).
    Proof. reflexivity. Qed.

    Lemma wkm_snoc0 : wkm · vr 0 = idm X.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_zero : wkms 0 = idm X.
    Proof. reflexivity. Qed.

    Lemma apply_ups_wks (ξ: Sub X) (δ: Dom) (i: Ix) :
      (ξ ↑⋆ δ) (wks δ i) = wks δ (ξ i).
    Proof. induction δ; crush. Qed.

    Lemma wks_comm δ (ξ: Sub X) :
      ∀ i, wks δ (ξ i) = (ξ ↑⋆ δ) (wks δ i).
    Proof. induction δ; crush. Qed.

    (* Point-wise the weakening substitution is the
       variable injection of the weakening action on
       indices. *)
    Lemma apply_wkms (δ: Dom) (i: Ix) :
      @wkms X _ _ δ i = vr (wks δ i).
    Proof. induction δ; crush. Qed.

    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.

    Lemma apply_up_def_O (ζ: Sub X) :
      (ζ ↑) 0 = vr 0.
    Proof. crush. Qed.

    Lemma apply_up_def_S (ζ: Sub X) :
      ∀ (i: Ix), (ζ ↑) (S i) = (ζ i)[wkm].
    Proof. crush. Qed.

    Lemma up_def (ζ: Sub X) :
      ζ ↑ = (ζ >=> wkm) · vr 0.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_succ (δ: Dom) : wkms (S δ) = wkms δ >=> @wkm X _ _.
    Proof. extensionality i; crush. Qed.

  End Weakening.

  Section Application.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.

    Section Het.
      Context {S: Type}.
      Context {vrS : Vr S}.
      Context {wkS : Wk S}.
      Context {apXS: Ap X S}.

      Lemma comp_id_right (ζ: Sub X) :
        ζ >=> idm S = ζ.
      Proof. extensionality i; crush. Qed.

    End Het.

    Context {apVrX: LemApVr X X}.

    Lemma comp_id_left (ζ: Sub X) :
      @idm X _ >=> ζ = ζ.
    Proof. extensionality i; crush. Qed.

    Lemma comp_snoc (ζ₁ ζ₂: Sub X) t :
      (ζ₁ · t) >=> ζ₂ = (ζ₁ >=> ζ₂) · t[ζ₂].
    Proof. extensionality i; destruct i; reflexivity. Qed.

    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma apply_wk_ap (x: X) (ζ: Sub X) :
      (wk x)[ζ] = x[wkm >=> ζ].
    Proof. now rewrite ap_wk. Qed.

    Lemma apply_wks_ap δ (x: X) (ζ: Sub X) :
      (wks δ x)[ζ] = x[wkms δ >=> ζ].
    Proof. now rewrite ap_wks, ap_comp. Qed.

    (* Always try to associate to the left in rewriting. *)
    Lemma comp_assoc (ζ₁ ζ₂ ζ₃: Sub X) :
      ζ₁ >=> (ζ₂ >=> ζ₃) = (ζ₁ >=> ζ₂) >=> ζ₃.
    Proof. extensionality i; crush. Qed.

    Lemma wkms_comm δ (ξ: Sub X) :
      ξ      >=> wkms δ =
      wkms δ >=> (ξ ↑⋆ δ).
    Proof.
      pose proof apply_wkms.
      pose proof apply_ups_wks.
      pose proof ap_wks.
      extensionality i; crush.
    Qed.

    Lemma wkm_comm (ξ: Sub X) :
      ξ   >=> wkm =
      wkm >=> ξ↑.
    Proof. apply (wkms_comm 1). Qed.

    Context {Y: Type}.
    Context {vrY: Vr Y}.
    Context {wkY: Wk Y}.
    Context {apXY: Ap X Y}.
    Context {compUpX : LemCompUp X Y}.

    Lemma comp_ups (ξ: Sub X) (ζ: Sub Y) (δ: Dom) :
      (ξ >=> ζ) ↑⋆ δ  = (ξ ↑⋆ δ) >=> (ζ ↑⋆ δ).
    Proof. induction δ; crush. Qed.

  End Application.

  Section BetaInteraction.

    Context {X : Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.
    Context {apVrX: LemApVr X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma beta_comm δ (ζ₁ ζ₂: Sub X) :
      beta δ ζ₁  >=> ζ₂  =
      (ζ₂ ↑⋆ δ)  >=> beta δ (ζ₁ >=> ζ₂).
    Proof.
      extensionality i. crush. revert ζ₁ ζ₂ i.
      induction δ; crush.
      destruct i; crush.
      rewrite ap_wk, ap_comp; crush.
      f_equal; extensionality j; crush.
    Qed.

    Lemma apply_beta_wks (δ: Dom) :
      ∀ (ξ: Sub X) i, beta δ ξ (wks δ i) = vr i.
    Proof. induction δ; crush. Qed.

    Lemma wkms_beta_cancel δ (ξ: Sub X) :
      wkms δ >=> beta δ ξ = idm X.
    Proof.
      pose proof apply_wkms.
      pose proof apply_beta_wks.
      extensionality i; crush.
    Qed.

    Lemma beta1_comm (x : X) (ζ: Sub X) :
      beta1 x >=> ζ  =
      (ζ ↑)   >=> beta1 x[ζ].
    Proof. apply (beta_comm 1). Qed.

    Lemma wkm_beta1_cancel (x: X) :
      wkm >=> beta1 x = idm X.
    Proof. apply (wkms_beta_cancel 1). Qed.

  End BetaInteraction.

  Section Misc.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX: Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma wkm_snoc_cancel (ζ: Sub X) t : wkm >=> (ζ · t) = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma snoc_eta_red (ζ: Sub X) : (wkm >=> ζ) · ζ 0 = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

  End Misc.

  (* This subsection contains pointful variables of the pointfree lemmas of the
     previous subsection. These are intended to be user-facing. The Db.Inst
     module populates the infrastructure database with these lemmas and some
     others such that it results in a terminating rewrite system (hopefully). *)
  Section Pointful.

    Context {T X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apTX: Ap T X}.
    Context {apXX: Ap X X}.
    Context {apCompTX: LemApComp T X X}.
    Context {apVrX: LemApVr X X}.
    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.
    Context {compUpX: LemCompUp X X}.

    Local Ltac crushPointful :=
      (* (* Convert renamings into substitutions *) *)
      (* rewrite <- ?ap_liftSub; *)
      (* Go point-free *)
      rewrite ?ap_comp; f_equal;
      (* Flow ups outside *)
      rewrite <- ?comp_up, <- ?comp_ups;
      (* (* Convert lifted weakening renaming into weakening substitution *) *)
      (* rewrite <- ?liftSub_wkm; *)
      (* Apply the point-free lemmas *)
      rewrite ?wkm_comm,
              ?wkm_beta1_cancel,
              ?beta1_comm;
      (* Get rid of identities *)
      rewrite ?up_idm, ?ups_idm, ?ap_id;
      reflexivity.

    Lemma apply_wkm_comm (t: T) (ξ: Sub X) :
      t[ξ][wkm] = t[wkm][ξ↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_cancel (t: T) (x: X) :
      t[wkm][beta1 x] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_comm (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x][ζ] = t[ζ↑][beta1 x[ζ]].
    Proof. crushPointful. Qed.

    (* 1 up variant *)
    Lemma apply_wkm_up_comm (t: T) (ξ: Sub X) :
      t[ξ↑][wkm↑] = t[wkm↑][ξ↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up_cancel (t: T) (x: X) :
      t[wkm↑][(beta1 x)↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑][ζ↑] = t[ζ↑↑][(beta1 x[ζ])↑].
    Proof. crushPointful. Qed.

    (* 2 ups variant *)
    Lemma apply_wkm_up2_comm (t: T) (ξ: Sub X) :
      t[ξ↑↑][wkm↑↑] = t[wkm↑↑][ξ↑↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up2_cancel (t: T) (x: X) :
      t[wkm↑↑][(beta1 x)↑↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up2_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑↑][ζ↑↑] = t[ζ↑↑↑][(beta1 x[ζ])↑↑].
    Proof. crushPointful. Qed.

    (* δ ups variant *)
    Lemma apply_wkm_ups_comm (δ: Dom) (t: T) (ξ: Sub X) :
      t[ξ ↑⋆ δ][wkm ↑⋆ δ] = t[wkm ↑⋆ δ][ξ↑ ↑⋆ δ].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_ups_cancel (δ: Dom) (t: T) (x: X) :
      t[wkm ↑⋆ δ][beta1 x ↑⋆ δ] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_ups_comm (δ: Dom) (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x ↑⋆ δ][ζ ↑⋆ δ] = t[ζ↑ ↑⋆ δ][beta1 x[ζ] ↑⋆ δ].
    Proof. crushPointful. Qed.

  End Pointful.

End Lemmas.

Ltac crushDbLemmasMatchH :=
  match goal with
    | H: context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] |- _ =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) in H by
          refine (eq_sym (ap_vr ξ i))

    | |- context[@up ?X ?vrX ?wkX ?ζ O        ] =>
      change (@up X vrX wkX ζ O) with (@vr X vrX O)
    | |- context[@up _ _ ?wkX (idm _)         ] => rewrite (@up_idm _ _ wkX)
    | |- context[@ups _ _ ?wkX (idm _) ?δ     ] => rewrite (@ups_idm _ _ wkX δ)
    | |- context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) by
          refine (eq_sym (ap_vr ξ i))
  end.

Ltac crushDbLemmasRewriteH :=
  rewrite
    ?dunion_assoc, ?ups_dunion, ?comp_up, ?comp_ups,
    (* ?up_liftSub, ?ups_liftSub, *)
    (* ?ap_liftSub, ?liftSub_wkm, ?liftSub_wkms, ?ap_lift, *)
    <- ?ap_comp,
    ?apply_wkm_comm,     ?apply_wkm_beta1_cancel,     ?apply_beta1_comm,
    ?apply_wkm_up_comm,  ?apply_wkm_beta1_up_cancel,  ?apply_beta1_up_comm,
    ?apply_wkm_up2_comm, ?apply_wkm_beta1_up2_cancel, ?apply_beta1_up2_comm,
    ?apply_wkm_ups_comm, ?apply_wkm_beta1_ups_cancel, ?apply_beta1_ups_comm.

    (* Print liftSub_wkm. *)

    (* Unset Printing Notations. *)
    (* Set Printing Implicit. *)
    (* Print ups_idm. *)

    (* | [|- context[(@liftSub Ix _ ?X _ _ ?ξ)↑]] => replace (@liftSub Ix _ X _ _ ξ)↑ *)
    (*                                                 with (@liftSub Ix _ X _ _ ξ↑) by *)
    (*                                                   exact (eq_sym (up_liftSub ξ)) *)
    (* | [|- context[@liftSub Ix _ ?X _ _ ?ξ ↑⋆ ?δ]] => replace (@liftSub Ix _ X _ _ ξ ↑⋆ δ) *)
    (*                                                 with (@liftSub Ix _ X _ _ (ξ ↑⋆ δ)) by *)
    (*                                                   exact (eq_sym (ups_liftSub δ ξ)) *)

  (* liftSub_id : ⌈idm Ix⌉ = idm X. *)
  (* liftSub_wkm  ⌈@wkm Ix _ _⌉ = @wkm X _ _. *)
  (* liftSub_wkms  ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ. *)