(** Infrastructure lemmas and tactic definitions for Fsub.

    Authors: Brian Aydemir and Arthur Charguéraud, with help from
    Aaron Bohannon, Jeffrey Vaughan, and Dimitrios Vytiniotis.

    This file contains a number of definitions, tactics, and lemmas
    that are based only on the syntax of the language at hand.  While
    the exact statements of everything here would change for a
    different language, the general structure of this file (i.e., the
    sequence of definitions, tactics, and lemmas) would remain the
    same.

    Table of contents:
      - #Free variables#
      - #Substitution#
      - #The "pick fresh" tactic#
      - #The "pick fresh and apply" tactic#
      - #Properties of opening and substitution#
      - #Local closure is preserved under substitution#
      - #Automation# *)

Require Export ANF_Definitions.

Require Import Coq.Arith.Peano_dec.

(* ********************************************************************** *)
(** * ## Substitution *)

(** In this section, we define substitution for expression and type
    variables appearing in types, expressions, and environments.
    Substitution differs from opening because opening replaces indices
    whereas substitution replaces free variables.  The definitions
    below are relatively simple for two reasons.
      - We are using locally nameless representation, where bound
        variables are represented using indices.  Thus, there is no
        need to rename variables to avoid capture.
      - The definitions below assume that the term being substituted
        in, i.e., the second argument to each function, is locally
        closed.  Thus, there is no need to shift indices when passing
        under a binder. *)

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else T
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all T1 T2 => typ_all (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_prod T1 T2 => typ_prod (subst_tt Z U T1) (subst_tt Z U T2)
  end.

Fixpoint subst_te (Z : atom) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_var v => exp_var v
  | exp_abs V e1 => exp_abs (subst_tt Z U V)  (subst_te Z U e1)
  | exp_app f x => exp_app f x
  | exp_tabs V e1 => exp_tabs (subst_tt Z U V)  (subst_te Z U e1)
  | exp_tapp x V => exp_tapp x (subst_tt Z U V)
  | exp_let e c => exp_let (subst_te Z U e) (subst_te Z U c)
  | exp_pair x1 x2 => exp_pair x1 x2
  | exp_fst x => exp_fst x
  | exp_snd x => exp_snd x
  end.

Definition subst_vv (z : atom) (y : atom) (v : var) : var :=
  match v with
  | var_b i => var_b i
  | var_f x => if x == z then y else x
  end.

Fixpoint subst_ve (z : atom) (y : atom) (e : exp) {struct e} : exp :=
  match e with
  | exp_var v => subst_vv z y v
  | exp_abs V e1 => exp_abs V (subst_ve z y e1)
  | exp_app f x => exp_app (subst_vv z y f) (subst_vv z y x)
  | exp_tabs V e1 => exp_tabs V (subst_ve z y e1)
  | exp_tapp x V => exp_tapp (subst_vv z y x) V
  | exp_let e c => exp_let (subst_ve z y e) (subst_ve z y c)
  | exp_pair x1 x2 => exp_pair (subst_vv z y x1) (subst_vv z y x2)
  | exp_fst x => exp_fst (subst_vv z y x)
  | exp_snd x => exp_snd (subst_vv z y x)
  end.

Definition subst_tb (Z : atom) (P : typ) (b : binding) : binding :=
  match b with
  | bind_sub T => bind_sub (subst_tt Z P T)
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

(* ********************************************************************** *)
(** * ## The "[pick fresh]" tactic *)

(** The "[pick fresh]" tactic introduces a fresh atom into the context.
    We define it in two steps.

    The first step is to define an auxiliary tactic [gather_atoms],
    meant to be used in the definition of other tactics, which returns
    a set of atoms in the current context.  The definition of
    [gather_atoms] follows a pattern based on repeated calls to
    [gather_atoms_with].  The one argument to this tactic is a
    function that takes an object of some particular type and returns
    a set of atoms that appear in that argument.  It is not necessary
    to understand exactly how [gather_atoms_with] works.  If we add a
    new inductive datatype, say for kinds, to our language, then we
    would need to modify [gather_atoms].  On the other hand, if we
    merely add a new type, say products, then there is no need to
    modify [gather_atoms]; the required changes would be made in
    [fv_tt]. *)

Ltac gather_atoms :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : exp => fv_te x) in
  let D := gather_atoms_with (fun x : var => fv_vv x) in
  let E := gather_atoms_with (fun x : exp => fv_ve x) in
  let F := gather_atoms_with (fun x : typ => fv_tt x) in
  let G := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` E `union` F `union` G).

(** The second step in defining "[pick fresh]" is to define the tactic
    itself.  It is based on the [(pick fresh ... for ...)] tactic
    defined in the [Atom] library.  Here, we use [gather_atoms] to
    construct the set [L] rather than leaving it to the user to
    provide.  Thus, invoking [(pick fresh x)] introduces a new atom
    [x] into the current context that is fresh for "everything" in the
    context. *)

Tactic Notation "pick" "fresh" ident(x) :=
  let L := gather_atoms in (pick fresh x for L).

(* *********************************************************************** *)
(** * ## The "[pick fresh and apply]" tactic *)

(** This tactic is implementation specific only because of its
    reliance on [gather_atoms], which is itself implementation
    specific.  The definition below may be copied between developments
    without any changes, assuming that the other other developments
    define an appropriate [gather_atoms] tactic.  For documentation on
    the tactic on which the one below is based, see the
    [Metatheory] library. *)

Tactic Notation
      "pick" "fresh" ident(atom_name) "and" "apply" constr(lemma) :=
  let L := gather_atoms in
  pick fresh atom_name excluding L and apply lemma.

(* ********************************************************************** *)
(** * ## Properties of opening and substitution *)

(** The following lemmas provide useful structural properties of
    substitution and opening.  While the exact statements are language
    specific, we have found that similar properties are needed in a
    wide range of languages.

    Below, we indicate which lemmas depend on which other lemmas.
    Since [te] functions depend on their [tt] counterparts, a similar
    dependency can be found in the lemmas.

    The lemmas are split into three sections, one each for the [tt],
    [te], and [ee] functions.  The most important lemmas are the
    following:
      - Substitution and opening commute with each other, e.g.,
        [subst_tt_open_tt_var].
      - Opening a term is equivalent to opening the term with a fresh
        name and then substituting for that name, e.g.,
        [subst_tt_intro].

    We keep the sections as uniform in structure as possible.  In
    particular, we state explicitly strengthened induction hypotheses
    even when there are more concise ways of proving the lemmas of
    interest. *)

(* ********************************************************************** *)
(** ** Properties of type substitution in types *)

(** The next lemma is the strengthened induction hypothesis for the
    lemma that follows, which states that opening a locally closed
    term is the identity.  This lemma is not otherwise independently
    useful. *)

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with eauto*.
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
  Case "typ_bvar".
    destruct (j === n)... destruct (i === n)...
Qed.

(** Opening a locally closed term is the identity.  This lemma depends
    on the immediately preceding lemma. *)

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with auto*.
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...
  Case "typ_all".
    unfold open_tt in *.
    pick fresh X.
    apply (open_tt_rec_type_aux T2 0 (typ_fvar X))...
Qed.

(** If a name is fresh for a term, then substituting for it is the
    identity. *)

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with auto*.
  induction T; simpl; intro H; f_equal...
  Case "typ_fvar".
    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

(** Substitution commutes with opening under certain conditions.  This
    lemma depends on the fact that opening a locally closed term is
    the identity. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto*.
  intros T1 T2 X P k WP. revert k.
  induction T1; intros k; simpl; f_equal...
  Case "typ_bvar".
    destruct (k === n); subst...
  Case "typ_fvar".
    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero. *)

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto*.
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---here, we're opening the term with a variable.  In
    practice, this lemma seems to be needed as a left-to-right rewrite
    rule, when stated in its current form. *)

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with auto*.
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

(** The next lemma states that opening a term is equivalent to first
    opening the term with a fresh name and then substituting for the
    name.  This is actually the strengthened induction hypothesis for
    the version we use in practice. *)

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with auto*.
  induction T2; intros U k Fr; simpl in *; f_equal...
  Case "typ_bvar".
    destruct (k === n)... simpl. destruct (X == X)...
  Case "typ_fvar".
    destruct (a == X)... contradict Fr; fsetdec.
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero.  *)

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof with auto*.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in expressions *)

(** This section follows the structure of the previous section.  The
    one notable difference is that we require two auxiliary lemmas to
    show that substituting a type in a locally-closed expression is
    the identity. *)

Lemma open_te_rec_expr_aux : forall e j v i P ,
  open_ve_rec j v e = open_te_rec i P (open_ve_rec j v e) ->
  e = open_te_rec i P e.
Proof with eauto*.
  induction e; intros j u i P H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_te_rec_type_aux : forall e j Q i P,
  i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros j Q i P Neq Heq; simpl in *; inversion Heq;
    f_equal; eauto using open_tt_rec_type_aux.
Qed.

Lemma open_te_rec_expr : forall e U k,
  expr e ->
  e = open_te_rec k U e.
Proof with auto*.
  intros e U k WF. revert k.
  induction WF; intros k; simpl; f_equal; auto using open_tt_rec_type;
  try solve [
    unfold open_ve in *;
    pick fresh x;
    eapply open_te_rec_expr_aux with (j := 0) (v := x);
    auto*
  | unfold open_te in *;
    pick fresh X;
    eapply open_te_rec_type_aux with (j := 0) (Q := typ_fvar X);
    auto*
    ].
Qed.

Lemma subst_te_fresh : forall X U e,
  X `notin` fv_te e ->
  e = subst_te X U e.
Proof.
  induction e; simpl; intros; f_equal; auto using subst_tt_fresh.
Qed.

Lemma subst_te_open_te_rec : forall e T X U k,
  type U ->
  subst_te X U (open_te_rec k T e) =
    open_te_rec k (subst_tt X U T) (subst_te X U e).
Proof.
  intros e T X U k WU. revert k.
  induction e; intros k; simpl; f_equal; auto using subst_tt_open_tt_rec.
Qed.

Lemma subst_te_open_te : forall e T X U,
  type U ->
  subst_te X U (open_te e T) = open_te (subst_te X U e) (subst_tt X U T).
Proof with auto*.
  intros.
  unfold open_te.
  apply subst_te_open_te_rec...
Qed.

Lemma subst_te_open_te_var : forall (X Y:atom) U e,
  Y <> X ->
  type U ->
  open_te (subst_te X U e) Y = subst_te X U (open_te e Y).
Proof with auto*.
  intros X Y U e Neq WU.
  unfold open_te.
  rewrite subst_te_open_te_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_te_intro_rec : forall X e U k,
  X `notin` fv_te e ->
  open_te_rec k U e = subst_te X U (open_te_rec k (typ_fvar X) e).
Proof.
  induction e; intros U k Fr; simpl in *; f_equal;
    auto using subst_tt_intro_rec.
Qed.

Lemma subst_te_intro : forall X e U,
  X `notin` fv_te e ->
  open_te e U = subst_te X U (open_te e X).
Proof with auto*.
  intros.
  unfold open_te.
  apply subst_te_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of expression substitution in expressions *)

(** This section follows the structure of the previous two sections. *)

Lemma open_vv_rec_expand : forall v x i,
  v = open_vv_rec i x v ->
  open_vv_rec i x v = open_vv_rec i x (open_vv_rec i x v).
Proof with auto*.
  intros v x i H.
  unfold open_vv_rec in *.
  destruct v...
  destruct (i === n)...
  destruct (i === n)...
Qed.

Lemma open_vv_rec_collapse : forall v j x y i,
  i <> j ->
  open_vv_rec j x v = open_vv_rec i y (open_vv_rec j x v) ->
  v = open_vv_rec i y v.
Proof with auto*.
  intros v j x y i Neq H.
  unfold open_vv_rec in *.
  destruct v...
  destruct (j === n).
  destruct (i === n)...
  assumption.
Qed.

Lemma open_ve_rec_expr_aux : forall e j x y i,
  i <> j ->
  open_ve_rec j y e = open_ve_rec i x (open_ve_rec j y e) ->
  e = open_ve_rec i x e.
Proof with eauto using open_vv_rec_collapse.
  intros e; induction e; intros j x y i Neq H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_ve_rec_type_aux : forall e j V u i,
  open_te_rec j V e = open_ve_rec i u (open_te_rec j V e) ->
  e = open_ve_rec i u e.
Proof with eauto using open_vv_rec_expand.
  induction e; intros j V u i H; simpl; inversion H; f_equal...
Qed.

Lemma open_ve_rec_expr : forall x e k,
  expr e ->
  e = open_ve_rec k x e.
Proof with auto*.
  intros x e k Hexpr. revert k.
  induction Hexpr; intro k; simpl; f_equal; auto*;
    try solve [
      unfold open_ve in *;
      pick fresh y;
      eapply open_ve_rec_expr_aux with (j := 0) (y := y);
      auto*
    | unfold open_te in *;
      pick fresh Y;
      eapply open_ve_rec_type_aux with (j := 0) (V := typ_fvar Y);
      auto*
    ].
Qed.

Lemma subst_vv_fresh : forall (z : atom) (y : atom) (v : var),
  v <> z ->
  v = subst_vv z y v.
Proof with auto*.
  intros z y v H.
  unfold subst_vv.
  destruct v...
  destruct (a == z)...
Qed.

Lemma subst_ve_fresh : forall (x : atom) (y : atom) e,
  x `notin` fv_ve e ->
  e = subst_ve x y e.
Proof with eauto using subst_vv_fresh.
  intros x u e; induction e; simpl; intro H; f_equal; unfold subst_vv; auto*;
    match goal with
    | [|- ?v = _] =>
      destruct v as [| a];
      auto*;
      destruct (a == x);
      auto*;
      subst;
      simpl in H;
      fsetdec
    end.
Qed.

(*
Lemma subst_ve_open_ve_rec : forall e1 e2 x (u : atom) k,
  subst_ve x u (open_ve_rec k e2 e1) =
    open_ve_rec k (subst_vv x u e2) (subst_ve x u e1).
Proof with auto*.
  intros e1 e2 x u k WP. revert k.
  induction e1; intros k; simpl; f_equal...
  Case "exp_bvar".
    destruct (k === n); subst...
  Case "exp_fvar".
    destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
  expr u ->
  subst_ee x u (open_ee e1 e2) =
    open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with auto*.
  intros.
  unfold open_ee.
  apply subst_ee_open_ee_rec...
Qed.
*)

Lemma subst_ve_open_ve_var : forall (x y : atom) u e k,
  y <> x ->
  open_ve_rec k y (subst_ve x u e) = subst_ve x u (open_ve_rec k y e).
Proof with auto*.
  intros x y u e k Neq. revert k.
  induction e; intros k; simpl; f_equal; unfold subst_vv; auto*;
    match goal with
    | [|- open_vv_rec k y (match ?v with var_b _ => _ | var_f _ => _ end) = _] =>
      unfold open_vv_rec;
      destruct v as [n | a];
      [ destruct (k === n);
        [ destruct (y == x);
          [ contradict e0; assumption
          | auto
          ]
        | auto
        ]
      | destruct (a == x); auto
      ]
    end.
Qed.

Lemma subst_te_open_ve_rec : forall e x Z P k,
  subst_te Z P (open_ve_rec k x e) =
    open_ve_rec k x (subst_te Z P e).
Proof with auto*.
  induction e; intros x Z P k; simpl; f_equal...
Qed.

Lemma subst_te_open_ve : forall e x Z P,
  subst_te Z P (open_ve e x) = open_ve (subst_te Z P e) x.
Proof with auto*.
  intros.
  unfold open_ve.
  apply subst_te_open_ve_rec...
Qed.

Lemma subst_te_open_ve_var : forall Z (x : atom) P e,
  open_ve (subst_te Z P e) x = subst_te Z P (open_ve e x).
Proof with auto*.
  intros.
  rewrite subst_te_open_ve...
Qed.

Lemma subst_ve_open_te_rec : forall e P z u k,
  subst_ve z u (open_te_rec k P e) = open_te_rec k P (subst_ve z u e).
Proof with auto*.
  induction e; intros P z u k; simpl; f_equal...
Qed.

Lemma subst_ve_open_te : forall e P z u,
  subst_ve z u (open_te e P) = open_te (subst_ve z u e) P.
Proof with auto*.
  intros.
  unfold open_te.
  apply subst_ve_open_te_rec...
Qed.

Lemma subst_ve_open_te_var : forall z (X : atom) u e,
  open_te (subst_ve z u e) X = subst_ve z u (open_te e X).
Proof with auto*.
  intros z X u e.
  rewrite subst_ve_open_te...
Qed.

Lemma subst_ve_intro_rec : forall x e y k,
  x `notin` fv_ve e ->
  open_ve_rec k y e = subst_ve x y (open_ve_rec k x e).
Proof with auto*.
  induction e; intros u k Fr; simpl in *; f_equal...
  all: match goal with
  | [|- open_vv_rec ?k ?u ?v = _] => destruct v; unfold open_vv_rec, subst_vv;
      [ destruct (k === n);
        [ destruct (x == x); [ auto | contradict n0; reflexivity ]
        | auto ]
      | destruct (a == x); [ contradict e; simpl in Fr; fsetdec | auto ]
      ]
  end.
Qed.

Lemma subst_ve_intro : forall x e y,
  x `notin` fv_ve e ->
  open_ve e y = subst_ve x y (open_ve e x).
Proof with auto*.
  intros.
  unfold open_ve.
  apply subst_ve_intro_rec...
Qed.

(* *********************************************************************** *)
(** * ## Local closure is preserved under substitution *)

(** While these lemmas may be considered properties of substitution, we
    separate them out due to the lemmas that they depend on. *)

(** The following lemma depends on [subst_tt_open_tt_var]. *)

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...
  Case "type_fvar".
    destruct (X == Z)...
  Case "type_all".
    pick fresh Y and apply type_all...
    rewrite subst_tt_open_tt_var...
Qed.

(** The following lemma depends on [subst_tt_type] and
    [subst_te_open_ee_var]. *)

Lemma subst_te_expr : forall Z P e,
  expr e ->
  type P ->
  expr (subst_te Z P e).
Proof with eauto using subst_tt_type.
  intros Z P e He Hp.
  induction He; simpl; auto using subst_tt_type;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton Z);
    intros;
    try rewrite subst_te_open_ve_var;
    try rewrite subst_te_open_te_var;
    eauto using subst_tt_type
  ].
Qed.

Lemma if_hoist {A B : Type} {C1 C2 : Prop} : forall (c : {C1} + {C2}) (a b : A) (f : A -> B),
  (if c then f a else f b) = f (if c then a else b).
Proof.
  intros c a b f.
  destruct c; reflexivity.
Qed.

(** The following lemma depends on [subst_ee_open_ee_var] and
    [subst_ee_open_te_var]. *)

Lemma subst_ve_expr : forall (z : atom) (y : atom) e,
  expr e ->
  expr (subst_ve z y e).
Proof with auto.
  intros z y e He.
  induction He; simpl; auto;
  try solve [
    econstructor;
    try (instantiate (1 := L `union` singleton z) || instantiate (1 := T));
    intros;
    try rewrite subst_ve_open_ve_var;
    try rewrite subst_ve_open_te_var;
    auto
  ].
  Case "expr_var".
    destruct (x == z)...
  Case "expr_abs".
    apply expr_abs with (L := L `union` singleton z)...
    intros x x_fresh.
    unfold open_ve.
    rewrite subst_ve_open_ve_var...
    apply H1...
  Case "expr_app".
    rewrite (if_hoist (x == z) y x var_f).
    rewrite (if_hoist (y0 == z) y y0 var_f).
    apply expr_app.
  Case "expr_tapp".
    rewrite (if_hoist (x == z) y x var_f).
    apply expr_tapp...
  Case "expr_let".
    apply expr_let with (L := L `union` singleton z)...
    intros x x_fresh.
    unfold open_ve.
    rewrite subst_ve_open_ve_var...
    apply H0...
  Case "expr_pair".
    rewrite (if_hoist (x == z) y x var_f).
    rewrite (if_hoist (y0 == z) y y0 var_f).
    apply expr_pair.
  Case "expr_fst".
    rewrite (if_hoist (x == z) y x var_f).
    apply expr_fst.
  Case "expr_snd".
    rewrite (if_hoist (x == z) y x var_f).
    apply expr_snd.
Qed.

Lemma eq_var_dec : forall v1 v2 : var,
  {v1 = v2} + {v1 <> v2}.
Proof.
  intros [i | a] [j | b]; try (right; discriminate).
  - Case "bound / bound".
    destruct (eq_nat_dec i j).
    + left; f_equal; apply e.
    + right; contradict n; inversion n; reflexivity.
  - Case "free / free".
    destruct (eq_atom_dec a b).
    + left; f_equal; apply e.
    + right; contradict n; inversion n; reflexivity.
Qed.

Lemma eq_typ_dec : forall t1 t2 : typ,
  {t1 = t2} + {t1 <> t2}.
Proof.
  intros t1.
  induction t1; intros t2; destruct t2; try (right; discriminate).
  - Case "typ_top".
    left; reflexivity.
  - Case "typ_bvar".
    destruct (eq_nat_dec n n0).
    + left; f_equal; apply e.
    + right; contradict n1; f_equal; inversion n1; reflexivity.
  - Case "typ_fvar".
    destruct (eq_atom_dec a a0).
    + left; f_equal; apply e.
    + right; contradict n; f_equal; inversion n; reflexivity.
  - Case "typ_arrow".
    destruct (IHt1_1 t2_1), (IHt1_2 t2_2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "typ_all".
    destruct (IHt1_1 t2_1), (IHt1_2 t2_2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "typ_prod".
    destruct (IHt1_1 t2_1), (IHt1_2 t2_2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
Qed.

Lemma eq_exp_dec : forall e1 e2 : exp,
  {e1 = e2} + {e1 <> e2}.
Proof.
  intros e1.
  induction e1; intros e2; destruct e2; try (right; discriminate).
  - Case "exp_var".
    destruct (eq_var_dec v v0).
    + left; f_equal; apply e.
    + right; contradict n; f_equal; inversion n; reflexivity.
  - Case "exp_abs".
    destruct (eq_typ_dec t t0), (IHe1 e2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "exp_app".
    destruct (eq_var_dec v v1), (eq_var_dec v0 v2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "exp_tabs".
    destruct (eq_typ_dec t t0), (IHe1 e2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "exp_tapp".
    destruct (eq_typ_dec t t0), (eq_var_dec v v0); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "exp_let".
    destruct (IHe1_1 e2_1), (IHe1_2 e2_2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "exp_pair".
    destruct (eq_var_dec v v1), (eq_var_dec v0 v2); subst; try (right; contradict n; inversion n; reflexivity).
    left; reflexivity.
  - Case "exp_fst".
    destruct (eq_var_dec v v0).
    + left; f_equal; apply e.
    + right; contradict n; f_equal; inversion n; reflexivity.
  - Case "exp_snd".
    destruct (eq_var_dec v v0).
    + left; f_equal; apply e.
    + right; contradict n; f_equal; inversion n; reflexivity.
Qed.

(* *********************************************************************** *)
(** * ## Automation *)

(** We add as hints the fact that local closure is preserved under
    substitution.  This is part of our strategy for automatically
    discharging local-closure proof obligations. *)

#[global]
Hint Resolve subst_tt_type subst_te_expr subst_ve_expr : core.

(** When reasoning about the [binds] relation and [map], we
    occasionally encounter situations where the binding is
    over-simplified.  The following hint undoes that simplification,
    thus enabling [Hint]s from the [Environment] library. *)

#[global]
Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tb X U (F T)) : core.


(** * Definition of PTS with Judgmental Equality (PTSe)
 Here we will define what is a judgmental equality and some
 basic results.*)
 (** The main difference between PTS and PTSe is that we do
 not rely here on bare beta-conversion, but we also check that
 every step of the conversion is welltyped.*)
Require Import PTS_base.
Require Import PTS_term.
Require Import PTS_red.
Require Import PTS_env.
Require Import List.
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt Le Gt.
Require Import Plus Minus.
Require Import PTS_type.
Require Import PTS_sr.

Module Type ut_typ_eq_mod (X:term_sig) (Y:pts_sig X) (TM:ut_term_mod X) (EM:ut_env_mod X TM) (RM: ut_red_mod X TM)
 (SRM: ut_sr_mod X Y TM EM RM).
 Import X Y TM EM RM SRM.

(** Typing Rules.*)
Reserved Notation "Γ ⊢e t : T" (at level 80, t, T at level 30, no associativity) .
Reserved Notation "Γ ⊢e M = N : T" (at level 80, M, N , T at level 30, no associativity).
Reserved Notation "Γ ⊣e " (at level 80, no associativity).

Inductive wf : Env -> Prop :=
 | wfe_nil : nil ⊣e
 | wfe_cons : forall Γ A s, Γ ⊢e A : !s -> A::Γ ⊣e
where "Γ ⊣e" := (wf Γ) : UT_scope
with typ : Env -> Term -> Term -> Prop :=
 | cSort : forall Γ s t, Ax s t -> Γ ⊣e -> Γ  ⊢e !s : !t
 | cVar : forall  Γ A v, Γ ⊣e -> A ↓ v  ⊂ Γ -> Γ ⊢e #v : A
 | cPi : forall Γ A B s t u,
     Rel s t u -> Γ ⊢e A : !s -> A::Γ ⊢e B : !t -> Γ ⊢e  Π(A), B : !u
 | cLa : forall Γ A b B s1 s2 s3, Rel s1 s2 s3 -> Γ ⊢e  A : !s1 -> A::Γ ⊢e B : !s2 ->
     A::Γ ⊢e b : B -> Γ ⊢e λ[A], b: Π(A), B
 | cApp : forall Γ a b A B , Γ ⊢e a : Π(A), B -> Γ ⊢e b :  A -> Γ ⊢e a·b : B[←b]
 | Cnv : forall Γ a A B s,
      Γ ⊢e A = B  : !s -> Γ ⊢e a : A -> Γ ⊢e a : B
where "Γ ⊢e t : T" := (typ Γ t T) : UT_scope
with typ_eq : Env -> Term -> Term -> Term -> Prop :=
 |cPi_eq : forall Γ A A' B B' s t u, Rel s t u -> Γ ⊢e A = A' : !s -> (A::Γ)⊢e B = B' : !t ->
   Γ ⊢e Π(A),B = Π(A'),B' : !u
 | cLa_eq : forall Γ A A' B M M' s t u, Rel s t u -> Γ ⊢e A = A' : !s -> (A::Γ) ⊢e M = M' : B ->
   (A::Γ) ⊢e B : !t -> Γ ⊢e λ[A],M = λ[A'],M' : Π(A),B
 | cApp_eq : forall Γ M M' N N' A B, Γ ⊢e M = M' : Π(A),B -> Γ⊢e N = N' : A ->
     Γ ⊢e M·N = M'·N' : B [← N]
 | cRefl : forall Γ M A, Γ ⊢e M : A -> Γ ⊢e M = M : A
 | cSym : forall Γ M N A , Γ ⊢e M = N : A -> Γ ⊢e N = M : A
 | cTrans : forall Γ M N P A, Γ ⊢e M = N : A -> Γ ⊢e N = P : A -> Γ ⊢e M = P : A
 | Cnv_eq : forall Γ M N A B s, Γ ⊢e A = B : !s -> Γ ⊢e M = N : A -> Γ ⊢e M = N : B
 | cBeta : forall Γ A B M N s t u, Rel s t u -> Γ ⊢e A : !s -> (A::Γ) ⊢e B : !t ->
    (A::Γ) ⊢e M : B -> Γ ⊢e N : A -> Γ ⊢e (λ[A],M)·N = M[← N] : B[← N]
where "Γ ⊢e M = N : T":= (typ_eq Γ M N T) : UT_scope.

Hint Constructors wf typ typ_eq.

Open Scope UT_scope.

(* begin hide *)
Scheme typ_ind' := Induction for typ Sort Prop
      with typ_eq_ind' := Induction for typ_eq Sort Prop
      with wf_ind' := Induction for wf Sort Prop.

Combined Scheme typ_induc from typ_ind', typ_eq_ind',  wf_ind'.
(* end hide *)

(** These lemmas are almost the same as for declarative PTS:
  - well formation of contexts
  - weakening
  - substitution
  - type correctness
  - ...
    *)
Lemma wf_typ : forall Γ t T, Γ ⊢e t : T -> Γ ⊣e.
induction 1; intros; intuition.
Qed.

Lemma wf_typ_eq : forall Γ M N T, Γ ⊢e M = N : T -> Γ ⊣e.
induction 1;  intuition.
apply wf_typ in H; trivial.
apply wf_typ in H0; trivial.
Qed.

Hint Resolve wf_typ wf_typ_eq.

Theorem weakening: (forall Δ M T, Δ ⊢e M : T -> forall Γ A s n Δ', ins_in_env Γ A n Δ Δ' ->   Γ ⊢e A :!s ->
                 Δ' ⊢e M ↑ 1 # n : T ↑ 1 # n ) /\
                (forall Δ M N T, Δ ⊢e M = N : T -> forall Γ A s n Δ', ins_in_env Γ A n Δ Δ' ->   Γ ⊢e A :!s ->
                 Δ' ⊢e M ↑ 1 # n = N ↑ 1 # n : T ↑ 1 # n ) /\
(forall Γ, Γ ⊣e -> forall Δ Γ' n A , ins_in_env Δ A n Γ Γ' -> forall s, Δ ⊢e A : !s -> Γ' ⊣e).
apply typ_induc; simpl in *; intros.
(*1*)
eauto.
(*2*)
destruct le_gt_dec.
constructor. eapply H;  eauto. destruct i as (AA & ?& ?). exists AA; split. rewrite H2.
change (S (S v)) with (1+ S v). rewrite liftP3; trivial. intuition. simpl; constructor; trivial. eapply ins_item_ge.
apply H0. trivial. trivial. constructor. eapply H; eauto.  eapply ins_item_lift_lt. apply H0. trivial. trivial.
(*3*)
econstructor. apply r. eapply H; eauto. eapply H0. constructor; apply H1. apply H2.
(*4*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
(*5*)
change n with (0+n). rewrite substP1. simpl.
econstructor. eapply H; eauto. eapply H0; eauto.
(*6*)
apply Cnv with (A↑ 1 # n) s; intuition.
eapply H; eauto. eapply H0; eauto.
(**)
apply cPi_eq with s t. trivial. eapply H; eauto. eapply H0; eauto.
(**)
apply cLa_eq with s t u; trivial. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
(**)
change n with (0+n). rewrite substP1. simpl.
apply cApp_eq with (A↑ 1 # n). eapply H; eauto. eapply H0; eauto.
(**) constructor; eapply H; eauto. (**) econstructor; eauto. (**) econstructor; eauto. (**) econstructor; eauto.
(**)
change n with (0+n). rewrite 2! substP1. simpl.
apply cBeta with s t u; eauto.
(* wf *)
inversion H; subst; clear H. eauto.
(**)
inversion  H0; subst; clear H0.
eauto.
apply wfe_cons with s; trivial. change !s with !s ↑ 1 # n0.
eapply H.  apply H6. apply H1.
Qed.

Theorem thinning :
   forall Γ M T A s,
      Γ ⊢e M  : T ->
   Γ ⊢e A : !s ->
   A::Γ ⊢e M ↑ 1 : T ↑ 1.
intros.
eapply weakening. apply H. constructor. apply H0.
Qed.

Theorem thinning_n : forall n Δ Δ',
   trunc n Δ Δ' ->
   forall M T , Δ' ⊢e M  : T  -> Δ ⊣e ->
               Δ ⊢e M ↑ n : T ↑ n.
intro n; induction n; intros.
inversion H; subst; clear H.
rewrite ! lift0; trivial.
inversion H; subst; clear H.
change (S n) with (1+n).
replace (M ↑ (1+n)) with ((M ↑ n )↑ 1) by (apply lift_lift).
replace (T ↑ (1+n)) with ((T ↑ n) ↑ 1) by (apply lift_lift).
inversion H1; subst; clear H1.
apply thinning with s; trivial.
eapply IHn. apply H3. trivial. apply wf_typ in H2; trivial.
Qed.

Theorem thinning_eq :
   forall Γ M N T A s,
      Γ ⊢e M = N : T ->
   Γ ⊢e A : !s ->
   A::Γ ⊢e M ↑ 1 = N ↑ 1 : T ↑ 1.
intros.
eapply weakening. apply H. constructor. apply H0.
Qed.

Theorem thinning_eq_n : forall n Δ Δ',
   trunc n Δ Δ' ->
   forall M N T , Δ' ⊢e M = N : T  -> Δ ⊣e ->
               Δ ⊢e M ↑ n = N ↑ n: T ↑ n.
intro n; induction n; intros.
inversion H; subst; clear H.
rewrite 3! lift0; trivial.
inversion H; subst; clear H.
change (S n) with (1+n).
replace (M ↑ (1+n)) with ((M ↑ n )↑ 1) by (apply lift_lift).
replace (N ↑ (1+n)) with ((N ↑ n )↑ 1) by (apply lift_lift).
replace (T ↑ (1+n)) with ((T ↑ n) ↑ 1) by (apply lift_lift).
inversion H1; subst; clear H1.
apply thinning_eq with s; trivial.
eapply IHn. apply H3. trivial. apply wf_typ in H2; trivial.
Qed.

Lemma conv_in_env_var : forall C n Γ, C ↓ n ∈ Γ ->
  forall Γ1 Γ2 A B s, Γ = Γ2++(A::Γ1) -> Γ1 ⊢e A = B : !s -> n < List.length Γ2 ->
  C ↓ n ∈ Γ2++(B::Γ1).
induction 1; intros.
destruct Γ2; simpl in *. apply lt_n_O in H1; elim H1.
injection H; intros; subst; clear H.
constructor.

destruct Γ2; simpl in *. apply lt_n_O in H2; elim H2.
injection H0; intros; subst; clear H0.
constructor. apply IHitem with A s; trivial.
intuition.
Qed.

Lemma conv_in_env_var2 : forall C n Γ, C ↓ n ∈ Γ ->
  forall Γ1 Γ2 A B s , Γ = Γ2++(A::Γ1) -> Γ1 ⊢e A = B : !s ->
  List.length Γ2 < n ->
  C ↓ n ∈ Γ2++(B::Γ1).
induction 1; intros.
apply lt_n_O in H1; elim H1.
destruct Γ2; simpl in *.
injection H0; intros; subst; clear H0.
constructor. trivial.

destruct Γ2; simpl in *.
constructor. injection H0; intros; subst; clear H0.

inversion H; subst; clear H. apply lt_irrefl in H2; elim H2.
constructor. trivial.
injection H0; intros; subst; clear H0.
constructor. rewrite app_comm_cons. apply IHitem with A s; trivial.
simpl. intuition.
Qed.

Lemma conv_in_env_var3 : forall Γ1 (B:Term) Γ2 , B ↓ (List.length Γ1) ∈ Γ1++(B::Γ2).
induction Γ1; intros.
simpl. constructor.
simpl. constructor. apply IHΓ1.
Qed.

Lemma conv_in_env_var_lift : forall C n Γ, C ↓ n ⊂ Γ ->
  forall Γ1 Γ2 A B s, Γ = Γ2 ++(A::Γ1) -> Γ1 ⊢e A = B : !s -> n < List.length Γ2 ->
  C ↓ n ⊂ Γ2++(B::Γ1).
intros.
destruct H as (u & h1 & h2).
apply (conv_in_env_var u n Γ) with Γ1 Γ2 A B s in h2; trivial.
exists u; intuition.
Qed.

Lemma conv_in_env_var_lift2 : forall C n Γ, C ↓ n ⊂ Γ ->
  forall Γ1 Γ2 A B s, Γ = Γ2++(A::Γ1) -> Γ1 ⊢e A = B : !s ->
  List.length Γ2 < n -> C ↓ n ⊂ Γ2++(B::Γ1).
intros.
destruct H as (u & h1 & h2).
apply (conv_in_env_var2 u n Γ) with Γ1 Γ2 A B s in h2; trivial.
exists u; intuition.
Qed.

Lemma conv_in_env_var_lift3 : forall Γ1 (A:Term) Γ2 ,
  (A ↑ (S (List.length Γ1))) ↓ (List.length Γ1) ⊂ Γ1++(A::Γ2).
induction Γ1; intros.
simpl. exists A; intuition.
simpl.
assert( H := IHΓ1 A Γ2).
destruct H as ( ?& ?& ?).
apply inv_lift in H. subst.
exists x; intuition.
Qed.

Lemma conv_in_env_aux_trunc : forall A (Γ1 Γ2:list A) B ,
  trunc (S (length Γ1)) (Γ1  ++ B :: Γ2) Γ2.
induction Γ1; simpl; intros.
constructor; constructor.
constructor.
apply IHΓ1.
Qed.

(** Conversion is the context is here provable without SR since every reduction
step is checked valid.*)
Theorem conv_in_env : (forall Γ M T, Γ ⊢e  M : T-> forall Γ1 Γ2 A B s, Γ = Γ1++(A::Γ2) -> Γ2 ⊢e A = B : !s ->
  Γ2 ⊢e B : !s -> (Γ1++(B::Γ2)) ⊢e M : T) /\
 (forall Γ M N T, Γ ⊢e  M = N : T-> forall Γ1 Γ2 A B s, Γ = Γ1++(A::Γ2) -> Γ2 ⊢e A = B : !s ->
  Γ2 ⊢e B : !s -> (Γ1++(B::Γ2)) ⊢e M = N : T ) /\
 (forall Γ, Γ ⊣e -> forall Γ1 Γ2 A B s, Γ = Γ1++(A::Γ2) -> Γ2 ⊢e A = B : !s -> Γ2 ⊢e B : !s -> Γ1++(B::Γ2) ⊣e).
apply typ_induc; intros; simpl in *.
(**)
constructor. trivial. apply H with A s0; trivial.
(**)
destruct (lt_eq_lt_dec v (List.length Γ1)) as [ [] | ].
econstructor. apply H with A0 s; trivial. eapply conv_in_env_var_lift. apply i. apply H0. apply H1. trivial.
subst. destruct i as (a & ?& ?). subst. replace a with A0 in *. apply Cnv with (B↑ (S (length Γ1))) s.
change !s with (!s↑ (S (length Γ1))). apply thinning_eq_n with Γ2. apply conv_in_env_aux_trunc. intuition.
apply H with A0 s; trivial.  constructor. apply H with A0 s; trivial. exists B; intuition.
clear. induction Γ1; simpl in *. constructor. constructor; intuition.
generalize H3; clear. revert Γ2 A0 a. induction Γ1; intros; simpl in *. inversion H3;subst; clear H3. trivial.
inversion H3; subst; clear H3. eapply IHΓ1. apply H0.
econstructor. apply H with A0 s; trivial. eapply conv_in_env_var_lift2. apply i. apply H0. apply H1. trivial.
(**)
apply cPi with s t;trivial. apply H with A0 s0; trivial.
rewrite app_comm_cons. eapply H0. rewrite H1; simpl; reflexivity. apply H2. trivial.
(**)
apply cLa with s1 s2 s3;trivial. apply H with A0 s; trivial.
rewrite app_comm_cons. eapply H0. rewrite H2; simpl; reflexivity. apply H3. trivial.
rewrite app_comm_cons. eapply H1. rewrite H2; simpl; reflexivity. apply H3. trivial.
(**)
apply cApp with A. apply H with A0 s; trivial. apply H0 with A0 s; trivial.
(**)
apply Cnv with A s; trivial. apply H with A0 s0; trivial. apply H0 with A0 s0; trivial.
(**)
apply cPi_eq with s t;trivial. apply H with A0 s0; trivial.
rewrite app_comm_cons. eapply H0. rewrite H1; simpl; reflexivity. apply H2. trivial.
(**)
apply cLa_eq with s t u;trivial. apply H with A0 s0; trivial.
rewrite app_comm_cons. eapply H0. rewrite H2; simpl; reflexivity. apply H3. trivial.
rewrite app_comm_cons. eapply H1. rewrite H2; simpl; reflexivity. apply H3. trivial.
(**)
apply cApp_eq with A. apply H with A0 s; trivial. apply H0 with A0 s; trivial.
(**)
apply cRefl. apply H with A0 s; trivial.
(**)
apply cSym. apply H with A0 s; trivial.
(**)
apply cTrans with N. apply H with A0 s; trivial. apply H0 with A0 s; trivial.
(**)
apply Cnv_eq with A s; trivial. apply H with A0 s0; trivial. apply H0 with A0 s0; trivial.
(**)
apply cBeta with s t u; trivial. apply H with A0 s0; trivial.
rewrite app_comm_cons. eapply H0. rewrite H3; simpl; reflexivity. apply H4. trivial.
rewrite app_comm_cons. eapply H1. rewrite H3; simpl; reflexivity. apply H4. trivial.
apply H2 with A0 s0; trivial.
(**)
destruct Γ1; simpl in *; discriminate.
(**)
destruct Γ1; simpl in *. injection H0;intros;  subst; clear H0. eauto.
injection H0; intros; subst; clear H0.
econstructor. apply H with A0 s0; trivial.
Qed.

(* The Substitution Lemma: we need to do it in several step because of the sym rule
of equality *)
Lemma substitution : (forall Γ t T , Γ  ⊢e t  : T  -> forall Δ P A, Δ  ⊢e P : A ->
 forall Γ' n , sub_in_env Δ P A n Γ Γ' ->  Γ' ⊢e t [ n ←P ]  : T [ n ←P ]) /\
(forall Γ M N T , Γ  ⊢e M = N  : T  -> forall Δ P A, Δ  ⊢e P : A ->
 forall Γ' n , sub_in_env Δ P A n Γ Γ' ->  Γ' ⊢e M [ n ←P ] = N [ n ←P ] : T [ n ←P ]) /\
 (forall Γ ,  Γ ⊣e -> forall Δ P A n Γ' , Δ ⊢e P : A ->
  sub_in_env  Δ P A n Γ Γ' ->     Γ' ⊣e) .
apply typ_induc; simpl; intros.
(*1*)
constructor. trivial. eapply H. apply H0. apply H1.
(*2*)
destruct lt_eq_lt_dec  as [ [] | ].
constructor. eapply H; eauto. eapply nth_sub_item_inf. apply H1. intuition. trivial.
destruct i as (AA & ?& ?). subst. rewrite substP3; trivial.
rewrite <- (nth_sub_eq H1 H3).
eapply thinning_n. eapply sub_trunc. apply H1. trivial. eapply H;  eauto. intuition.
constructor. eapply H; eauto. destruct i as (AA & ? &?). subst.  rewrite substP3; trivial.
exists AA; split. replace (S (v-1)) with v. trivial. rewrite <- pred_of_minus. rewrite <- (S_pred v n l); trivial.
eapply nth_sub_sup. apply H1. destruct v. apply lt_n_O in l; elim l. replace (S v - 1 ) with v. intuition.
rewrite <- pred_of_minus. simpl.  trivial. replace (S (v-1)) with v. trivial. rewrite <- pred_of_minus. rewrite <- (S_pred v n l); trivial.
intuition.  simpl; intuition.
(*4*)
econstructor. apply r. eapply H; eauto. eapply H0. apply H1. constructor; apply H2. eauto.
(*5*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
(*6*)
rewrite subst_travers. econstructor.
replace (n+1) with (S n) by (rewrite plus_comm; trivial). eapply H; eauto.
replace (n+1) with (S n) by (rewrite plus_comm; trivial).  eapply H0; eauto.
(*7*)
econstructor. eapply H. apply H1. trivial. eapply H0. apply H1. trivial.
(**)
apply cPi_eq with s t. trivial. eapply H. apply H1. trivial. eapply H0. apply H1. constructor; trivial.
(**)
apply cLa_eq with s t u. trivial. eapply H. apply H2. trivial. eapply H0. apply H2. constructor; trivial.
eapply H1. apply H2. constructor; trivial.
(**)
rewrite subst_travers. apply cApp_eq with (A[n ← P]). replace (Π (A [n ← P]), B [(n + 1) ← P]) with (Π(A),B)[n← P].
eapply H. apply H1. trivial. simpl; replace (n+1) with (S n). trivial. rewrite plus_comm; trivial.
eapply H0. apply H1. trivial.
(**)
constructor. eapply H. apply H0. trivial.
(**)
constructor.  eapply H. apply H0. trivial.
(**)
apply cTrans with (N[n← P0]). eauto. eauto.
(**)
apply Cnv_eq with (A[n ← P]) s. eapply H. apply H1.  trivial. eapply H0. apply H1. trivial.
(**)
rewrite 2! subst_travers. simpl in *. replace (n+1) with (S n) by (rewrite plus_comm; trivial). apply cBeta with s t u. trivial.
eapply H. apply H3. trivial. eapply H0. apply H3. constructor;  trivial. eapply H1. apply H3. constructor; trivial.
eapply H2. apply H3. trivial.
(* wf *)
inversion H0.
inversion H1; subst; clear H1. apply wf_typ in H0; trivial.
econstructor. eapply H. apply H0. trivial.
Qed.

(** Here is the generalization of the substitution **)
Lemma substitution2 : forall Γ t T , Γ  ⊢e t  : T  -> forall Δ P P' A, Δ  ⊢e P = P': A ->
  Δ  ⊢e P : A -> forall Γ' n , sub_in_env Δ P A n Γ Γ' ->  Γ' ⊢e t [ n ←P ]  = t [ n ← P'] : T [ n ←P ].
induction 1; intros; simpl in *.
(*1*)
constructor. constructor. trivial. eapply substitution.  apply H0. apply H2. apply H3.
(*2*)
destruct lt_eq_lt_dec as [ [] | ].
constructor. constructor. eapply substitution. apply H. apply H2. apply H3.
eapply nth_sub_item_inf. apply H3. intuition. trivial.
destruct H0 as (AA & ?& ?).
subst. rewrite substP3; intuition.
rewrite <- (nth_sub_eq H3 H4).
eapply thinning_eq_n. eapply sub_trunc. apply H3. trivial. eapply substitution. apply H. apply H2. apply H3.
constructor. constructor. eapply substitution. apply H. apply H2.  apply H3. destruct H0 as (AA & ? &?). subst.  rewrite substP3; intuition.
exists AA; split. replace (S (v-1)) with v. trivial. rewrite <- pred_of_minus. rewrite <- (S_pred v n l). trivial.
eapply nth_sub_sup. apply H3. intuition. destruct v. apply lt_n_O in l; elim l. rewrite <- pred_of_minus. simpl; trivial.
intuition. replace (S (v-1)) with v. trivial. rewrite <- pred_of_minus. rewrite <- (S_pred v n l). trivial.
(*4*)
apply cPi_eq with s t; trivial.  eapply IHtyp1.  apply H2. trivial.  trivial. eapply IHtyp2. apply H2. trivial. constructor; trivial.
(*5*)
apply cLa_eq with s1 s2 s3; trivial. eapply IHtyp1.  apply H3. trivial.  trivial. eapply IHtyp3. apply H3. trivial. constructor; trivial.
change !s2 with (!s2[(S n)← P]). eapply substitution. apply H1. apply H4. constructor; trivial.
(*6*)
rewrite subst_travers. apply cApp_eq with (A[n← P]).
replace (n+1) with (S n) by (rewrite plus_comm; trivial).  eapply IHtyp1; eauto.
replace (n+1) with (S n) by (rewrite plus_comm; trivial).  eapply IHtyp2; eauto.
(*7*)
apply Cnv_eq with (A[n← P]) s. change !s with (!s[n ← P]). eapply substitution. apply H. apply H2. trivial.
eapply IHtyp. apply H1. trivial. trivial.
Qed.

Lemma wf_item : forall Γ A n, A ↓ n ∈ Γ ->
   forall  Γ', Γ ⊣e ->  trunc (S n) Γ Γ' -> exists s, Γ' ⊢e A : !s.
induction 1; intros.
inversion H0; subst; clear H0.
inversion H5; subst; clear H5.
inversion H; subst.
exists s; trivial.
inversion H1; subst; clear H1.
inversion H0; subst.
apply IHitem; trivial. apply wf_typ in H2; trivial.
Qed.

Lemma wf_item_lift : forall Γ t n ,Γ ⊣e  -> t ↓ n ⊂ Γ ->
  exists s,  Γ ⊢e t  : !s.
intros.
destruct H0 as (u & ? & ?).
subst.
assert (exists Γ' , trunc (S n) Γ Γ') by (apply item_trunc with u; trivial).
destruct H0 as (Γ' & ?).
destruct (wf_item Γ u n H1 Γ' H H0) as (t &  ?).
exists t. change !t with (!t ↑(S n)).
eapply thinning_n. apply H0. trivial. trivial.
Qed.

Lemma wgen_pi : forall Γ A B T, Γ ⊢e Π(A),B : T -> exists s, exists t, exists u, Rel s t u /\
 Γ ⊢e A : !s /\ (A::Γ) ⊢e B : !t.
intros. remember (Π(A),B) as P. revert A B HeqP. induction H; intros; subst; try discriminate.
injection HeqP; intros; subst; clear HeqP. exists s; exists t; exists u; split.
trivial. split; trivial.
destruct (IHtyp A0 B0) as (a & b& c & h); trivial. decompose [and] h; clear h.
exists a; exists b; exists c; split; trivial. split; trivial.
Qed.

(** Reflexivity and Type Correctness:
since we have symetry, and we did not check for the well formation of the function type
in the app-eq rule, we need to prove all at once:
 * Type Correctness
 * Left-Hand Reflexivity
 * Right-Hand Reflexivity
**)
Lemma TypeCorrect_Refl : (forall Γ M T, Γ ⊢e M : T -> exists s, T = !s \/ Γ ⊢e T : !s) /\
  (forall Γ M N T, Γ ⊢e M = N : T -> Γ ⊢e M : T /\ Γ ⊢e N : T /\ exists s, T = !s \/ Γ ⊢e T : !s) /\
  (forall Γ, Γ ⊣e -> True).
apply typ_induc; intros; simpl in *.
exists t; left; trivial.
(**)
apply wf_item_lift in i. destruct i.  exists x; right ; trivial. trivial.
(**)
exists u; left; trivial.
(**)
exists s3; right. apply cPi with s1 s2; trivial.
(**)
destruct H. destruct H. discriminate.
apply wgen_pi in H as (s1 & s2 & s3 & h). decompose [and] h; clear h.
exists s2; right. change !s2 with (!s2 [← b]). eapply substitution. apply H3. apply t0. constructor.
(**)
destruct H as (? & ? &?). exists s; right; trivial.
(**)
destruct H as (? & ?& ?), H0 as (? & ?& ?). split.
apply cPi with s t; trivial. split. apply cPi with s t; trivial.
change (A'::Γ) with (nil++A'::Γ). eapply conv_in_env. apply H3. simpl; reflexivity. apply t0. trivial.
exists u; left; trivial.
(**)
destruct H as (? & ?& ?), H0 as (? & ?& ?). split. apply cLa with s t u; trivial.
split. apply Cnv with (Π(A'),B) u. apply cPi_eq with s t; intuition. change (A'::Γ) with (nil++A'::Γ).
eapply conv_in_env. constructor. apply t2. simpl; reflexivity. apply t0. trivial.
apply cLa with s t u; trivial. change (A'::Γ) with (nil++A'::Γ).
eapply conv_in_env. apply t2. simpl; reflexivity. apply t0. trivial.
change (A'::Γ) with (nil++A'::Γ). eapply conv_in_env. apply H4. simpl; reflexivity. apply t0. trivial.
exists u; right. apply cPi with s t; trivial.
(**)
destruct H as (? & ? & ?), H0 as (? & ?& ?). split. apply cApp with A; trivial. split.
destruct H2 as (s & ?). destruct H2. discriminate. apply wgen_pi in H2 as (a & b & c & h); decompose [and] h ;clear h.
apply Cnv with (B[← N']) b. change !b with (!b[← N]). apply cSym. eapply substitution2.
apply H7. apply t0. trivial. constructor. apply cApp with A; trivial.
destruct H2. destruct H2. discriminate. apply wgen_pi in H2 as (a & b & c & h); decompose [and] h; clear h.
exists b; right. change !b with (!b[←N]). eapply substitution. apply H7. apply H0. constructor.
(**)
intuition.
(**)
intuition.
(**)
destruct H as (? & ?& ?), H0 as (? & ? & ?).
intuition.
(**)
destruct H as (? & ?& ?), H0 as (? & ?& ?).
split. apply Cnv with A s; trivial. split. apply Cnv with A s; trivial.
exists s; right; trivial.
(**)
split. apply cApp with A; trivial. apply cLa with s t u; trivial. split.
eapply substitution. apply t2. apply t3. constructor. exists t; right.
change !t with (!t[← N]). eapply substitution. apply t1. apply t3. constructor.
(**)
trivial. trivial.
Qed.

Lemma TypeCorrect : forall Γ M T, Γ ⊢e M : T -> exists s, T = !s \/ Γ ⊢e T : !s.
apply TypeCorrect_Refl.
Qed.

Lemma TypeCorrect_eq :  forall Γ M N T, Γ ⊢e M = N : T -> exists s, T = !s \/ Γ ⊢e T : !s.
intros. apply TypeCorrect_Refl in H. intuition.
Qed.

Lemma left_reflexivity : forall Γ M N T, Γ ⊢e M = N : T -> Γ ⊢e M : T.
intros. apply TypeCorrect_Refl in H. intuition.
Qed.

Lemma right_reflexivity : forall Γ M N T, Γ ⊢e M = N : T -> Γ ⊢e N : T.
intros. apply TypeCorrect_Refl in H. intuition.
Qed.

(** We can easily prove that every judgement in PTSe is a valid one in PTS.
It's just a matter of "forgetting" typing information during the conversion.*)
Lemma FromPTSe_to_PTS : (forall Γ M T, Γ ⊢e M : T -> Γ ⊢ M : T) /\
  (forall Γ M N T, Γ ⊢e M = N : T -> Γ ⊢ M : T /\ Γ ⊢ N : T /\ M ≡ N) /\
  (forall Γ, Γ ⊣e -> Γ ⊣).
apply typ_induc; intros; simpl in *.
(**)
intuition.
(**)
intuition.
(**)
apply SRM.cPi with s t; trivial.
(**)
apply SRM.cLa with s1 s2 s3; trivial.
(**)
apply SRM.cApp with A; trivial.
destruct H as (? & ? & ?). apply SRM.Cnv with A s; trivial.
(**)
destruct H as (? & ?& ?). destruct H0 as ( ? & ? & ?).
split. apply SRM.cPi with s t; trivial. split. apply SRM.cPi with s t; trivial.
apply Betac_confl in H2 as (Z & ?& ?). apply Betas_env_sound_up with (Z::Γ).
apply Betas_env_sound with (A::Γ). trivial. apply Betas_env_hd; trivial.
econstructor. apply H1. apply Betas_env_hd; trivial. intuition.
(**)
destruct H as (? & ?& ?). destruct H0 as (? & ?& ?).
split. apply SRM.cLa with s t u; trivial. split. apply SRM.Cnv with (Π(A'),B) u.
intuition. apply SRM.cLa with s t u; trivial.
apply Betac_confl in H3 as (Z & ?& ?). apply Betas_env_sound_up with (Z::Γ).
apply Betas_env_sound with (A::Γ). trivial. apply Betas_env_hd; trivial.
econstructor. apply H2. apply Betas_env_hd; trivial.
apply Betac_confl in H3 as (Z & ?& ?). apply Betas_env_sound_up with (Z::Γ).
apply Betas_env_sound with (A::Γ). trivial. apply Betas_env_hd; trivial.
econstructor. apply H2. apply Betas_env_hd; trivial.
apply SRM.cPi with s t; trivial. intuition.
(**)
destruct H as (? & ?& ?). destruct H0 as (? & ?& ?).
split. apply SRM.cApp with A; trivial. split.
assert (exists s, A::Γ ⊢ B : !s). apply SRM.TypeCorrect in H. destruct H as [ [s ?]| [ s ?] ].
discriminate. apply gen_pi in H as (a & b & c & h);decompose [and] h; clear h. exists b; trivial.
destruct H5 as (b & ?). apply SRM.Cnv with (B[← N']) b. intuition.
apply SRM.cApp with A; trivial. change !b with (!b[← N]). eapply SRM.substitution.
apply H5. apply H0. constructor. apply SRM.wf_typ in H5; trivial. intuition.
(**)
intuition.
(**)
intuition.
(**)
destruct H as (? & ?& ?), H0 as (? & ?& ?). intuition. eauto.
(**)
destruct H as (? & ?& ?). destruct H0 as ( ?& ?& ?).
split. apply SRM.Cnv with A s; trivial. split. apply SRM.Cnv with A s; trivial. trivial.
(**)
split. apply SRM.cApp with A. apply SRM.cLa with s t u; trivial. trivial.
split. eapply SRM.substitution. apply H1. apply H2. constructor. eauto. intuition.
(**)
intuition.
(**)
eauto.
Qed.

End ut_typ_eq_mod.