(* ---------------------------------------------------------------------------- *)

(* The syntax of untyped terms. *)

Inductive term :=
  | TVar: nat -> term
  | TAbs: term -> term
  | TApp: term -> term -> term.(* ---------------------------------------------------------------------------- *)

(* The syntax of untyped terms. *)

Inductive term :=
  | TVar: nat -> term
  | TAbs: term -> term
  | TApp: term -> term -> term.(* ---------------------------------------------------------------------------- *)

(* The syntax of untyped terms. *)

Inductive term :=
  | TVar: nat -> term
  | TAbs: term -> term
  | TApp: term -> term -> term.(* ---------------------------------------------------------------------------- *)

(* The syntax of untyped terms. *)

Inductive term :=
  | TVar: nat -> term
  | TAbs: term -> term
  | TApp: term -> term -> term.(* ---------------------------------------------------------------------------- *)

(* The binding structure of terms. *)

Instance Var_term : Var term := {
  var := TVar (* avoid eta-expansion *)
}.Fixpoint traverse_term (f : nat -> nat -> term) l t :=
  match t with
  | TVar x =>
      f l x
  | TAbs t =>
      TAbs (traverse_term f (1 + l) t)
  | TApp t1 t2 =>
      TApp (traverse_term f l t1) (traverse_term f l t2)
  end.Instance Traverse_term : Traverse term term := {
  traverse := traverse_term
}.Instance TraverseVarInjective_term : @TraverseVarInjective term _ term _.Instance TraverseFunctorial_term : @TraverseFunctorial term _ term _.Instance TraverseRelative_term : @TraverseRelative term term _.Instance TraverseIdentifiesVar_term : @TraverseIdentifiesVar term _ _.Instance TraverseVarIsIdentity_term : @TraverseVarIsIdentity term _ term _.(* ---------------------------------------------------------------------------- *)

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2,
      red (TApp (TAbs t1) t2)
          (subst t2 0 t1)
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).(* ---------------------------------------------------------------------------- *)

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2,
      red (TApp (TAbs t1) t2)
          (subst t2 0 t1)
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).(* ---------------------------------------------------------------------------- *)

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2,
      red (TApp (TAbs t1) t2)
          (subst t2 0 t1)
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).(* ---------------------------------------------------------------------------- *)

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2,
      red (TApp (TAbs t1) t2)
          (subst t2 0 t1)
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).(* ---------------------------------------------------------------------------- *)

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2,
      red (TApp (TAbs t1) t2)
          (subst t2 0 t1)
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).(* ---------------------------------------------------------------------------- *)

(* The syntax of System F types. *)

Inductive ty :=
  | TyVar: nat -> ty
  | TyArrow: ty -> ty -> ty
  | TyForall: ty -> ty.(* ---------------------------------------------------------------------------- *)

(* The syntax of System F types. *)

Inductive ty :=
  | TyVar: nat -> ty
  | TyArrow: ty -> ty -> ty
  | TyForall: ty -> ty.(* ---------------------------------------------------------------------------- *)

(* The syntax of System F types. *)

Inductive ty :=
  | TyVar: nat -> ty
  | TyArrow: ty -> ty -> ty
  | TyForall: ty -> ty.(* ---------------------------------------------------------------------------- *)

(* The syntax of System F types. *)

Inductive ty :=
  | TyVar: nat -> ty
  | TyArrow: ty -> ty -> ty
  | TyForall: ty -> ty.(* ---------------------------------------------------------------------------- *)

(* The binding structure of types. *)

Instance Var_ty : Var ty := {
  var := TyVar (* avoid eta-expansion *)
}.Fixpoint traverse_ty (f : nat -> nat -> ty) l T :=
  match T with
  | TyVar x =>
      f l x
  | TyArrow T1 T2 =>
      TyArrow (traverse_ty f l T1) (traverse_ty f l T2)
  | TyForall T =>
      TyForall (traverse_ty f (1 + l) T)
  end.Instance Traverse_ty : Traverse ty ty := {
  traverse := traverse_ty
}.Instance TraverseVarInjective_ty : @TraverseVarInjective ty _ ty _.Instance TraverseFunctorial_ty : @TraverseFunctorial ty _ ty _.Instance TraverseRelative_ty : @TraverseRelative ty ty _.Instance TraverseIdentifiesVar_ty : @TraverseIdentifiesVar ty _ _.Instance TraverseVarIsIdentity_ty : @TraverseVarIsIdentity ty _ ty _.(* ---------------------------------------------------------------------------- *)

(* The tactic [introq] introduces all of the universal quantifiers that appear
   at the head of the goal. *)

Ltac introq :=
  match goal with
  | |- ?P -> ?Q =>
      idtac
  | |- forall _, _ =>
      intro; introq
  | |- _ =>
      idtac
  end.(* ---------------------------------------------------------------------------- *)

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' -> 
      j n E t U'.(* ---------------------------------------------------------------------------- *)

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' -> 
      j n E t U'.(* ---------------------------------------------------------------------------- *)

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' -> 
      j n E t U'.(* ---------------------------------------------------------------------------- *)

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' -> 
      j n E t U'.(* ---------------------------------------------------------------------------- *)

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' -> 
      j n E t U'.(* ---------------------------------------------------------------------------- *)

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' -> 
      j n E t U'.

Lemma type_weakening: forall n E t T, j n E t T -> forall x E' T', map (shift x) E = E' -> shift x T = T' -> j n E' t T'.