(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ *)

Set Implicit Arguments.

(** The type of If-then-else expressions *)

Inductive cexpr : Set := At : cexpr | If : cexpr → cexpr → cexpr → cexpr.

Notation α := At.
Notation ω := If.
Notation Ω := cexpr.

(** The graph 𝔾 : Ω -> Ω -> Prop of nm
    with notation x ⟼ y for (𝔾 x y)
 *)

Reserved Notation "x '⟼n' y" (at level 70, no associativity).

Inductive 𝔾nm : Ω → Ω → Prop :=
  | in_gnm_0 :     α ⟼n α
  | in_gnm_1 y ny z nz :
                   y ⟼n ny
                 → z ⟼n nz
                 → ω α y z ⟼n ω α ny nz
  | in_gnm_2 u v w y z na nb nc :
                   ω v y z ⟼n na
                 → ω w y z ⟼n nb
                 → ω u na nb ⟼n nc
                 → ω (ω u v w) y z ⟼n nc
where "x ⟼n y" := (𝔾nm x y).

(** 𝔾nm is a functional/deterministic graph *)

Fact 𝔾nm_fun e n1 n2 : e ⟼n n1  →  e ⟼n n2  →  n1 = n2.
Proof.
  intros H; revert H n2.
  induction 1 as [
                 | y ny z nz H1 IH1 H2 IH2
                 | u v w y z na nb nc H1 IH1 H2 IH2 H3 IH3 ]; inversion 1; subst; auto.
  - f_equal; auto.
  - apply IH1 in H9; subst.
    apply IH2 in H10; subst.
    apply IH3 in H11; subst.
    auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.Instance.Coq.Category.
Require Import CT.Instance.Functor.ContravariantFunctor.

(** * Presheaves

A presheaf is a contravariant functor whose codomain is [Set].
In this case we use the category [CoqType] of Coq types instead of [Set].
*)
Program Definition Presheaf (C : Category) := ContravariantFunctor C CoqType.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e401m31_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Coq.Arith.Arith.

Require Import Axioms.

From istari Require Import Sigma Tactics Equality Ordinal Page.

Import List.ListNotations.

Inductive term: Set :=
| var : nat -> term
| nattp_m : term
| z_m : term
| succ_m : term -> term
| arrow_m : term -> term -> term
| lam_m : term -> term
| app_m : term -> term -> term
| comp_m : term -> term
| ret_m : term -> term
| bind_m : term -> term -> term
| reftp_m: term -> term
| ref_m : term -> term
| deref_m: term -> term
| asgn_m: term -> term -> term
| triv_m: term
| unittp_m: term.

Definition context := list term.

Fixpoint traverse (S:Set) (enter : S -> S) (resolve : S -> nat -> term) (s : S) (t : term) {struct t} : term :=
  match t with
   | var i => resolve s i
   | nattp_m => nattp_m
   | z_m => z_m
   | succ_m t1 => succ_m (traverse S enter resolve s t1)
   | arrow_m t1 t2 => arrow_m (traverse S enter resolve s t1) (traverse S enter resolve s t2)
   | lam_m t1 => lam_m (traverse S enter resolve (enter s) t1)
   | app_m t1 t2 => app_m (traverse S enter resolve s t1) (traverse S enter resolve s t2)
   | comp_m t1 => comp_m (traverse S enter resolve s t1)
   | ret_m t1 => ret_m (traverse S enter resolve s t1)
   | bind_m t1 t2 => bind_m (traverse S enter resolve s t1) (traverse S enter resolve (enter s) t2)
   | reftp_m t1 => reftp_m (traverse S enter resolve s t1)
   | ref_m t1 => ref_m (traverse S enter resolve s t1)
   | deref_m t1 => deref_m (traverse S enter resolve s t1)
   | asgn_m R v => asgn_m (traverse S enter resolve s R) (traverse S enter resolve s v)
   | triv_m => triv_m
   | unittp_m => unittp_m end.

Ltac prove_traverse_parametric ind :=
intros S S' R enter enter' resolve resolve' s s' t Henter Hresolve Hs;
generalize dependent s';
generalize dependent s;
induction t using ind; intros s s' Hs;
[apply Hresolve; apply Hs | ..];  (* deal with first goal (var) *)
simpl;
try reflexivity;  (* dispense with trivial goals *)
f_equal;
(* find and apply IH *)
try
  ((match goal with
    | IH : (forall (s : S) (s' : S'), _ -> _ = ?f _ ?t)
      |- _ = ?g _ ?t
      => apply IH
    end);
   repeat (apply Henter);
   apply Hs).

Ltac prove_traverse_id ind :=
intros S R enter resolve s t Henter Hresolve Hs;
generalize dependent s;
induction t using ind; intros s Hs;
[apply Hresolve; apply Hs | ..];  (* deal with first goal (var) *)
simpl;
try reflexivity;  (* dispense with trivial goals *)
f_equal;
(* find and apply IH *)
try ((match goal with
      | IH : (forall (s : S), _ -> _ = ?t)
        |- _ = ?t
        => apply IH
      end);
     repeat (apply Henter);
     apply Hs).

Ltac prove_traverse_compose ind :=
intros S S' enter enter' resolve resolve' s s' t;
generalize dependent s';
generalize dependent s;
induction t using ind; intros s s';
[simpl; reflexivity | ..];  (* deal with first goal (var) *)
simpl;
try reflexivity;  (* dispense with trivial goals *)
f_equal;
(* find and apply IH *)
try (match goal with
      | IH : (forall (s : S) (s' : S'), _ = ?f ?t)
        |- _ = ?g ?t
        => apply IH
      end).

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

Lemma traverse_parametric :
  forall (S:Set) (S':Set) (R : S -> S' -> Prop) enter enter' resolve resolve' s s' t,
    (forall s s', R s s' -> R (enter s) (enter' s'))
    -> (forall s s' i, R s s' -> resolve s i = resolve' s' i)
    -> R s s'
    -> traverse S enter resolve s t = traverse S' enter' resolve' s' t.
Proof.
prove_traverse_parametric term_ind.
Qed.

Lemma traverse_id :
  forall (S:Set) (R : S -> Prop) enter resolve s t,
    (forall s, R s -> R (enter s))
    -> (forall s i, R s -> resolve s i = var i)
    -> R s
    -> traverse S enter resolve s t = t.
Proof.
prove_traverse_id term_ind.
Qed.

Lemma traverse_compose :
  forall (S:Set) (S':Set) enter enter' resolve resolve' s s' t,
    traverse S enter resolve s (traverse S' enter' resolve' s' t)
    = traverse (S * S')
      (fun p => let (s, s') := p in (enter s, enter' s'))
      (fun p i => let (s, s') := p in traverse S enter resolve s (resolve' s' i))
      (s, s') t.
Proof.
prove_traverse_compose term_ind.
Qed.

Definition termx := term.
Definition varx := var.


Section Yoneda.

  Variable P : Type.
  Variable Hom : P -> P -> Type.
  Variable Comp : forall {p q r}, Hom q r -> Hom p q -> Hom p r.
  Variable Id : forall p, Hom p p.
  Variable Id_L : forall {p q} (f:Hom p q), Comp _ _ _ f (Id p) = f.
  Variable Id_R : forall {p q} (f:Hom p q), Comp _ _ _ (Id q) f = f.

Definition Y (p: P) := fun r => Hom r p.

Definition YHom (p q : P) := forall r, Y p r -> Y q r.

Definition YComp {p q r : P} (g: YHom q r) (f: YHom p q) : YHom p r :=
  fun r' k => g _ (f _ k).

Infix "°" := YComp (at level 55).

Definition YId (p: P) : YHom p p :=
  fun r' k => k.

Definition Yassoc p q r s (f : YHom p q) (g : YHom q r) (h : YHom r s)
           : (h ° g) ° f = h ° (g ° f) := eq_refl.

Definition YId_R p q (f : YHom p q)
           : YId _ ° f = f := eq_refl.

Definition YId_L p q (f : YHom p q)
           : f ° YId _  = f := eq_refl.

Definition Yoneda_embedding_l {p q : P} : Hom p q -> YHom p q :=
  fun f r k => Comp _ _ _ f k.

Definition Yoneda_embedding_r {p q : P} : YHom p q -> Hom p q :=
  fun k => k p (Id p).

Definition Yoneda_embedding_lr (p q : P) (f:Hom p q) :
  Yoneda_embedding_r (Yoneda_embedding_l f) = f := Id_L _ _ f.

End Yoneda.

Definition Yoneda_fun := forall
    (P : Type)
    (Hom : P -> P -> Type)
    (Comp : forall {p q r}, Hom q r -> Hom p q -> Hom p r)
    (Id : forall p, Hom p p)
    p q, YHom P Hom p q.

(* Require Import Parametricity. *)
(* Parametricity Yoneda_fun arity 2. *)

(* Here is the result, for those who don't have the plugin of Marc Lasson *)

Definition Yoneda_fun_R := fun (H H0 : Yoneda_fun) =>
   forall (P₁ P₂ : Type) (P_R : P₁ -> P₂ -> Type)
     (Hom₁ : P₁ -> P₁ -> Type) (Hom₂ : P₂ -> P₂ -> Type)
     (Hom_R : forall (H1 : P₁) (H2 : P₂),
              P_R H1 H2 ->
              forall (H3 : P₁) (H4 : P₂),
              P_R H3 H4 -> Hom₁ H1 H3 -> Hom₂ H2 H4 -> Type)
     (Comp₁ : forall p q r : P₁, Hom₁ q r -> Hom₁ p q -> Hom₁ p r)
     (Comp₂ : forall p q r : P₂, Hom₂ q r -> Hom₂ p q -> Hom₂ p r),
   (forall (p₁ : P₁) (p₂ : P₂) (p_R : P_R p₁ p₂)
      (q₁ : P₁) (q₂ : P₂) (q_R : P_R q₁ q₂) (r₁ : P₁)
      (r₂ : P₂) (r_R : P_R r₁ r₂) (H1 : Hom₁ q₁ r₁)
      (H2 : Hom₂ q₂ r₂),
    Hom_R q₁ q₂ q_R r₁ r₂ r_R H1 H2 ->
    forall (H3 : Hom₁ p₁ q₁) (H4 : Hom₂ p₂ q₂),
    Hom_R p₁ p₂ p_R q₁ q₂ q_R H3 H4 ->
    Hom_R p₁ p₂ p_R r₁ r₂ r_R (Comp₁ p₁ q₁ r₁ H1 H3)
      (Comp₂ p₂ q₂ r₂ H2 H4)) ->
   forall (Id₁ : forall p : P₁, Hom₁ p p) (Id₂ : forall p : P₂, Hom₂ p p),
   (forall (p₁ : P₁) (p₂ : P₂) (p_R : P_R p₁ p₂),
    Hom_R p₁ p₂ p_R p₁ p₂ p_R (Id₁ p₁) (Id₂ p₂)) ->
   forall (p₁ : P₁) (p₂ : P₂) (p_R : P_R p₁ p₂) (q₁ : P₁)
     (q₂ : P₂) (q_R : P_R q₁ q₂) (r₁ : P₁) (r₂ : P₂)
     (r_R : P_R r₁ r₂) (H3 : Hom₁ r₁ p₁) (H4 : Hom₂ r₂ p₂),
   Hom_R r₁ r₂ r_R p₁ p₂ p_R H3 H4 ->
   Hom_R r₁ r₂ r_R q₁ q₂ q_R (H P₁ Hom₁ Comp₁ Id₁ p₁ q₁ r₁ H3)
         (H0 P₂ Hom₂ Comp₂ Id₂ p₂ q₂ r₂ H4).

Axiom Yoneda_fun_param_thm : forall (f g:Yoneda_fun), Yoneda_fun_R f g.

Axiom fun_ext : forall A (B:A -> Type) (f g : forall a: A, B a),
    (forall x, f x = g x) -> f = g.

Definition transport {A x y} (P:A -> Type) (p:x = y) (X:P y) : P x.
destruct p; exact X.
Defined.

Definition inv {A} (x y:A) (p:x = y) : y = x.
destruct p. reflexivity.
Defined.

Notation "p '#' x " := (transport _ p x) (at level 55).

Definition Yoneda_fun_param (f:Yoneda_fun) (P : Type)
    (Hom : P -> P -> Type)
    (Comp : forall p q r, Hom q r -> Hom p q -> Hom p r)
    (Id : forall p, Hom p p)
    (p q : P) r k :
    f P Hom Comp Id p q r k = Comp r p q (f P Hom Comp Id p q p (Id _)) k.
  pose (f_R := Yoneda_fun_param_thm f
          (fun P Hom Comp Id p q r k => Comp r p q (f P Hom Comp Id p q p (Id _)) k)).
   unfold Yoneda_fun_R in f_R.
   specialize (f_R P P (fun x y => x = y) Hom Hom). simpl in f_R.
   specialize (f_R (fun x x' Hx y y' Hy f g => f =
   transport (fun X => Hom X _) Hx (transport (fun X => Hom _ X) Hy g))).
   assert (H_Comp : forall (p₁ p₂ : P) (p_R : p₁ = p₂) (q₁ q₂ : P)
           (q_R : q₁ = q₂) (r₁ r₂ : P) (r_R : r₁ = r₂)
           (H : Hom q₁ r₁) (H0 : Hom q₂ r₂),
         H =
         transport (fun X : P => Hom X r₁) q_R
           (transport (fun X : P => Hom q₂ X) r_R H0) ->
         forall (H1 : Hom p₁ q₁) (H2 : Hom p₂ q₂),
         H1 =
         transport (fun X : P => Hom X q₁) p_R
           (transport (fun X : P => Hom p₂ X) q_R H2) ->
         Comp p₁ q₁ r₁ H H1 =
         transport (fun X : P => Hom X r₁) p_R
           (transport (fun X : P => Hom p₂ X) r_R (Comp p₂ q₂ r₂ H0 H2))).
   intros. destruct p_R, q_R, r_R. simpl in *. destruct H1, H4. reflexivity.
   assert (H_Id : forall (p₁ p₂ : P) (p_R : p₁ = p₂),
         Id p₁ =
         transport (fun X : P => Hom X p₁) p_R
           (transport (fun X : P => Hom p₂ X) p_R (Id p₂))).
   intros. destruct p_R. reflexivity.
   specialize (f_R Comp Comp H_Comp Id Id H_Id). simpl in f_R.
   exact (f_R p p eq_refl q q eq_refl r r eq_refl k k eq_refl).
Defined.

Definition Yoneda_embedding_rl (P : Type)
    (Hom : P -> P -> Type)
    (Comp : forall p q r, Hom q r -> Hom p q -> Hom p r)
    (Id : forall p, Hom p p)
    (p q : P) (f:Yoneda_fun) :
    Yoneda_embedding_l P Hom Comp (Yoneda_embedding_r P Hom Id (f P Hom Comp Id p q)) = (f P Hom Comp Id p q).
   refine (fun_ext _ _ _ _ _). intro r.
   refine (fun_ext _ _ _ _ _). intro k.
   unfold Yoneda_embedding_r, Yoneda_embedding_l.
   apply inv. exact (Yoneda_fun_param f P Hom Comp Id p q r k).
Defined.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Replacement_B.

Coq < Goal forall a b c:Prop, (a -> ~(b /\ c)) /\ (a /\ c) -> (~b).
1 subgoal

  ============================
   forall a b c : Prop, (a -> ~ (b /\ c)) /\ a /\ c -> ~ b

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a -> ~ (b /\ c)) /\ a /\ c
  ============================
   ~ b

Unnamed_thm < elim H.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a -> ~ (b /\ c)) /\ a /\ c
  ============================
   (a -> ~ (b /\ c)) -> a /\ c -> ~ b

Unnamed_thm < intro.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a -> ~ (b /\ c)) /\ a /\ c
  H0 : a -> ~ (b /\ c)
  ============================
   a /\ c -> ~ b

Unnamed_thm < intro.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a -> ~ (b /\ c)) /\ a /\ c
  H0 : a -> ~ (b /\ c)
  H1 : a /\ c
  ============================
   ~ b

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined
*)

Section Replacement_B.
Goal forall a b c:Prop, (a -> ~(b /\ c)) /\ (a /\ c) -> (~b).
intros.
elim H.
intro.
intro.
firstorder.
Qed.


(***************************************************************************
* Preservation and Progress for System F<: with Closed Functions           *
* - allow capture of type variables in closed functions                    *
*                                                                          *
* (based on the F<: implementation in locally-nameless project)            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.
Implicit Types X : var.

(* ********************************************************************** *)
(** * Description of the Language *)

(** Representation of pre-types *)

Inductive typ : Set :=
  | typ_top   : typ
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_all   : typ -> typ -> typ.

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_cap  : typ -> trm -> trm           (* capsule lambda - closed *)
  | trm_app  : trm -> trm -> trm
  | trm_tabs : typ -> trm -> trm
  | trm_tapp : trm -> typ -> trm.

(** Opening up a type binder occuring in a type *)

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top         => typ_top
  | typ_bvar J      => If K = J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all T1 T2   => typ_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

(** Opening up a type binder occuring in a term *)

Fixpoint open_te_rec (K : nat) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | trm_cap V e1  => trm_cap  (open_tt_rec K U V)  (open_te_rec K U e1)
  | trm_app e1 e2 => trm_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | trm_tabs V e1 => trm_tabs (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | trm_tapp e1 V => trm_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Definition open_te t U := open_te_rec 0 U t.

(** Opening up a term binder occuring in a term *)

Fixpoint open_ee_rec (k : nat) (f : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs V (open_ee_rec (S k) f e1)
  | trm_cap V e1  => trm_cap V (open_ee_rec (S k) f e1)
  | trm_app e1 e2 => trm_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | trm_tabs V e1 => trm_tabs V (open_ee_rec k f e1)
  | trm_tapp e1 V => trm_tapp (open_ee_rec k f e1) V
  end.

Definition open_ee t u := open_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "T 'open_tt_var' X" := (open_tt T (typ_fvar X)) (at level 67).
Notation "t 'open_te_var' X" := (open_te t (typ_fvar X)) (at level 67).
Notation "t 'open_ee_var' x" := (open_ee t (trm_fvar x)) (at level 67).

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (typ_all T1 T2).

(** Terms as locally closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L V e1,
      type V ->
      (forall x, x \notin L -> term (e1 open_ee_var x)) ->
      term (trm_abs V e1)
  | term_cap : forall L V e1,
      type V ->
      (forall x, x \notin L -> term (e1 open_ee_var x)) ->
      term (trm_cap V e1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2)
  | term_tabs : forall L V e1,
      type V ->
      (forall X, X \notin L -> term (e1 open_te_var X)) ->
      term (trm_tabs V e1)
  | term_tapp : forall e1 V,
      term e1 ->
      type V ->
      term (trm_tapp e1 V).

(** Binding are either mapping type or term variables.
 [X ~<: T] is a subtyping asumption and [x ~: T] is
 a typing assumption *)

Inductive bind : Set :=
  | bind_sub : typ -> bind
  | bind_typ : typ -> bind.

Notation "X ~<: T" := (X ~ bind_sub T)
  (at level 23, left associativity) : env_scope.
Notation "x ~: T" := (x ~ bind_typ T)
  (at level 23, left associativity) : env_scope.

(** Environment is an associative list of bindings. *)

Definition env := LibEnv.env bind.

(* get environment for typing types *)
Fixpoint typ_env (E: env) := match E with
  | nil => nil
  | cons (X, bind_sub U) E' => cons (X, bind_sub U) (typ_env E')
  | cons (_, bind_typ _) E' => typ_env E'
  end.

(** Well-formedness of a pre-type T in an environment E:
  all the type variables of T must be bound via a
  subtyping relation in E. This predicates implies
  that T is a type *)

Inductive wft : env -> typ -> Prop :=
  | wft_top : forall E,
      wft E typ_top
  | wft_var : forall U E X,
      binds X (bind_sub U) E ->
      wft E (typ_fvar X)
  | wft_arrow : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_arrow T1 T2)
  | wft_all : forall L E T1 T2,
      wft E T1 ->
      (forall X, X \notin L ->
        wft (E & X ~<: T1) (T2 open_tt_var X)) ->
      wft E (typ_all T1 T2).

(** A environment E is well-formed if it contains no duplicate bindings
  and if each type in it is well-formed with respect to the environment
  it is pushed on to. *)

Inductive okt : env -> Prop :=
  | okt_empty :
      okt empty
  | okt_sub : forall E X T,
      okt E -> wft E T -> X # E -> okt (E & X ~<: T)
  | okt_typ : forall E x T,
      okt E -> wft E T -> x # E -> okt (E & x ~: T).

(** Subtyping relation *)

Inductive sub : env -> typ -> typ -> Prop :=
  | sub_top : forall E S,
      okt E ->
      wft E S ->
      sub E S typ_top
  | sub_refl_tvar : forall E X,
      okt E ->
      wft E (typ_fvar X) ->
      sub E (typ_fvar X) (typ_fvar X)
  | sub_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      sub E U T ->
      sub E (typ_fvar X) T
  | sub_arrow : forall E S1 S2 T1 T2,
      sub E T1 S1 ->
      sub E S2 T2 ->
      sub E (typ_arrow S1 S2) (typ_arrow T1 T2)
  | sub_all : forall L E S1 S2 T1 T2,
      sub E T1 S1 ->
      (forall X, X \notin L ->
          sub (E & X ~<: T1) (S2 open_tt_var X) (T2 open_tt_var X)) ->
      sub E (typ_all S1 S2) (typ_all T1 T2).

(** Typing relation *)

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x (bind_typ T) E ->
      typing E (trm_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x, x \notin L ->
        typing (E & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_abs V e1) (typ_arrow V T1)
  | typing_cap: forall L E V e1 T1,   (* v2: allow capture type variable *)
      okt E ->
      (forall x, x \notin L ->
        typing ((typ_env E) & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_cap V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (trm_app e1 e2) T2
  | typing_tabs : forall L E V e1 T1,
      (forall X, X \notin L ->
        typing (E & X ~<: V) (e1 open_te_var X) (T1 open_tt_var X)) ->
      typing E (trm_tabs V e1) (typ_all V T1)
  | typing_tapp : forall T1 E e1 T T2,
      typing E e1 (typ_all T1 T2) ->
      sub E T T1 ->
      typing E (trm_tapp e1 T) (open_tt T2 T)
  | typing_sub : forall S E e T,
      typing E e S ->
      sub E S T ->
      typing E e T.

(** Values *)

Inductive value : trm -> Prop :=
  | value_abs  : forall V e1, term (trm_abs V e1) ->
                 value (trm_abs V e1)
  | value_cap  : forall V e1, term (trm_cap V e1) ->
                 value (trm_cap V e1)
  | value_tabs : forall V e1, term (trm_tabs V e1) ->
                 value (trm_tabs V e1).

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      term e2 ->
      red e1 e1' ->
      red (trm_app e1 e2) (trm_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (trm_app e1 e2) (trm_app e1 e2')
  | red_tapp : forall e1 e1' V,
      type V ->
      red e1 e1' ->
      red (trm_tapp e1 V) (trm_tapp e1' V)
  | red_abs : forall V e1 v2,
      term (trm_abs V e1) ->
      value v2 ->
      red (trm_app (trm_abs V e1) v2) (open_ee e1 v2)
  | red_cap : forall V e1 v2,
      term (trm_cap V e1) ->
      value v2 ->
      red (trm_app (trm_cap V e1) v2) (open_ee e1 v2)
  | red_tabs : forall V1 e1 V2,
      term (trm_tabs V1 e1) ->
      type V2 ->
      red (trm_tapp (trm_tabs V1 e1) V2) (open_te e1 V2).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall E e e' T,
  typing E e T ->
  red e e' ->
  typing E e' T.

Definition progress := forall e T,
  typing empty e T ->
     value e
  \/ exists e', red e e'.

(* ********************************************************************** *)
(** * Additional Definitions Used in the Proofs *)

(** Computing free type variables in a type *)

Fixpoint fv_tt (T : typ) {struct T} : vars :=
  match T with
  | typ_top         => \{}
  | typ_bvar J      => \{}
  | typ_fvar X      => \{X}
  | typ_arrow T1 T2 => (fv_tt T1) \u (fv_tt T2)
  | typ_all T1 T2   => (fv_tt T1) \u (fv_tt T2)
  end.

(** Computing free type variables in a term *)

Fixpoint fv_te (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{}
  | trm_abs V e1  => (fv_tt V) \u (fv_te e1)
  | trm_cap V e1  => (fv_tt V) \u (fv_te e1)
  | trm_app e1 e2 => (fv_te e1) \u (fv_te e2)
  | trm_tabs V e1 => (fv_tt V) \u (fv_te e1)
  | trm_tapp e1 V => (fv_tt V) \u (fv_te e1)
  end.

(** Computing free term variables in a type *)

Fixpoint fv_ee (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs V e1  => (fv_ee e1)
  | trm_cap V e1  => (fv_ee e1)
  | trm_app e1 e2 => (fv_ee e1) \u (fv_ee e2)
  | trm_tabs V e1 => (fv_ee e1)
  | trm_tapp e1 V => (fv_ee e1)
  end.

(** Substitution for free type variables in types. *)

Fixpoint subst_tt (Z : var) (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 (typ_fvar X)
  | 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)
  end.

(** Substitution for free type variables in terms. *)

Fixpoint subst_te (Z : var) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs  (subst_tt Z U V)  (subst_te Z U e1)
  | trm_cap V e1  => trm_cap  (subst_tt Z U V)  (subst_te Z U e1)
  | trm_app e1 e2 => trm_app  (subst_te Z U e1) (subst_te Z U e2)
  | trm_tabs V e1 => trm_tabs (subst_tt Z U V)  (subst_te Z U e1)
  | trm_tapp e1 V => trm_tapp (subst_te Z U e1) (subst_tt Z U V)
  end.

(** Substitution for free term variables in terms. *)

Fixpoint subst_ee (z : var) (u : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs V e1  => trm_abs V (subst_ee z u e1)
  | trm_cap V e1  => trm_cap V (subst_ee z u e1)
  | trm_app e1 e2 => trm_app (subst_ee z u e1) (subst_ee z u e2)
  | trm_tabs V e1 => trm_tabs V (subst_ee z u e1)
  | trm_tapp e1 V => trm_tapp (subst_ee z u e1) V
  end.

(** Substitution for free type variables in environment. *)

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

(* ********************************************************************** *)
(** * Tactics *)

(** Constructors as hints. *)

Hint Constructors type term wft ok okt value red.

Hint Resolve
  sub_top sub_refl_tvar sub_arrow
  typing_var typing_app typing_tapp typing_sub.

(** Gathering free names already used in the proofs *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : trm => fv_te x) in
  let D := gather_vars_with (fun x : trm => fv_ee x) in
  let E := gather_vars_with (fun x : typ => fv_tt x) in
  let F := gather_vars_with (fun x : env => dom x) in
  constr:(A \u B \u C \u D \u E \u F).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

Ltac get_env :=
  match goal with
  | |- wft ?E _ => E
  | |- sub ?E _ _  => E
  | |- typing ?E _ _ => E
  end.

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (concat_empty_r E);
  eapply lemma; try rewrite concat_empty_r.

Tactic Notation "apply_empty" constr(F) :=
  apply_empty_bis (get_env) F.

Tactic Notation "apply_empty" "*" constr(F) :=
  apply_empty F; autos*.

(** Tactic to undo when Coq does too much simplification *)

Ltac unsimpl_map_bind :=
  match goal with |- context [ ?B (subst_tt ?Z ?P ?U) ] =>
    unsimpl ((subst_tb Z P) (B U)) end.

Tactic Notation "unsimpl_map_bind" "*" :=
  unsimpl_map_bind; autos*.

(* ********************************************************************** *)
(** * Properties of Substitutions *)

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

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_tt_rec_type_core : forall T j V U i, 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.
  induction T; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_tt_rec_type : forall T U,
  type T -> forall k, T = open_tt_rec k U T.
Proof.
  induction 1; intros; simpl; f_equal*. unfolds open_tt.
  pick_fresh X. apply* (@open_tt_rec_type_core T2 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_tt_fresh : forall Z U T,
  Z \notin fv_tt T -> subst_tt Z U T = T.
Proof.
  induction T; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P n, type P ->
  subst_tt X P (open_tt_rec n T2 T1) =
  open_tt_rec n (subst_tt X P T2) (subst_tt X P T1).
Proof.
  introv WP. generalize n.
  induction T1; intros k; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_tt_rec_type.
Qed.

Lemma subst_tt_open_tt : forall T1 T2 X P, type P ->
  subst_tt X P (open_tt T1 T2) =
  open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof.
  unfold open_tt. autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_tt_open_tt_var : forall X Y U T, Y <> X -> type U ->
  (subst_tt X U T) open_tt_var Y = subst_tt X U (T open_tt_var Y).
Proof.
  introv Neq Wu. rewrite* subst_tt_open_tt.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_tt_intro : forall X T2 U,
  X \notin fv_tt T2 -> type U ->
  open_tt T2 U = subst_tt X U (T2 open_tt_var X).
Proof.
  introv Fr Wu. rewrite* subst_tt_open_tt.
  rewrite* subst_tt_fresh. simpl. case_var*.
Qed.

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

Lemma open_te_rec_term_core : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H; f_equal*; f_equal*.
Qed.

Lemma open_te_rec_type_core : 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; simpl in *; inversion H0; f_equal*;
  match goal with H: ?i <> ?j |- ?t = open_tt_rec ?i _ ?t =>
   apply* (@open_tt_rec_type_core t j) end.
Qed.

Lemma open_te_rec_term : forall e U,
  term e -> forall k, e = open_te_rec k U e.
Proof.
  intros e U WF. induction WF; intros; simpl;
    f_equal*; try solve [ apply* open_tt_rec_type ].
  unfolds open_ee. pick_fresh x.
   apply* (@open_te_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_ee. pick_fresh x.
   apply* (@open_te_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_te. pick_fresh X.
   apply* (@open_te_rec_type_core e1 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_te_fresh : forall X U e,
  X \notin fv_te e -> subst_te X U e = e.
Proof.
  induction e; simpl; intros; f_equal*; autos* subst_tt_fresh.
Qed.

(** Substitution distributes on the open operation. *)

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.
  intros. unfold open_te. generalize 0.
  induction e; intros; simpls; f_equal*;
  autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_te_open_te_var : forall X Y U e, Y <> X -> type U ->
  (subst_te X U e) open_te_var Y = subst_te X U (e open_te_var Y).
Proof.
  introv Neq Wu. rewrite* subst_te_open_te.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_te_intro : forall X U e,
  X \notin fv_te e -> type U ->
  open_te e U = subst_te X U (e open_te_var X).
Proof.
  introv Fr Wu. rewrite* subst_te_open_te.
  rewrite* subst_te_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Properties of term substitution in terms *)

Lemma open_ee_rec_term_core : forall e j v u i, i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_ee_rec_type_core : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv H; simpls; inversion H; f_equal*.
Qed.

Lemma open_ee_rec_term : forall u e,
  term e -> forall k, e = open_ee_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds open_ee. pick_fresh x.
   apply* (@open_ee_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_ee. pick_fresh x.
   apply* (@open_ee_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_te. pick_fresh X.
   apply* (@open_ee_rec_type_core e1 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_ee_fresh : forall x u e,
  x \notin fv_ee e -> subst_ee x u e = e.
Proof.
  induction e; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_ee_open_ee : forall t1 t2 u x, term u ->
  subst_ee x u (open_ee t1 t2) =
  open_ee (subst_ee x u t1) (subst_ee x u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1; intros; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_ee_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_ee_open_ee_var : forall x y u e, y <> x -> term u ->
  (subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_ee_intro : forall x u e,
  x \notin fv_ee e -> term u ->
  open_ee e u = subst_ee x u (e open_ee_var x).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_var*.
Qed.

(** Interactions between type substitutions in terms and opening
  with term variables in terms. *)

Lemma subst_te_open_ee_var : forall Z P x e,
  (subst_te Z P e) open_ee_var x = subst_te Z P (e open_ee_var x).
Proof.
  introv. unfold open_ee. generalize 0.
  induction e; intros; simpl; f_equal*. case_nat*.
Qed.

(** Interactions between term substitutions in terms and opening
  with type variables in terms. *)

Lemma subst_ee_open_te_var : forall z u e X, term u ->
  (subst_ee z u e) open_te_var X = subst_ee z u (e open_te_var X).
Proof.
  introv. unfold open_te. generalize 0.
  induction e; intros; simpl; f_equal*.
  case_var*. symmetry. autos* open_te_rec_term.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_tt_type : forall T Z P,
  type T -> type P -> type (subst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* type_all as X. rewrite* subst_tt_open_tt_var.
Qed.

Lemma subst_te_term : forall e Z P,
  term e -> type P -> term (subst_te Z P e).
Proof.
  lets: subst_tt_type. induction 1; intros; simpl; auto.
  apply_fresh* term_abs as x. rewrite* subst_te_open_ee_var.
  apply_fresh* term_cap as x. rewrite* subst_te_open_ee_var.
  apply_fresh* term_tabs as x. rewrite* subst_te_open_te_var.
Qed.

Lemma subst_ee_term : forall e1 Z e2,
  term e1 -> term e2 -> term (subst_ee Z e2 e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
  apply_fresh* term_cap as y. rewrite* subst_ee_open_ee_var.
  apply_fresh* term_tabs as Y. rewrite* subst_ee_open_te_var.
Qed.

Hint Resolve subst_tt_type subst_te_term subst_ee_term.

(* ********************************************************************** *)
(** * Properties of well-formedness of a type in an environment *)

(** If a type is well-formed in an environment then it is locally closed. *)

Lemma wft_type : forall E T,
  wft E T -> type T.
Proof.
  induction 1; eauto.
Qed.

(** Through weakening *)

Lemma wft_weaken : forall G T E F,
  wft (E & G) T ->
  ok (E & F & G) ->
  wft (E & F & G) T.
Proof.
  intros. gen_eq K: (E & G). gen E F G.
  induction H; intros; subst; eauto.
  (* case: var *)
  apply (@wft_var U). apply* binds_weaken.
  (* case: all *)
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

(** Through narrowing *)

Lemma wft_narrow : forall V F U T E X,
  wft (E & X ~<: V & F) T ->
  ok (E & X ~<: U & F) ->
  wft (E & X ~<: U & F) T.
Proof.
  intros. gen_eq K: (E & X ~<: V & F). gen E F.
  induction H; intros; subst; eauto.
  destruct (binds_middle_inv H) as [K|[K|K]]; try destructs K.
    applys wft_var. apply* binds_concat_right.
    subst. applys wft_var. apply~ binds_middle_eq.
    applys wft_var. apply~ binds_concat_left.
     apply* binds_concat_left.
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

(** Through strengthening *)

Lemma wft_strengthen : forall E F x U T,
 wft (E & x ~: U & F) T -> wft (E & F) T.
Proof.
  intros. gen_eq G: (E & x ~: U & F). gen F.
  induction H; intros F EQ; subst; auto.
  apply* (@wft_var U0).
  destruct (binds_concat_inv H) as [?|[? ?]].
    apply~ binds_concat_right.
    destruct (binds_push_inv H1) as [[? ?]|[? ?]].
      subst. false.
      apply~ binds_concat_left.
  (* todo: binds_cases tactic *)
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

(** Through type substitution *)

Lemma wft_subst_tb : forall F Q E Z P T,
  wft (E & Z ~<: Q & F) T ->
  wft E P ->
  ok (E & map (subst_tb Z P) F) ->
  wft (E & map (subst_tb Z P) F) (subst_tt Z P T).
Proof.
  introv WT WP. gen_eq G: (E & Z ~<: Q & F). gen F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt; auto.
  case_var*.
    apply_empty* wft_weaken.
    destruct (binds_concat_inv H) as [?|[? ?]].
      apply (@wft_var (subst_tt Z P U)).
       apply~ binds_concat_right.
       unsimpl_map_bind. apply~ binds_map.
      destruct (binds_push_inv H1) as [[? ?]|[? ?]].
        subst. false~.
        applys wft_var. apply* binds_concat_left.
  apply_fresh* wft_all as Y.
   unsimpl ((subst_tb Z P) (bind_sub T1)).
   lets: wft_type.
   rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(** Through type reduction *)

Lemma wft_open : forall E U T1 T2,
  ok E ->
  wft E (typ_all T1 T2) ->
  wft E U ->
  wft E (open_tt T2 U).
Proof.
  introv Ok WA WU. inversions WA. pick_fresh X.
  autos* wft_type. rewrite* (@subst_tt_intro X).
  lets K: (@wft_subst_tb empty).
  specializes_vars K. clean_empty K. apply* K.
  (* todo: apply empty ? *)
Qed.

(* ********************************************************************** *)
(** * Relations between well-formed environment and types well-formed
  in environments *)

(** If an environment is well-formed, then it does not contain duplicated keys. *)

Lemma ok_from_okt : forall E,
  okt E -> ok E.
Proof.
  induction 1; auto.
Qed.

Hint Extern 1 (ok _) => apply ok_from_okt.

(** Extraction from a subtyping assumption in a well-formed environments *)

Lemma wft_from_env_has_sub : forall x U E,
  okt E -> binds x (bind_sub U) E -> wft E U.
Proof.
  induction E using env_ind; intros Ok B.
  false* binds_empty_inv.
  inversions Ok.
    false (empty_push_inv H0).
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H3. apply_empty* wft_weaken.
       apply_empty* wft_weaken.
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H3.
       apply_empty* wft_weaken.
Qed.

(** Extraction from a typing assumption in a well-formed environments *)

Lemma wft_from_env_has_typ : forall x U E,
  okt E -> binds x (bind_typ U) E -> wft E U.
Proof.
  induction E using env_ind; intros Ok B.
  false* binds_empty_inv.
  inversions Ok.
    false (empty_push_inv H0).
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H3.
       apply_empty* wft_weaken.
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H3. apply_empty* wft_weaken.
       apply_empty* wft_weaken.
Qed.

(** Extraction from a well-formed environment *)

Lemma wft_from_okt_typ : forall x T E,
  okt (E & x ~: T) -> wft E T.
Proof.
  intros. inversions* H.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [? ?]]. false.
  destruct (eq_push_inv H0) as [? [? ?]]. inversions~ H4.
Qed.

Lemma wft_from_okt_sub : forall x T E,
  okt (E & x ~<: T) -> wft E T.
Proof.
  intros. inversions* H.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [? ?]]. inversions~ H4.
  destruct (eq_push_inv H0) as [? [? ?]]. false.
Qed.

(** Automation *)

Lemma wft_weaken_right : forall T E F,
  wft E T ->
  ok (E & F) ->
  wft (E & F) T.
Proof.
  intros. apply_empty* wft_weaken.
Qed.

Hint Resolve wft_weaken_right.
Hint Resolve wft_from_okt_typ wft_from_okt_sub.
Hint Immediate wft_from_env_has_sub wft_from_env_has_typ.
Hint Resolve wft_subst_tb.

(* ********************************************************************** *)
(** ** Properties of well-formedness of an environment *)

(** Inversion lemma *)

Lemma okt_push_inv : forall E X B,
  okt (E & X ~ B) -> exists T, B = bind_sub T \/ B = bind_typ T.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&?&?): (eq_push_inv H). subst*.
    lets (?&?&?): (eq_push_inv H). subst*.
Qed.

Lemma okt_push_sub_inv : forall E X T,
  okt (E & X ~<: T) -> okt E /\ wft E T /\ X # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&M&?): (eq_push_inv H). subst. inverts~ M.
    lets (?&?&?): (eq_push_inv H). false.
Qed.

Lemma okt_push_sub_type : forall E X T,
  okt (E & X ~<: T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_sub_inv. Qed.

Lemma okt_push_typ_inv : forall E x T,
  okt (E & x ~: T) -> okt E /\ wft E T /\ x # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&?&?): (eq_push_inv H). false.
    lets (?&M&?): (eq_push_inv H). subst. inverts~ M.
Qed.

Lemma okt_push_typ_type : forall E X T,
  okt (E & X ~: T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_typ_inv. Qed.

Hint Immediate okt_push_sub_type okt_push_typ_type.

(** Through narrowing *)

Lemma okt_narrow : forall V (E F:env) U X,
  okt (E & X ~<: V & F) ->
  wft E U ->
  okt (E & X ~<: U & F).
Proof.
  introv O W. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_sub_inv O).
  rewrite concat_assoc in *.
   lets (T&[?|?]): okt_push_inv O; subst.
     lets (?&?&?): (okt_push_sub_inv O).
      applys~ okt_sub. applys* wft_narrow.
     lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. applys* wft_narrow.
Qed.

(** Through strengthening *)

Lemma okt_strengthen : forall x T (E F:env),
  okt (E & x ~: T & F) ->
  okt (E & F).
Proof.
 introv O. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_typ_inv O).
  rewrite concat_assoc in *.
   lets (U&[?|?]): okt_push_inv O; subst.
     lets (?&?&?): (okt_push_sub_inv O).
      applys~ okt_sub. applys* wft_strengthen.
     lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. applys* wft_strengthen.
Qed.

(** Through type substitution *)

Lemma okt_subst_tb : forall Q Z P (E F:env),
  okt (E & Z ~<: Q & F) ->
  wft E P ->
  okt (E & map (subst_tb Z P) F).
Proof.
 introv O W. induction F using env_ind.
  rewrite map_empty. rewrite concat_empty_r in *.
   lets*: (okt_push_sub_inv O).
  rewrite map_push. rewrite concat_assoc in *.
   lets (U&[?|?]): okt_push_inv O; subst.
     lets (?&?&?): (okt_push_sub_inv O).
      applys~ okt_sub. applys* wft_subst_tb.
     lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. applys* wft_subst_tb.
Qed.

(** Automation *)

Hint Resolve okt_narrow okt_subst_tb wft_weaken.
Hint Immediate okt_strengthen.

(* ********************************************************************** *)
(** ** Environment is unchanged by substitution from a fresh name *)

Lemma notin_fv_tt_open : forall Y X T,
  X \notin fv_tt (T open_tt_var Y) ->
  X \notin fv_tt T.
Proof.
 introv. unfold open_tt. generalize 0.
 induction T; simpl; intros k Fr; auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 specializes IHT1 k. specializes IHT2 (S k). auto.
Qed.

Lemma notin_fv_wf : forall E X T,
  wft E T -> X # E -> X \notin fv_tt T.
Proof.
  induction 1; intros Fr; simpl.
  eauto.
  rewrite notin_singleton. intro. subst. applys binds_fresh_inv H Fr.
  notin_simpl; auto.
  notin_simpl; auto. pick_fresh Y. apply* (@notin_fv_tt_open Y).
Qed.

Lemma map_subst_tb_id : forall G Z P,
  okt G -> Z # G -> G = map (subst_tb Z P) G.
Proof.
  induction 1; intros Fr; autorewrite with rew_env_map; simpl.
  auto.
  rewrite* <- IHokt. rewrite* subst_tt_fresh. apply* notin_fv_wf.
  rewrite* <- IHokt. rewrite* subst_tt_fresh. apply* notin_fv_wf.
Qed.

(* ********************************************************************** *)
(** ** Properties of set *)

Lemma subset_trans: forall (T: Type) (a b c: fset T),
  a \c b -> b \c c -> a \c c.
Proof. unfolds subset. autos. Qed.

Lemma subset_strengthen: forall (T: Type) (a b: fset T) (x: T),
  a \c (b \u \{x}) -> x \notin a -> a \c b.
Proof. unfolds subset. intros. forwards K: (H x0 H1).
  rewrite in_union in K. destruct* K.
  rewrite in_singleton in H2. subst.
  tryfalse.
Qed.

(* ********************************************************************** *)
(** * Properties of environment *)
Lemma typ_env_dist: forall E F, typ_env (E & F) = typ_env E & typ_env F.
Proof. rewrite concat_def. intros. gen E. induction F; intros E; autos.
  rewrite LibList.app_cons. destruct a. destruct* b.
  simpl. rewrite LibList.app_cons. rewrite* <- IHF.
Qed.

Lemma typ_env_dom_subset : forall E, dom (typ_env E) \c dom E.
Proof. intros. induction E.
  simpls. apply subset_refl.
  destruct a. destruct b.
  simpls. repeat(rewrite cons_to_push). repeat(rewrite dom_push).
    eapply subset_union_2. eapply subset_refl. eauto.
  simpls. rewrite cons_to_push. rewrite dom_push.
    eapply subset_trans. eauto. apply subset_union_weak_r.
Qed.

Lemma typ_env_binds: forall E U x, ok E ->
  binds x (bind_sub U) (typ_env E) ->
  binds x (bind_sub U) E.
Proof. intros. induction E.
  simpls. autos.
  destruct a. destruct b.
    simpls. rewrite cons_to_push in *. destruct (binds_push_inv H0).
      destructs H1. inversions H2. apply binds_push_eq.
      destructs H1. apply* binds_push_neq.
    simpls. rewrite cons_to_push in *. apply binds_push_neq.
      autos* ok_concat_inv_l.
      intros Ha. subst. lets: IHE (ok_concat_inv_l H) H0.
      rewrite <- concat_empty_r in H. lets: ok_middle_inv_l H.
      apply (binds_fresh_inv H1 H2).
Qed.

Lemma typ_env_binds_reverse: forall E U x,
  binds x (bind_sub U) E -> binds x (bind_sub U) (typ_env E).
Proof. intros. induction E.
  simpl in *. autos.
  destruct a. destruct b.
    simpls. rewrite cons_to_push in *. destruct (binds_push_inv H).
      destructs H0. inversions H1. apply binds_push_eq.
      destructs H0. apply* binds_push_neq.
    simpls. rewrite cons_to_push in *. apply IHE.
      eapply binds_push_neq_inv. exact H.
      intros HI. subst. lets: binds_push_eq_inv H. inversion H0.
Qed.

Lemma typ_env_no_var : forall x T E, ~binds x (bind_typ T) (typ_env E).
Proof. intros. intros H. induction E.
  simpl in H. rewrite <- empty_def in H. destruct (binds_empty_inv H).
  destruct a. destruct b; autos.
    simpl in H. apply IHE. rewrite cons_to_push in H. destruct (binds_push_inv H).
      destruct H0. subst. inversion H1.
      destruct* H0.
Qed.

Lemma typ_env_wft: forall E V, ok E -> wft (typ_env E) V -> wft E V.
Proof. intros. remember (typ_env E) as G. gen E. inductions H0; intros; subst; autos.
  eapply wft_var. apply* typ_env_binds.
  apply_fresh* wft_all as Y. apply* H1. repeat(rewrite <- cons_to_push). autos.
Qed.

Lemma typ_env_wft_weaken: forall E F G V,
  ok (E & F & G) -> wft (E & (typ_env F) & G) V -> wft (E & F & G) V.
Proof. intros. inductions H0; intros; subst; autos.
  eapply wft_var. binds_cases H0.
    apply binds_concat_left; autos. apply* binds_concat_left_ok.
    apply binds_concat_left; autos. apply* binds_concat_right. apply* typ_env_binds.
      lets*: ok_concat_inv_r (ok_concat_inv_l H).
    apply binds_concat_right. auto.
  apply_fresh* wft_all as Y.
    assert (HI: ok (E & F & (G & Y ~<: T1 ))).
      rewrite concat_assoc. apply* ok_push.
    forwards~ HII: (H1 Y). apply HI.  rewrite* concat_assoc.
    rewrite* <- concat_assoc.
Qed.

Lemma typ_env_wft_reverse: forall E V, wft E V -> wft (typ_env E) V.
Proof. intros. inductions H; autos.
  eapply wft_var. apply* typ_env_binds_reverse.
  apply_fresh* wft_all as Y. forwards~ HI: (H1 Y).
    rewrite typ_env_dist in HI. rewrite single_def in *. autos.
Qed.

Lemma typ_env_okt : forall E,
  okt E -> okt (typ_env E).
Proof. intros. induction* E.
  destruct a. destruct b; simpl; rewrite cons_to_push in *.
  apply okt_sub. apply IHE. lets*: okt_push_sub_inv H.
    lets(_ & HI & HII): okt_push_sub_inv H.
    autos* typ_env_wft_reverse.
    lets(_ & _ & HI): okt_push_sub_inv H.
    lets: typ_env_dom_subset E. unfolds subset.
    intros Ha. apply HI. autos.

  apply IHE. lets*: okt_push_typ_inv H.
Qed.

Lemma typ_env_map : forall E Z P, typ_env (map (subst_tb Z P) E) = map (subst_tb Z P) (typ_env E).
Proof. intros. induction E.
  simpl. rewrite <- empty_def. rewrite map_empty. rewrite empty_def. reflexivity.
  destruct a. destruct b; simpl.
    repeat(rewrite cons_to_push). repeat(rewrite map_push). simpl.
      rewrite <- cons_to_push. simpl. rewrite cons_to_push. rewrite* IHE.
    repeat(rewrite cons_to_push). repeat(rewrite map_push). simpl.
      rewrite <- cons_to_push. simpl. rewrite* IHE.
Qed.

Lemma typ_env_eq : forall E, typ_env (typ_env E) = typ_env E.
Proof. intros. induction E; autos.
  destruct a. destruct b; autos.
  simpl. rewrite* IHE.
Qed.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** The subtyping relation is restricted to well-formed objects. *)

Lemma sub_regular : forall E S T,
  sub E S T -> okt E /\ wft E S /\ wft E T.
Proof.
  induction 1. autos*. autos*. autos*. jauto_set; auto. (* autos* too slow *)
  split. autos*. split;
   apply_fresh* wft_all as Y;
    forwards~: (H1 Y); apply_empty* (@wft_narrow T1).
Qed.

(** The typing relation is restricted to well-formed objects. *)

Lemma typing_regular : forall E e T,
  typing E e T -> okt E /\ term e /\ wft E T.
Proof.
  induction 1.
  splits*.
  splits.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_typ_inv.
   apply_fresh* term_abs as y.
     pick_fresh y. specializes H0 y. destructs~ H0.
      forwards*: okt_push_typ_inv.
     specializes H0 y. destructs~ H0.
   pick_fresh y. specializes H0 y. destructs~ H0.
    apply* wft_arrow.
      forwards*: okt_push_typ_inv.
      apply_empty* wft_strengthen.
  splits*.
   apply_fresh* term_cap as y.
     pick_fresh y. specializes H1 y. destructs~ H1.
       forwards*: (okt_push_typ_inv H1).
     specializes H1 y. destructs~ H1.
   pick_fresh y. specializes H1 y. destructs~ H1.
     apply* wft_arrow.
       apply* typ_env_wft.
       apply* typ_env_wft.
       rewrite <- (@concat_empty_r bind (typ_env E)).
       eapply wft_strengthen. rewrite* concat_empty_r.
  splits*. destructs IHtyping1. inversion* H3.
  splits.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_sub_inv.
   apply_fresh* term_tabs as y.
     pick_fresh y. forwards~ K: (H0 y). destructs K.
       forwards*: okt_push_sub_inv.
     forwards~ K: (H0 y). destructs K. auto.
   apply_fresh* wft_all as Y.
     pick_fresh y. forwards~ K: (H0 y). destructs K.
      forwards*: okt_push_sub_inv.
     forwards~ K: (H0 Y). destructs K.
      forwards*: okt_push_sub_inv.
  splits*; destructs (sub_regular H0).
   apply* term_tapp. applys* wft_type.
   applys* wft_open T1.
  splits*. destructs~ (sub_regular H0).
Qed.

(** The value relation is restricted to well-formed objects. *)

Lemma value_regular : forall t,
  value t -> term t.
Proof.
  induction 1; autos*.
Qed.

(** The reduction relation is restricted to well-formed objects. *)

Lemma red_regular : forall t t',
  red t t' -> term t /\ term t'.
Proof.
  induction 1; split; autos* value_regular.
  inversions H. pick_fresh y. rewrite* (@subst_ee_intro y).
  inversions H. pick_fresh y. rewrite* (@subst_ee_intro y).
  inversions H. pick_fresh Y. rewrite* (@subst_te_intro Y).
Qed.

(** Automation *)

Hint Extern 1 (okt ?E) =>
  match goal with
  | H: sub _ _ _ |- _ => apply (proj31 (sub_regular H))
  | H: typing _ _ _ |- _ => apply (proj31 (typing_regular H))
  end.

Hint Extern 1 (wft ?E ?T) =>
  match goal with
  | H: typing E _ T |- _ => apply (proj33 (typing_regular H))
  | H: sub E T _ |- _ => apply (proj32 (sub_regular H))
  | H: sub E _ T |- _ => apply (proj33 (sub_regular H))
  end.

Hint Extern 1 (type ?T) =>
  let go E := apply (@wft_type E); auto in
  match goal with
  | H: typing ?E _ T |- _ => go E
  | H: sub ?E T _ |- _ => go E
  | H: sub ?E _ T |- _ => go E
  end.

Hint Extern 1 (term ?e) =>
  match goal with
  | H: typing _ ?e _ |- _ => apply (proj32 (typing_regular H))
  | H: red ?e _ |- _ => apply (proj1 (red_regular H))
  | H: red _ ?e |- _ => apply (proj2 (red_regular H))
  end.

(** In parentheses are given the label of the corresponding
  lemma in the description of the POPLMark Challenge. *)

(* ********************************************************************** *)
(** * Properties of Subtyping *)

(* ********************************************************************** *)
(** Reflexivity (1) *)

Lemma sub_reflexivity : forall E T,
  okt E ->
  wft E T ->
  sub E T T .
Proof.
  introv Ok WI. lets W: (wft_type WI). gen E.
  induction W; intros; inversions WI; eauto.
  apply_fresh* sub_all as Y.
Qed.

(* ********************************************************************** *)
(** Weakening (2) *)

Lemma sub_weakening : forall E F G S T,
   sub (E & G) S T ->
   okt (E & F & G) ->
   sub (E & F & G) S T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok; auto.
  (* case: fvar trans *)
  apply* sub_trans_tvar. apply* binds_weaken.
  (* case: all *)
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
Qed.

Lemma sub_weakening_env : forall E F G S T,
   sub (E & typ_env F & G) S T ->
   okt (E & F & G) ->
   sub (E & F & G) S T.
Proof. intros. inductions H; eauto.
  apply* sub_top. apply* typ_env_wft_weaken.
  apply* sub_refl_tvar. apply* typ_env_wft_weaken.
  apply* sub_trans_tvar.  binds_cases H.
    apply binds_concat_left; autos. apply* binds_concat_left_ok. eapply ok_concat_inv_l.
      eapply ok_from_okt. eauto.
    apply binds_concat_left; autos. apply* binds_concat_right. apply* typ_env_binds.
      lets*: ok_concat_inv_r (ok_concat_inv_l (ok_from_okt H1)).
    apply binds_concat_right. auto.
  apply_fresh* sub_all as X. lets: (H1 X).
    rewrite <- concat_assoc in H3. rewrite <- concat_assoc.
    apply* H3. rewrite concat_assoc. apply* okt_sub.
    destructs (sub_regular H). apply* typ_env_wft_weaken.
Qed.

(* ********************************************************************** *)
(** Narrowing and transitivity (3) *)

Section NarrowTrans.

Definition transitivity_on Q := forall E S T,
  sub E S Q -> sub E Q T -> sub E S T.

Hint Unfold transitivity_on.

Hint Resolve wft_narrow.

Lemma sub_narrowing_aux : forall Q F E Z P S T,
  transitivity_on Q ->
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & Z ~<: P & F) S T.
Proof.
  introv TransQ SsubT PsubQ.
  inductions SsubT; introv.
  apply* sub_top.
  apply* sub_refl_tvar.
  tests EQ: (X = Z).
    lets M: (@okt_narrow Q).
    apply (@sub_trans_tvar P).
      asserts~ N: (ok (E & Z ~<: P & F)).
       lets: ok_middle_inv_r N.
       apply~ binds_middle_eq.
      apply TransQ.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. autos*.
    apply* (@sub_trans_tvar U). binds_cases H; auto.
  apply* sub_arrow.
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
Qed.

Lemma sub_transitivity : forall Q,
  transitivity_on Q.
Proof.
  intro Q. introv SsubQ QsubT. asserts* W: (type Q).
  gen E S T. set_eq Q' EQ: Q. gen Q' EQ.
  induction W; intros Q' EQ E S SsubQ;
    induction SsubQ; try discriminate; inversions EQ;
      intros T QsubT; inversions keep QsubT;
        eauto 4 using sub_trans_tvar.
  (* case: all / top -> only needed to fix well-formedness,
     by building back what has been deconstructed too much *)
  assert (sub E (typ_all S1 S2) (typ_all T1 T2)).
    apply_fresh* sub_all as y.
  autos*.
  (* case: all / all *)
  apply_fresh sub_all as Y. autos*.
  applys~ (H0 Y). lets: (IHW T1).
  apply_empty* (@sub_narrowing_aux T1).
Qed.

Lemma sub_narrowing : forall Q E F Z P S T,
  sub E P Q ->
  sub (E & Z ~<: Q & F) S T ->
  sub (E & Z ~<: P & F) S T.
Proof.
  intros.
  apply* sub_narrowing_aux.
  apply* sub_transitivity.
Qed.

End NarrowTrans.

(* ********************************************************************** *)
(** Type substitution preserves subtyping (10) *)

Lemma sub_through_subst_tt : forall Q E F Z S T P,
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & map (subst_tb Z P) F) (subst_tt Z P S) (subst_tt Z P T).
Proof.
  introv SsubT PsubQ.
  inductions SsubT; introv; simpl subst_tt.
  apply* sub_top.
  case_var.
    apply* sub_reflexivity.
    apply* sub_reflexivity.
     inversions H0. binds_cases H3.
      apply* (@wft_var U).
      apply* (@wft_var (subst_tt Z P U)). unsimpl_map_bind*.
   case_var.
    apply (@sub_transitivity Q).
      apply_empty* sub_weakening.
      rewrite* <- (@subst_tt_fresh Z P Q).
        binds_get H. autos*.
        apply* (@notin_fv_wf E).
    apply* (@sub_trans_tvar (subst_tt Z P U)).
      rewrite* (@map_subst_tb_id E Z P).
        binds_cases H; unsimpl_map_bind*.
  apply* sub_arrow.
  apply_fresh* sub_all as X.
   unsimpl (subst_tb Z P (bind_sub T1)).
   do 2 rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(* ********************************************************************** *)
(** * Properties of Typing *)

(* ********************************************************************** *)
(** Weakening (5) *)

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as x. forwards~ K: (H x).
   apply_ih_bind (H0 x); eauto.
  apply_fresh* typing_cap as x. repeat(rewrite typ_env_dist in *).
   assert (HI: okt(typ_env E & typ_env F & typ_env G)).
      apply typ_env_okt in Ok. repeat(rewrite typ_env_dist in Ok). autos.
   lets: H1 x. rewrite <- concat_assoc in H2. rewrite <- concat_assoc.
   apply* H2. rewrite concat_assoc. apply okt_typ. auto.
     apply* wft_weaken. forwards~: (H0 x). destructs (typing_regular H3).
       rewrite <- (@concat_empty_r bind (typ_env E & typ_env G)).
       eapply wft_strengthen. rewrite concat_empty_r. eauto.
     unfolds. intros HII. repeat(rewrite dom_concat in HII).
       assert (Ha: x \notin dom E \u dom F \u dom G) by autos. apply Ha.
       repeat(rewrite in_union in *). rewrite or_assoc in HII. branches HII.
       branch 1. lets*: typ_env_dom_subset E.
       branch 2. lets*: typ_env_dom_subset F.
       branch 3. lets*: typ_env_dom_subset G.
  apply* typing_app.
  apply_fresh* typing_tabs as X. forwards~ K: (H X).
   apply_ih_bind (H0 X); eauto.
  apply* typing_tapp. apply* sub_weakening.
  apply* typing_sub. apply* sub_weakening.
Qed.

Lemma typing_weakening_env : forall E F G e T,
  typing (E & (typ_env F) & G) e T ->
  okt (E & F & G) ->
  typing (E & F & G) e T.
Proof. intros. inductions H.
  apply* typing_var. destruct (binds_concat_inv H0).
    apply* binds_concat_right.
    destruct H2. apply* binds_concat_left. destruct (binds_concat_inv H3).
      destruct (typ_env_no_var _ H4). destruct H4.
      apply* binds_concat_left_ok. lets*: ok_concat_inv_l (ok_from_okt H1).
  apply_fresh* typing_abs as x. forwards~ K: (H x).
    apply_ih_bind (H0 x); eauto.
    destruct (typing_regular K). apply okt_typ; autos.
    lets(_ & HI & _): okt_push_typ_inv H2.
    apply* typ_env_wft_weaken.
  apply_fresh* typing_cap as x. repeat(rewrite typ_env_dist in *).
    rewrite typ_env_eq in H0. apply* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as X. forwards~ K: (H X).
    apply_ih_bind (H0 X); eauto. apply* okt_sub.
    eapply typ_env_wft_weaken; autos. destructs (typing_regular K).
    eapply wft_from_okt_sub; eauto.
  apply* typing_tapp. apply* sub_weakening_env.
  eapply typing_sub. apply* IHtyping. apply* sub_weakening_env.
Qed.

(* ********************************************************************** *)
(** Strengthening (6) *)

Lemma sub_strengthening : forall x U E F S T,
  sub (E & x ~: U & F) S T ->
  sub (E & F) S T.
Proof.
  intros x U E F S T SsubT.
  inductions SsubT; introv; autos* wft_strengthen.
  (* case: fvar trans *)
  apply* (@sub_trans_tvar U0). binds_cases H; autos*.
  (* case: all *)
  apply_fresh* sub_all as X. apply_ih_bind* H0.
Qed.

Lemma sub_strengthening_env : forall E S T,
  sub E S T -> sub (typ_env E) S T.
Proof.  intros. inductions H; autos.
  apply sub_top. apply* typ_env_okt. apply* typ_env_wft_reverse.
  apply sub_refl_tvar. apply* typ_env_okt. apply* typ_env_wft_reverse.
  eapply sub_trans_tvar. eapply typ_env_binds_reverse. eauto. auto.
  apply sub_all with L. auto. intros. forwards~ : H1 X.
  rewrite typ_env_dist in H3.
  replace (typ_env (X ~<: T1)) with (X ~<: T1) in H3 by (rewrite* single_def).
  auto.
Qed.

(************************************************************************ *)
(** Preservation by Type Narrowing (7) *)

Lemma typing_narrowing : forall Q E F X P e T,
  sub E P Q ->
  typing (E & X ~<: Q & F) e T ->
  typing (E & X ~<: P & F) e T.
Proof.
  introv PsubQ Typ. gen_eq E': (E & X ~<: Q & F). gen E F.
  inductions Typ; introv PsubQ EQ; subst; simpl.
  binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply_fresh* typing_cap as y. repeat(rewrite typ_env_dist in *).
    rewrite <- concat_assoc. lets: H1 y. rewrite <- concat_assoc in H2.
    replace (typ_env (X ~<: P)) with (X ~<: P) by (rewrite* single_def).
    apply* H2. apply* sub_strengthening_env.
    replace (typ_env (X ~<: Q)) with (X ~<: Q) by (rewrite* single_def). auto.
  apply* typing_app.
  apply_fresh* typing_tabs as Y. apply_ih_bind* H0.
  apply* typing_tapp. apply* (@sub_narrowing Q).
  apply* typing_sub. apply* (@sub_narrowing Q).
Qed.

(************************************************************************ *)
(** Preservation by Term Substitution (8) *)

Lemma open_tt_fv_subset: forall k U T,
  fv_tt T \c fv_tt (open_tt_rec k U T).
Proof. intros. gen k. induction T; intros; simpls.
  apply subset_empty_l.
  apply subset_empty_l.
  apply subset_refl.
  apply* subset_union_2.
  apply* subset_union_2.
Qed.

Lemma open_te_fv_subset: forall k U e,
  fv_te e \c fv_te (open_te_rec k U e).
Proof. intros. gen k. induction e; intros; simpls.
  apply subset_empty_l.
  apply subset_empty_l.
  apply* subset_union_2. apply open_tt_fv_subset.
  apply* subset_union_2. apply open_tt_fv_subset.
  apply* subset_union_2.
  autos.
  apply* subset_union_2. apply open_tt_fv_subset.
  apply* subset_union_2. apply open_tt_fv_subset.
Qed.

Lemma open_ee_fv_subset: forall k u e,
  fv_ee e \c fv_ee (open_ee_rec k u e).
Proof. intros. gen k. induction e; intros; simpls.
  apply subset_empty_l.
  apply subset_refl.
  autos.
  autos.
  apply* subset_union_2.
  autos.
  autos.
Qed.

Lemma open_ee_te_fv_eq: forall k U e,
  fv_ee e = fv_ee (open_te_rec k U e).
Proof. intros. gen k. induction e; intros; simpls; autos.
  rewrites (IHe1 k).
  rewrites (IHe2 k).
  reflexivity.
Qed.

Lemma open_te_ee_fv_subset: forall k u e,
  fv_te e \c fv_te (open_ee_rec k u e).
Proof. intros. gen k. induction e; intros; simpls; autos.
  apply subset_empty_l.
  apply subset_empty_l.
  apply* subset_union_2. apply subset_refl.
  apply* subset_union_2. apply subset_refl.
  apply* subset_union_2.
  apply* subset_union_2. apply subset_refl.
  apply* subset_union_2. apply subset_refl.
Qed.

Lemma open_tt_tt_fv_subset: forall k T1 T2,
  fv_tt (open_tt_rec k T1 T2) \c fv_tt T1 \u fv_tt T2.
Proof. intros. gen k. induction T2; intros; simpls; autos.
  apply subset_empty_l.
  destruct (prop_degeneracy (k = n)).
    (* k = n*)
    apply is_True_inv in H. rewrite* If_l. apply subset_union_weak_l.
    (* k != n*)
    apply is_False_inv in H. rewrite* If_r. simpl. apply subset_empty_l.

  apply subset_union_weak_r.

  lets*: (subset_union_2 (IHT2_1 k) (IHT2_2 k)).
  rewrite union_assoc in H.
  rewrite union_comm in H.
  replace ((fv_tt T1 \u fv_tt T2_1) \u fv_tt T1) with (fv_tt T1 \u fv_tt T2_1) in H.
  rewrite union_assoc. rewrite union_comm. autos.

  rewrite union_comm. rewrite <- union_assoc.
  rewrite union_same. reflexivity.

  lets*: (subset_union_2 (IHT2_1 k) (IHT2_2 (S k))).
  rewrite union_assoc in H.
  rewrite union_comm in H.
  replace ((fv_tt T1 \u fv_tt T2_1) \u fv_tt T1) with (fv_tt T1 \u fv_tt T2_1) in H.
  rewrite union_assoc. rewrite union_comm. autos.

  rewrite union_comm. rewrite <- union_assoc.
  rewrite union_same. reflexivity.
Qed.

Lemma wft_fv_tt: forall E T,
  wft E T -> fv_tt T \c dom E.
Proof.
  intros. inductions H; simpls.
  apply subset_empty_l.
  lets: get_some_inv (binds_get H). unfolds subset. intros.
    rewrite in_singleton in H1. rewrite* H1.
  rewrite <- union_same. apply* subset_union_2.
  rewrite <- union_same. apply* subset_union_2.
    pick_fresh X. forwards~ HI: (H1 X). simpls. rewrite dom_concat in HI.
    rewrite dom_single in HI. eapply subset_strengthen. eapply subset_trans.
    apply open_tt_fv_subset. exact HI. autos.
Qed.

Lemma subtyping_env_fv : forall E S T, sub E S T ->
  fv_tt S \c dom E /\ fv_tt T \c dom E.
Proof. intros. inductions H; simpls.
  splits. apply* wft_fv_tt. apply subset_empty_l.
  lets*: wft_fv_tt H0.
  destructs IHsub. splits*. lets: get_some_inv (binds_get H).
    unfolds. intros. rewrite in_singleton in H4. subst*.
  destructs IHsub1. destructs IHsub2.
    splits; rewrite <- union_same; apply* subset_union_2.
  destruct IHsub. pick_fresh X. forwards~ HI: H1 X.
    rewrite dom_concat in HI. rewrite dom_single in HI. destruct HI.
    splits.
    rewrite <- union_same. apply* subset_union_2. apply subset_strengthen with X; autos.
      eapply subset_trans. apply open_tt_fv_subset. eauto.
    rewrite <- union_same. apply* subset_union_2. apply subset_strengthen with X; autos.
      eapply subset_trans. apply open_tt_fv_subset. eauto.
Qed.

Lemma typing_env_fv : forall E e T, typing E e T ->
  fv_ee e \c dom E /\ fv_te e \c dom E /\ fv_tt T \c dom E.
Proof. intros. inductions H; substs.
  (* var *)
  forwards~ HI:  get_some_inv (binds_get H0).
  simpls. splits.
  unfolds subset. intros. rewrite in_singleton in *. subst*.
  apply subset_empty_l.
  apply* wft_fv_tt.

  (* abs *)
  pick_fresh x. forwards~ (HI & HII & HIII): H0 x. simpls.
  rewrite dom_concat in *. rewrite dom_single in *.
  unfolds open_ee. unfolds open_te.

  assert (Ha: fv_tt V \c dom E).
    forwards~ Htyp: (H x).
    destruct (typing_regular Htyp) as [He _].
    apply subset_strengthen with x; autos.
    rewrite <- dom_single with (v:= bind_typ V). rewrite <- dom_concat.
    apply* wft_fv_tt; autos.

  splits.

  apply* subset_strengthen. eapply subset_trans. apply open_ee_fv_subset. exact HI.

  rewrite <- union_same. apply* subset_union_2. apply* subset_strengthen.
  eapply subset_trans. apply open_te_ee_fv_subset. exact HII.

  rewrite <- union_same. apply* subset_union_2. apply* subset_strengthen.

  (* cap *)
  pick_fresh x. forwards~ (HI & HII & HIII): H1 x. simpls.
  rewrite dom_concat in *. rewrite dom_single in *. unfolds open_ee.

  assert (Ha: fv_tt V \c dom (typ_env E)).
    forwards~ Htemp: (H0 x).
    destruct (typing_regular Htemp) as [He _].
    apply* wft_fv_tt.

  splits.

  apply* subset_strengthen. eapply subset_trans. apply open_ee_fv_subset.
  eapply subset_trans. eauto. apply subset_union_2.
    apply typ_env_dom_subset. apply subset_refl.

  rewrite <- union_same. apply* subset_union_2.
  eapply subset_trans. exact Ha. apply typ_env_dom_subset.
  apply* subset_strengthen. eapply subset_trans. apply open_te_ee_fv_subset.
    eapply subset_trans. eauto. apply subset_union_2.
      apply typ_env_dom_subset. apply subset_refl.

  rewrite <- union_same. apply* subset_union_2.
    eapply subset_trans. eauto. apply typ_env_dom_subset.
    apply* subset_strengthen. eapply subset_trans. eauto.
      apply subset_union_2. apply typ_env_dom_subset. apply subset_refl.

  (* app *)
  forwards(Ma & Mb & Mc): IHtyping1. forwards(Na & Nb & Nc): IHtyping2.
  simpls. splits.

  rewrite <- union_same. apply* subset_union_2.
  rewrite <- union_same. apply* subset_union_2.
  eapply subset_trans. apply subset_union_weak_r. exact Mc.

  (* tabs *)
  simpls. pick_fresh X. forwards~ (HI & HII & HIII) : (H0 X).
  rewrite dom_concat in *. rewrite dom_single in *.
  unfolds open_ee. unfolds open_te. unfolds open_tt.
  rewrite <- open_ee_te_fv_eq in HI.

  assert (Ha: fv_tt V \c dom E).
    forwards~ Htyp: (H X).
    destruct (typing_regular Htyp) as [He _].
    apply subset_strengthen with X; autos.
    rewrite <- dom_single with (v:= bind_sub V). rewrite <- dom_concat.
    apply* wft_fv_tt; autos.

  splits.

  eapply subset_strengthen. exact HI. autos.
  rewrite <- union_same. apply* subset_union_2. apply subset_strengthen with X; autos.
    eapply subset_trans. apply open_te_fv_subset. exact HII.
  rewrite <- union_same. apply* subset_union_2. apply subset_strengthen with X; autos.
    eapply subset_trans. apply open_tt_fv_subset. exact HIII.

  (* tapp *)
  lets(HI & HII & HIII): IHtyping. simpls.

  assert (Ha: fv_tt T \c dom E) by (lets*: subtyping_env_fv H0).

  splits; autos.

  rewrite <- union_same. apply* subset_union_2.
  eapply subset_trans. eapply open_tt_tt_fv_subset.
    rewrite <- union_same. apply* subset_union_2.
    eapply subset_trans. apply subset_union_weak_r. apply HIII.

  (* sub *)
  destructs IHtyping. splits; autos. lets*: subtyping_env_fv H0.
Qed.

Lemma typing_cap_closed_trm : forall e T E F x U V,
  typing (E & x ~: U & F) (trm_cap V e) T -> x \notin fv_ee e.
Proof. intros. inductions H;  eauto.
  repeat(rewrite typ_env_dist in *). lets: (ok_middle_inv (ok_from_okt H)).
  replace (typ_env (x ~: U)) with (@empty bind) in *
    by (rewrite single_def; simpl; rewrite* empty_def).
  rewrite concat_empty_r in *.
  assert (HI: typing (E & F) (trm_cap V e) (typ_arrow V T1)).
    apply* typing_cap. rewrite* typ_env_dist.
  destructs (typing_env_fv HI). simpls. rewrite <- notin_union in H2.
  unfolds subset. intros Hc. apply H2. rewrite <- dom_concat. autos.
Qed.

Lemma typing_cap_closed_typ : forall e V T,
  typing empty (trm_cap V e) (typ_arrow V T) ->
  forall X, X \notin fv_te e /\ X \notin fv_tt V /\ X \notin fv_tt T.
Proof. intros. lets(_ & HI & HII): typing_env_fv H.
  simpls. rewrite dom_empty in *. unfolds subset.
  specialize HI with X. specialize HII with X. rewrite in_union in *.
  splits; intros Hin; rewrite* <- (@in_empty var X).
Qed.

Lemma typing_through_subst_ee : forall U E F x T e u,
  typing (E & x ~: U & F) e T ->
  typing E u U ->
  typing (E & F) (subst_ee x u e) T.
Proof.
  introv TypT TypU. inductions TypT; introv; simpl.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih_bind* H0.
  apply typing_cap with L; eauto.
    rewrite* subst_ee_fresh. repeat(rewrite typ_env_dist in *).
    replace (typ_env (x ~: U)) with (@empty bind) in *
      by (rewrite single_def; simpl; rewrite* empty_def).
    rewrite concat_empty_r in *. autos.
    eapply typing_cap_closed_trm. eapply typing_cap; eauto.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    rewrite* subst_ee_open_te_var.
    apply_ih_bind* H0.
  apply* typing_tapp. apply* sub_strengthening.
  apply* typing_sub. apply* sub_strengthening.
Qed.

(************************************************************************ *)
(** Preservation by Type Substitution (11) *)

Lemma typing_through_subst_te : forall Q E F Z e T P,
  typing (E & Z ~<: Q & F) e T ->
  sub E P Q ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Typ PsubQ.
  inductions Typ; introv; simpls subst_tt; simpls subst_te.
  apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
   binds_cases H0; unsimpl_map_bind*.
  apply_fresh* typing_abs as y.
    unsimpl (subst_tb Z P (bind_typ V)).
    rewrite* subst_te_open_ee_var.
    apply_ih_map_bind* H0.
  apply_fresh* typing_cap as y.
    unsimpl (subst_tb Z P (bind_typ V)).
    rewrite* subst_te_open_ee_var. rewrite typ_env_dist.
    rewrite typ_env_map. apply_ih_map_bind* H1.
    repeat(rewrite typ_env_dist).
    replace (typ_env (Z ~<: Q)) with (Z ~<:Q) by (rewrite* single_def).
    rewrite concat_assoc. reflexivity.
    apply* sub_strengthening_env.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    unsimpl (subst_tb Z P (bind_sub V)).
    rewrite* subst_te_open_te_var.
    rewrite* subst_tt_open_tt_var.
    apply_ih_map_bind* H0.
  rewrite* subst_tt_open_tt. apply* typing_tapp.
    apply* sub_through_subst_tt.
  apply* typing_sub. apply* sub_through_subst_tt.
Qed.

(* ********************************************************************** *)
(** * Preservation *)

(* ********************************************************************** *)
(** Inversions for Typing (13) *)

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  forall U1 U2, sub E T (typ_arrow U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ sub E S2 U2.
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub. autos* (@sub_transitivity T).
Qed.

Lemma typing_inv_cap : forall E S1 e1 T,
  typing E (trm_cap S1 e1) T ->
  forall U1 U2, sub E T (typ_arrow U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ sub E S2 U2.
Proof.
  introv Typ. gen_eq e: (trm_cap S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub. splits*. exists T1.
    let L1 := gather_vars in exists L1. split; auto.
    rewrite <- (@concat_empty_l bind E).
    apply typing_weakening_env. rewrite* concat_empty_l.
    rewrite concat_empty_l. apply* okt_typ.
  autos* (@sub_transitivity T).
Qed.

Lemma typing_inv_tabs : forall E S1 e1 T,
  typing E (trm_tabs S1 e1) T ->
  forall U1 U2, sub E T (typ_all U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall X, X \notin L ->
     typing (E & X ~<: U1) (e1 open_te_var X) (S2 open_tt_var X)
     /\ sub (E & X ~<: U1) (S2 open_tt_var X) (U2 open_tt_var X).
Proof.
  intros E S1 e1 T H. gen_eq e: (trm_tabs S1 e1). gen S1 e1.
  induction H; intros S1 b EQ U1 U2 Sub; inversion EQ.
  inversions Sub. splits. auto.
   exists T1. let L1 := gather_vars in exists L1.
   intros Y Fr. splits.
    apply_empty* (@typing_narrowing S1). auto.
  autos* (@sub_transitivity T).
Qed.

(* ********************************************************************** *)
(** Preservation Result (20) *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  inversions Red; try solve [ apply* typing_app ].

  destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_ee_intro X).
     apply_empty (@typing_through_subst_ee V).
       apply* (@typing_sub S2). apply_empty* sub_weakening.
       autos*.

  destruct~ (typing_inv_cap Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_ee_intro X).
     apply_empty (@typing_through_subst_ee V).
       apply* (@typing_sub S2). apply_empty* sub_weakening.
       autos*.

  (* case: tapp *)
  inversions Red; try solve [ apply* typing_tapp ].
  destruct~ (typing_inv_tabs Typ (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_te_intro X).
     rewrite* (@subst_tt_intro X).
     (* todo: apply empty here *)
     asserts_rewrite (E = E & map (subst_tb X T) empty).
       rewrite map_empty. rewrite~ concat_empty_r.
     apply* (@typing_through_subst_te T1).
       rewrite* concat_empty_r.
  (* case sub *)
  apply* typing_sub.
Qed.

(* ********************************************************************** *)
(** * Progress *)

(* ********************************************************************** *)
(** Canonical Forms (14) *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_arrow U1 U2) ->
  exists V, exists e1, t = trm_abs V e1 \/ t = trm_cap V e1.
Proof.
  introv Val Typ. gen_eq E: (@empty bind).
  gen_eq T: (typ_arrow U1 U2). gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. inversion H.
      false (binds_empty_inv H0).
      inversions H0. forwards*: IHTyp.
Qed.

Lemma canonical_form_tabs : forall t U1 U2,
  value t -> typing empty t (typ_all U1 U2) ->
  exists V, exists e1, t = trm_tabs V e1.
Proof.
  introv Val Typ. gen_eq E: (@empty bind).
  gen_eq T: (typ_all U1 U2). gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. inversion H.
      false* binds_empty_inv.
      inversions H0. forwards*: IHTyp.
Qed.

(* ********************************************************************** *)
(** Progress Result (16) *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty bind). lets Typ': Typ.
  induction Typ; intros EQ; subst.
  (* case: var *)
  false* binds_empty_inv.
  (* case: abs *)
  left*.
  (* case: cap *)
  left*.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        destruct EQ; subst; exists* (open_ee e3 e2).
  (* case: tabs *)
  left*.
  (* case: tapp *)
  right. destruct~ IHTyp as [Val1 | [e1' Rede1']].
    destruct (canonical_form_tabs Val1 Typ) as [S [e3 EQ]].
      subst. exists* (open_te e3 T).
      exists* (trm_tapp e1' T).
  (* case: sub *)
  autos*.
Qed.


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Definition appTest  := fun (A : Set) (B: forall A, Set) (f: (forall a:A, B a)) (a:A)=>
 f a.

Let mode := true.

Definition ids : forall A : Set, A -> A := fun (A : Set) (x : A) => x.
Definition idsT  := forall A : Set, A -> A.

Run TemplateProgram (genParam [] mode true "appTest").
Eval compute in appTest_RR.

Run TemplateProgram (genParam [] mode true "idsT").
Eval compute in idsT_RR.

Print idsT.

Parametricity idsT.

(* Given f: some Pi Type, prove that the new theorem implies the old *)
Eval vm_compute in idsT_RR.

Run TemplateProgram (genParam [] mode true "ids").
Eval compute in ids_RR.

Definition idsTT  := fun A : Set => forall a:A, A.

Parametricity Recursive idsTT.

Run TemplateProgram (genParam [] mode true "idsTT").
Eval compute in idsTT_RR.

Print idsTT_RR.

Definition s := Set.
Run TemplateProgram (genParam [] mode  true "s").

Eval compute in s_RR.

Definition propIff : Type := forall A:Set, Prop.

Run TemplateProgram (genParam [] mode true "propIff").

Eval compute in propIff_RR.

Definition propIff2 : Prop := forall A:Prop, A.

Run TemplateProgram (genParam [] mode  true "propIff2").

Run TemplateProgram (printTerm "propIff2").

Eval compute in propIff2_RR.

Goal propIff2_RR = fun _ _ => True.
unfold propIff2_RR.
Print PiTSummary.
unfold PiATypeBSet. simpl.
Print PiATypeBSet.
Abort.

Definition p := Prop.
Run TemplateProgram (genParam [] mode  true "p").

Eval compute in p_RR.


(** This file collects general purpose definitions and theorems on
lists of numbers that are not in the Coq standard library. *)
From stdpp Require Export list.
From stdpp Require Import options.

(** * Definitions *)
(** [seqZ m n] generates the sequence [m], [m + 1], ..., [m + n - 1]
over integers, provided [0 ≤ n]. If [n < 0], then the range is empty. **)
Definition seqZ (m len: Z) : list Z :=
  (λ i: nat, Z.add (Z.of_nat i) m) <$> (seq 0 (Z.to_nat len)).
Global Arguments seqZ : simpl never.

Definition sum_list_with {A} (f : A → nat) : list A → nat :=
  fix go l :=
  match l with
  | [] => 0
  | x :: l => f x + go l
  end.
Notation sum_list := (sum_list_with id).

Definition max_list_with {A} (f : A → nat) : list A → nat :=
  fix go l :=
  match l with
  | [] => 0
  | x :: l => f x `max` go l
  end.
Notation max_list := (max_list_with id).

(** ** Conversion of integers to and from little endian *)
(** [Z_to_little_endian m n z] converts [z] into a list of [m] [n]-bit
integers in the little endian format. A negative [z] is encoded using
two's-complement. If [z] uses more than [m * n] bits, these additional
bits are discarded (see [Z_to_little_endian_to_Z]). [m] and [n] should be
non-negative. *)
Definition Z_to_little_endian (m n : Z) : Z → list Z :=
  Z.iter m (λ rec z, Z.land z (Z.ones n) :: rec (z ≫ n)%Z) (λ _, []).
Global Arguments Z_to_little_endian : simpl never.

(** [little_endian_to_Z n bs] converts the list [bs] of [n]-bit integers
into a number by interpreting [bs] as the little endian encoding.
The integers [b] in [bs] should be in the range [0 ≤ b < 2 ^ n]. *)
Fixpoint little_endian_to_Z (n : Z) (bs : list Z) : Z :=
  match bs with
  | [] => 0
  | b :: bs => Z.lor b (little_endian_to_Z n bs ≪ n)
  end.

(** * Properties *)
(** ** Properties of the [seq] function *)
Section seq.
  Implicit Types m n i j : nat.

  Lemma fmap_add_seq j j' n : Nat.add j <$> seq j' n = seq (j + j') n.
  Proof.
    revert j'. induction n as [|n IH]; intros j'; csimpl; [reflexivity|].
    by rewrite IH, Nat.add_succ_r.
  Qed.
  Lemma fmap_S_seq j n : S <$> seq j n = seq (S j) n.
  Proof. apply (fmap_add_seq 1). Qed.
  Lemma imap_seq {A B} (l : list A) (g : nat → B) i :
    imap (λ j _, g (i + j)) l = g <$> seq i (length l).
  Proof.
    revert i. induction l as [|x l IH]; [done|].
    csimpl. intros n. rewrite <-IH, <-plus_n_O. f_equal.
    apply imap_ext; simpl; auto with lia.
  Qed.
  Lemma imap_seq_0 {A B} (l : list A) (g : nat → B) :
    imap (λ j _, g j) l = g <$> seq 0 (length l).
  Proof. rewrite (imap_ext _ (λ i o, g (0 + i))); [|done]. apply imap_seq. Qed.
  Lemma lookup_seq_lt j n i : i < n → seq j n !! i = Some (j + i).
  Proof.
    revert j i. induction n as [|n IH]; intros j [|i] ?; simpl; auto with lia.
    rewrite IH; auto with lia.
  Qed.
  Lemma lookup_total_seq_lt j n i : i < n → seq j n !!! i = j + i.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seq_lt. Qed.
  Lemma lookup_seq_ge j n i : n ≤ i → seq j n !! i = None.
  Proof. revert j i. induction n; intros j [|i] ?; simpl; auto with lia. Qed.
  Lemma lookup_total_seq_ge j n i : n ≤ i → seq j n !!! i = inhabitant.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seq_ge. Qed.
  Lemma lookup_seq j n i j' : seq j n !! i = Some j' ↔ j' = j + i ∧ i < n.
  Proof.
    destruct (le_lt_dec n i).
    - rewrite lookup_seq_ge by done. naive_solver lia.
    - rewrite lookup_seq_lt by done. naive_solver lia.
  Qed.
  Lemma NoDup_seq j n : NoDup (seq j n).
  Proof. apply NoDup_ListNoDup, seq_NoDup. Qed.
  (* FIXME: This lemma is in the stdlib since Coq 8.12 *)
  Lemma seq_S n j : seq j (S n) = seq j n ++ [j + n].
  Proof.
    revert j. induction n as [|n IH]; intros j; f_equal/=; [done |].
    by rewrite IH, Nat.add_succ_r.
  Qed.

  Lemma elem_of_seq j n k :
    k ∈ seq j n ↔ j ≤ k < j + n.
  Proof. rewrite elem_of_list_In, in_seq. done. Qed.

  Lemma Forall_seq (P : nat → Prop) i n :
    Forall P (seq i n) ↔ ∀ j, i ≤ j < i + n → P j.
  Proof. rewrite Forall_forall. setoid_rewrite elem_of_seq. auto with lia. Qed.
End seq.

(** ** Properties of the [seqZ] function *)
Section seqZ.
  Implicit Types (m n : Z) (i j : nat).
  Local Open Scope Z_scope.

  Lemma seqZ_nil m n : n ≤ 0 → seqZ m n = [].
  Proof. by destruct n. Qed.
  Lemma seqZ_cons m n : 0 < n → seqZ m n = m :: seqZ (Z.succ m) (Z.pred n).
  Proof.
    intros H. unfold seqZ. replace n with (Z.succ (Z.pred n)) at 1 by lia.
    rewrite Z2Nat.inj_succ by lia. f_equal/=.
    rewrite <-fmap_S_seq, <-list_fmap_compose.
    apply map_ext; naive_solver lia.
  Qed.
  Lemma seqZ_length m n : length (seqZ m n) = Z.to_nat n.
  Proof. unfold seqZ; by rewrite fmap_length, seq_length. Qed.
  Lemma fmap_add_seqZ m m' n : Z.add m <$> seqZ m' n = seqZ (m + m') n.
  Proof.
    revert m'. induction n as [|n ? IH|] using (Z.succ_pred_induction 0); intros m'.
    - by rewrite seqZ_nil.
    - rewrite (seqZ_cons m') by lia. rewrite (seqZ_cons (m + m')) by lia.
      f_equal/=. rewrite Z.pred_succ, IH; simpl. f_equal; lia.
    - by rewrite !seqZ_nil by lia.
  Qed.
  Lemma lookup_seqZ_lt m n i : Z.of_nat i < n → seqZ m n !! i = Some (m + Z.of_nat i).
  Proof.
    revert m i. induction n as [|n ? IH|] using (Z.succ_pred_induction 0);
      intros m i Hi; [lia| |lia].
    rewrite seqZ_cons by lia. destruct i as [|i]; simpl.
    - f_equal; lia.
    - rewrite Z.pred_succ, IH by lia. f_equal; lia.
  Qed.
  Lemma lookup_total_seqZ_lt m n i : Z.of_nat i < n → seqZ m n !!! i = m + Z.of_nat i.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seqZ_lt. Qed.
  Lemma lookup_seqZ_ge m n i : n ≤ Z.of_nat i → seqZ m n !! i = None.
  Proof.
    revert m i.
    induction n as [|n ? IH|] using (Z.succ_pred_induction 0); intros m i Hi; try lia.
    - by rewrite seqZ_nil.
    - rewrite seqZ_cons by lia.
      destruct i as [|i]; simpl; [lia|]. by rewrite Z.pred_succ, IH by lia.
    - by rewrite seqZ_nil by lia.
  Qed.
  Lemma lookup_total_seqZ_ge m n i : n ≤ Z.of_nat i → seqZ m n !!! i = inhabitant.
  Proof. intros. by rewrite !list_lookup_total_alt, lookup_seqZ_ge. Qed.
  Lemma lookup_seqZ m n i m' : seqZ m n !! i = Some m' ↔ m' = m + Z.of_nat i ∧ Z.of_nat i < n.
  Proof.
    destruct (Z_le_gt_dec n (Z.of_nat i)).
    - rewrite lookup_seqZ_ge by lia. naive_solver lia.
    - rewrite lookup_seqZ_lt by lia. naive_solver lia.
  Qed.
  Lemma NoDup_seqZ m n : NoDup (seqZ m n).
  Proof. apply NoDup_fmap_2, NoDup_seq. intros ???; lia. Qed.

  Lemma seqZ_app m n1 n2 :
    0 ≤ n1 →
    0 ≤ n2 →
    seqZ m (n1 + n2) = seqZ m n1 ++ seqZ (m + n1) n2.
  Proof.
    intros. unfold seqZ. rewrite Z2Nat.inj_add, seq_app, fmap_app by done.
    f_equal. rewrite Nat.add_comm, <-!fmap_add_seq, <-list_fmap_compose.
    apply list_fmap_ext; intros j n; simpl.
    rewrite Nat2Z.inj_add, Z2Nat.id by done. lia.
  Qed.

  Lemma seqZ_S m i : seqZ m (Z.of_nat (S i)) = seqZ m (Z.of_nat i) ++ [m + Z.of_nat i].
  Proof.
    unfold seqZ. rewrite !Nat2Z.id, seq_S, fmap_app.
    simpl. by rewrite Z.add_comm.
  Qed.

  Lemma elem_of_seqZ m n k :
    k ∈ seqZ m n ↔ m ≤ k < m + n.
  Proof.
    rewrite elem_of_list_lookup.
    setoid_rewrite lookup_seqZ. split; [naive_solver lia|].
    exists (Z.to_nat (k - m)). rewrite Z2Nat.id by lia. lia.
  Qed.

  Lemma Forall_seqZ (P : Z → Prop) m n :
    Forall P (seqZ m n) ↔ ∀ m', m ≤ m' < m + n → P m'.
  Proof. rewrite Forall_forall. setoid_rewrite elem_of_seqZ. auto with lia. Qed.
End seqZ.

(** ** Properties of the [sum_list] function *)
Section sum_list.
  Context {A : Type}.
  Implicit Types x y z : A.
  Implicit Types l k : list A.
  Lemma sum_list_with_app (f : A → nat) l k :
    sum_list_with f (l ++ k) = sum_list_with f l + sum_list_with f k.
  Proof. induction l; simpl; lia. Qed.
  Lemma sum_list_with_reverse (f : A → nat) l :
    sum_list_with f (reverse l) = sum_list_with f l.
  Proof.
    induction l; simpl; rewrite ?reverse_cons, ?sum_list_with_app; simpl; lia.
  Qed.
  Lemma sum_list_with_in x (f : A → nat) ls : x ∈ ls → f x ≤ sum_list_with f ls.
  Proof. induction 1; simpl; lia. Qed.
  Lemma join_reshape szs l :
    sum_list szs = length l → mjoin (reshape szs l) = l.
  Proof.
    revert l. induction szs as [|sz szs IH]; simpl; intros l Hl; [by destruct l|].
    by rewrite IH, take_drop by (rewrite drop_length; lia).
  Qed.
  Lemma sum_list_replicate n m : sum_list (replicate m n) = m * n.
  Proof. induction m; simpl; auto. Qed.
  Lemma sum_list_fmap_same n l f :
    Forall (λ x, f x = n) l →
    sum_list (f <$> l) = length l * n.
  Proof. induction 1; csimpl; lia. Qed.
  Lemma sum_list_fmap_const l n :
    sum_list ((λ _, n) <$> l) = length l * n.
  Proof. by apply sum_list_fmap_same, Forall_true. Qed.
End sum_list.

(** ** Properties of the [mjoin] function that rely on [sum_list] *)
Section mjoin.
  Context {A : Type}.
  Implicit Types x y z : A.
  Implicit Types l k : list A.
  Implicit Types ls : list (list A).

  Lemma join_length ls:
    length (mjoin ls) = sum_list (length <$> ls).
  Proof. induction ls; [done|]; csimpl. rewrite app_length. lia. Qed.

  Lemma join_lookup_Some ls i x :
    mjoin ls !! i = Some x ↔ ∃ j l i', ls !! j = Some l ∧ l !! i' = Some x
                                     ∧ i = sum_list (length <$> take j ls) + i'.
  Proof.
    revert i. induction ls as [|l ls IH]; csimpl; intros i.
    { setoid_rewrite lookup_nil. naive_solver. }
    rewrite lookup_app_Some, IH. split.
    - destruct 1 as [?|(?&?&?&?&?&?&?)].
      + eexists 0. naive_solver.
      + eexists (S _); naive_solver lia.
    - destruct 1 as [[|?] ?]; naive_solver lia.
  Qed.

  Lemma join_lookup_Some_same_length n ls i x :
    Forall (λ l, length l = n) ls →
    mjoin ls !! i = Some x ↔ ∃ j l i', ls !! j = Some l ∧ l !! i' = Some x
                                     ∧ i = j * n + i'.
  Proof.
    intros Hl. rewrite join_lookup_Some.
    f_equiv; intros j. f_equiv; intros l. f_equiv; intros i'.
    assert (ls !! j = Some l → j < length ls) by eauto using lookup_lt_Some.
    rewrite (sum_list_fmap_same n), take_length by auto using Forall_take.
    naive_solver lia.
  Qed.

  Lemma join_lookup_Some_same_length' n ls j i x :
    Forall (λ l, length l = n) ls →
    i < n →
    mjoin ls !! (j * n + i) = Some x ↔ ∃ l, ls !! j = Some l ∧ l !! i = Some x.
  Proof.
    intros. rewrite join_lookup_Some_same_length by done.
    split; [|naive_solver].
    destruct 1 as (j'&l'&i'&?&?&Hj); decompose_Forall.
    assert (i' < length l') by eauto using lookup_lt_Some.
    apply Nat.mul_split_l in Hj; naive_solver.
  Qed.
End mjoin.

(** ** Properties of the [max_list] function *)
Section max_list.
  Context {A : Type}.

  Lemma max_list_elem_of_le n ns :
    n ∈ ns → n ≤ max_list ns.
  Proof. induction 1; simpl; lia. Qed.

  Lemma max_list_not_elem_of_gt n ns : max_list ns < n → n ∉ ns.
  Proof. intros ??%max_list_elem_of_le. lia. Qed.

  Lemma max_list_elem_of ns : ns ≠ [] → max_list ns ∈ ns.
  Proof.
    intros. induction ns as [|n ns IHns]; [done|]. simpl.
    destruct (Nat.max_spec n (max_list ns)) as [[? ->]|[? ->]].
    - destruct ns.
      + simpl in *. lia.
      + by apply elem_of_list_further, IHns.
    - apply elem_of_list_here.
  Qed.
End max_list.

(** ** Properties of the [Z_to_little_endian] and [little_endian_to_Z] functions *)
Section Z_little_endian.
  Local Open Scope Z_scope.
  Implicit Types m n z : Z.

  Lemma Z_to_little_endian_0 n z : Z_to_little_endian 0 n z = [].
  Proof. done. Qed.

  Lemma Z_to_little_endian_succ m n z :
    0 ≤ m →
    Z_to_little_endian (Z.succ m) n z
    = Z.land z (Z.ones n) :: Z_to_little_endian m n (z ≫ n).
  Proof.
    unfold Z_to_little_endian. intros.
    by rewrite !iter_nat_of_Z, Zabs2Nat.inj_succ by lia.
  Qed.

  Lemma Z_to_little_endian_to_Z m n bs :
    m = Z.of_nat (length bs) → 0 ≤ n →
    Forall (λ b, 0 ≤ b < 2 ^ n) bs →
    Z_to_little_endian m n (little_endian_to_Z n bs) = bs.
  Proof.
    intros -> ?. induction 1 as [|b bs ? ? IH]; [done|]; simpl.
    rewrite Nat2Z.inj_succ, Z_to_little_endian_succ by lia. f_equal.
    - apply Z.bits_inj_iff'. intros z' ?.
      rewrite !Z.land_spec, Z.lor_spec, Z.ones_spec by lia.
      case_bool_decide.
      + rewrite andb_true_r, Z.shiftl_spec_low, orb_false_r by lia. done.
      + rewrite andb_false_r.
        symmetry. eapply (Z.bounded_iff_bits_nonneg n); lia.
    - rewrite <-IH at 3. f_equal.
      apply Z.bits_inj_iff'. intros z' ?.
      rewrite Z.shiftr_spec, Z.lor_spec, Z.shiftl_spec by lia.
      assert (Z.testbit b (z' + n) = false) as ->.
      { apply (Z.bounded_iff_bits_nonneg n); lia. }
      rewrite orb_false_l. f_equal. lia.
  Qed.

  Lemma little_endian_to_Z_to_little_endian m n z :
    0 ≤ n → 0 ≤ m →
    little_endian_to_Z n (Z_to_little_endian m n z) = z `mod` 2 ^ (m * n).
  Proof.
    intros ? Hm. rewrite <-Z.land_ones by lia.
    revert z.
    induction m as [|m ? IH|] using (Z.succ_pred_induction 0); intros z; [..|lia].
    { Z.bitwise. by rewrite andb_false_r. }
    rewrite Z_to_little_endian_succ by lia; simpl. rewrite IH by lia.
    apply Z.bits_inj_iff'. intros z' ?.
    rewrite Z.land_spec, Z.lor_spec, Z.shiftl_spec, !Z.land_spec by lia.
    rewrite (Z.ones_spec n z') by lia. case_bool_decide.
    - rewrite andb_true_r, (Z.testbit_neg_r _ (z' - n)), orb_false_r by lia. simpl.
      by rewrite Z.ones_spec, bool_decide_true, andb_true_r by lia.
    - rewrite andb_false_r, orb_false_l.
      rewrite Z.shiftr_spec by lia. f_equal; [f_equal; lia|].
      rewrite !Z.ones_spec by lia. apply bool_decide_ext. lia.
  Qed.

  Lemma Z_to_little_endian_length m n z :
    0 ≤ m →
    Z.of_nat (length (Z_to_little_endian m n z)) = m.
  Proof.
    intros. revert z. induction m as [|m ? IH|]
      using (Z.succ_pred_induction 0); intros z; [done| |lia].
    rewrite Z_to_little_endian_succ by lia. simpl. by rewrite Nat2Z.inj_succ, IH.
  Qed.

  Lemma Z_to_little_endian_bound m n z :
    0 ≤ n → 0 ≤ m →
    Forall (λ b, 0 ≤ b < 2 ^ n) (Z_to_little_endian m n z).
  Proof.
    intros. revert z.
    induction m as [|m ? IH|] using (Z.succ_pred_induction 0); intros z; [..|lia].
    { by constructor. }
    rewrite Z_to_little_endian_succ by lia.
    constructor; [|by apply IH]. rewrite Z.land_ones by lia.
    apply Z.mod_pos_bound, Z.pow_pos_nonneg; lia.
  Qed.

  Lemma little_endian_to_Z_bound n bs :
    0 ≤ n →
    Forall (λ b, 0 ≤ b < 2 ^ n) bs →
    0 ≤ little_endian_to_Z n bs < 2 ^ (Z.of_nat (length bs) * n).
  Proof.
    intros ?. induction 1 as [|b bs Hb ? IH]; [done|]; simpl.
    apply Z.bounded_iff_bits_nonneg'; [lia|..].
    { apply Z.lor_nonneg. split; [lia|]. apply Z.shiftl_nonneg. lia. }
    intros z' ?. rewrite Z.lor_spec.
    rewrite Z.bounded_iff_bits_nonneg' in Hb by lia.
    rewrite Hb, orb_false_l, Z.shiftl_spec by lia.
    apply (Z.bounded_iff_bits_nonneg' (Z.of_nat (length bs) * n)); lia.
  Qed.

  Lemma Z_to_little_endian_lookup_Some m n z (i : nat) x :
    0 ≤ m → 0 ≤ n →
    Z_to_little_endian m n z !! i = Some x ↔
    Z.of_nat i < m ∧ x = Z.land (z ≫ (Z.of_nat i * n)) (Z.ones n).
  Proof.
    revert z i. induction m as [|m ? IH|] using (Z.succ_pred_induction 0);
      intros z i ??; [..|lia].
    { destruct i; simpl; naive_solver lia. }
    rewrite Z_to_little_endian_succ by lia. destruct i as [|i]; simpl.
    { naive_solver lia. }
    rewrite IH, Z.shiftr_shiftr by lia.
    naive_solver auto with f_equal lia.
  Qed.

  Lemma little_endian_to_Z_spec n bs i b :
    0 ≤ i → 0 < n →
    Forall (λ b, 0 ≤ b < 2 ^ n) bs →
    bs !! Z.to_nat (i `div` n) = Some b →
    Z.testbit (little_endian_to_Z n bs) i = Z.testbit b (i `mod` n).
  Proof.
    intros Hi Hn Hbs. revert i Hi.
    induction Hbs as [|b' bs [??] ? IH]; intros i ? Hlookup; simplify_eq/=.
    destruct (decide (i < n)).
    - rewrite Z.div_small in Hlookup by lia. simplify_eq/=.
      rewrite Z.lor_spec, Z.shiftl_spec, Z.mod_small by lia.
      by rewrite (Z.testbit_neg_r _ (i - n)), orb_false_r by lia.
    - assert (Z.to_nat (i `div` n) = S (Z.to_nat ((i - n) `div` n))) as Hdiv.
      { rewrite <-Z2Nat.inj_succ by (apply Z.div_pos; lia).
        rewrite <-Z.add_1_r, <-Z.div_add by lia.
        do 2 f_equal. lia. }
      rewrite Hdiv in Hlookup; simplify_eq/=.
      rewrite Z.lor_spec, Z.shiftl_spec, IH by auto with lia.
      assert (Z.testbit b' i = false) as ->.
      { apply (Z.bounded_iff_bits_nonneg n); lia. }
      by rewrite <-Zminus_mod_idemp_r, Z_mod_same_full, Z.sub_0_r.
  Qed.
End Z_little_endian.