(** Authors: Jianzhou Zhao. *)

Require Import LinF_PreLib.
Require Import Coq.Arith.Max.

(* ********************************************************************** *)
(** * Closing terms *)

Fixpoint close_tt_rec (K : nat) (X : atom) (T : typ) {struct T} : typ :=
  match T with
    | typ_bvar J => typ_bvar J
    | typ_fvar Y => if X == Y then K else typ_fvar Y
    | typ_arrow k T1 T2 => typ_arrow k (close_tt_rec K X T1) (close_tt_rec K X T2)
    | typ_all k T1 => typ_all k (close_tt_rec (S K) X T1)
    | typ_with T1 T2 => typ_with (close_tt_rec K X T1) (close_tt_rec K X T2)
  end.

Fixpoint close_te_rec (K : nat) (X : atom) (e : exp) {struct e} : exp :=
  match e with
    | exp_bvar i => exp_bvar i
    | exp_fvar x => exp_fvar x
    | exp_abs k V e1 => exp_abs  k (close_tt_rec K X V)  (close_te_rec K X e1)
    | exp_app e1 e2 => exp_app  (close_te_rec K X e1) (close_te_rec K X e2)
    | exp_tabs k e1 => exp_tabs k (close_te_rec (S K) X e1)
    | exp_tapp e1 V => exp_tapp (close_te_rec K X e1) (close_tt_rec K X V)
    | exp_apair e1 e2 => exp_apair (close_te_rec K X e1) (close_te_rec K X e2)
    | exp_fst e => exp_fst (close_te_rec K X e)
    | exp_snd e => exp_snd (close_te_rec K X e)
  end.

Fixpoint close_ee_rec (k : nat) (x : atom) (e : exp) {struct e} : exp :=
  match e with
    | exp_bvar i => exp_bvar i
    | exp_fvar y => if x == y then k else exp_fvar y
    | exp_abs K V e1 => exp_abs K V (close_ee_rec (S k) x e1)
    | exp_app e1 e2 => exp_app (close_ee_rec k x e1) (close_ee_rec k x e2)
    | exp_tabs K e1 => exp_tabs K (close_ee_rec k x e1)
    | exp_tapp e1 V => exp_tapp (close_ee_rec k x e1) V
    | exp_apair e1 e2 => exp_apair (close_ee_rec k x e1) (close_ee_rec k x e2)
    | exp_fst e => exp_fst (close_ee_rec k x e)
    | exp_snd e => exp_snd (close_ee_rec k x e)
  end.

Definition close_tt T X := close_tt_rec 0 X T.
Definition close_te e X := close_te_rec 0 X e.
Definition close_ee e x := close_ee_rec 0 x e.

Inductive ctx : Set :=
  | ctx_hole  : ctx
  | ctx_abs_free  : kn -> typ -> ctx ->  ctx
  | ctx_abs_capture  : kn -> atom -> typ -> ctx ->  ctx
  | ctx_app1  : ctx -> exp -> ctx
  | ctx_app2  : exp -> ctx ->  ctx
  | ctx_tabs_free  :  kn -> ctx ->  ctx
  | ctx_tabs_capture  :  atom -> kn -> ctx ->  ctx
  | ctx_tapp  : ctx -> typ -> ctx
  | ctx_apair1 : ctx -> exp -> ctx
  | ctx_apair2 : exp -> ctx -> ctx
  | ctx_fst : ctx -> ctx
  | ctx_snd : ctx -> ctx
  .

Fixpoint open_tc_rec (K : nat) (U : typ) (C : ctx)  {struct C} : ctx :=
  match C with
  | ctx_hole  => ctx_hole
  | ctx_abs_free k V C1 => ctx_abs_free k (open_tt_rec K U V) (open_tc_rec K U C1)
  | ctx_abs_capture k x V C1 => ctx_abs_capture k x (open_tt_rec K U V) (open_tc_rec K U C1)
  | ctx_app1  C1 e2 => ctx_app1 (open_tc_rec K U C1) (open_te_rec K U e2)
  | ctx_app2  v1 C2 => ctx_app2 (open_te_rec K U v1) (open_tc_rec K U C2)
  | ctx_tabs_free k C1 => ctx_tabs_free k (open_tc_rec (S K) U C1)
  | ctx_tabs_capture X k C1 => ctx_tabs_capture X k (open_tc_rec (S K) U C1)
  | ctx_tapp C1 V => ctx_tapp (open_tc_rec K U C1) (open_tt_rec K U V)
  | ctx_apair1 C1 e2 => ctx_apair1 (open_tc_rec K U C1) (open_te_rec K U e2)
  | ctx_apair2 e1 C2 => ctx_apair2 (open_te_rec K U e1) (open_tc_rec K U C2)
  | ctx_fst C1 => ctx_fst (open_tc_rec K U C1)
  | ctx_snd C1 => ctx_snd (open_tc_rec K U C1)
  end.

Fixpoint open_ec_rec (K : nat) (f : exp) (C : ctx)  {struct C} : ctx :=
  match C with
  | ctx_hole  => ctx_hole
  | ctx_abs_free k V C1 => ctx_abs_free k V (open_ec_rec (S K) f C1)
  | ctx_abs_capture k x V C1 => ctx_abs_capture k x V (open_ec_rec (S K) f C1)
  | ctx_app1  C1 e2 => ctx_app1 (open_ec_rec K f C1) (open_ee_rec K f e2)
  | ctx_app2  v1 C2 => ctx_app2 (open_ee_rec K f v1) (open_ec_rec K f C2)
  | ctx_tabs_free k C1 => ctx_tabs_free k (open_ec_rec K f C1)
  | ctx_tabs_capture X k C1 => ctx_tabs_capture X k (open_ec_rec K f C1)
  | ctx_tapp C1 V => ctx_tapp (open_ec_rec K f C1) V
  | ctx_apair1 C1 e2 => ctx_apair1 (open_ec_rec K f C1) (open_ee_rec K f e2)
  | ctx_apair2 e1 C2 => ctx_apair2 (open_ee_rec K f e1) (open_ec_rec K f C2)
  | ctx_fst C1 => ctx_fst (open_ec_rec K f C1)
  | ctx_snd C1 => ctx_snd (open_ec_rec K f C1)
  end.

Fixpoint close_tc_rec (K : nat)(X : atom) (C : ctx)  {struct C} : ctx :=
  match C with
  | ctx_hole  => ctx_hole
  | ctx_abs_free k V C1 => ctx_abs_free k (close_tt_rec K X V) (close_tc_rec K X C1)
  | ctx_abs_capture k x V C1 => ctx_abs_capture k x (close_tt_rec K X V) (close_tc_rec K X C1)
  | ctx_app1  C1 e2 => ctx_app1 (close_tc_rec K X C1) (close_te_rec K X e2)
  | ctx_app2  v1 C2 => ctx_app2 (close_te_rec K X v1) (close_tc_rec K X C2)
  | ctx_tabs_free k C1 => ctx_tabs_free k (close_tc_rec (S K) X C1)
  | ctx_tabs_capture Y k C1 => ctx_tabs_capture Y k (close_tc_rec (S K) X C1)
  | ctx_tapp C1 V => ctx_tapp (close_tc_rec K X C1) (close_tt_rec K X V)
  | ctx_apair1 C1 e2 => ctx_apair1 (close_tc_rec K X C1) (close_te_rec K X e2)
  | ctx_apair2 e1 C2 => ctx_apair2 (close_te_rec K X e1) (close_tc_rec K X C2)
  | ctx_fst C1 => ctx_fst (close_tc_rec K X C1)
  | ctx_snd C1 => ctx_snd (close_tc_rec K X C1)
  end.

Fixpoint close_ec_rec (K : nat) (x : atom) (C : ctx)  {struct C} : ctx :=
  match C with
  | ctx_hole  => ctx_hole
  | ctx_abs_free k V C1 => ctx_abs_free k V (close_ec_rec (S K) x C1)
  | ctx_abs_capture k y V C1 => ctx_abs_capture k y V (close_ec_rec (S K) x C1)
  | ctx_app1  C1 e2 => ctx_app1 (close_ec_rec K x C1) (close_ee_rec K x e2)
  | ctx_app2  v1 C2 => ctx_app2 (close_ee_rec K x v1) (close_ec_rec K x C2)
  | ctx_tabs_free k C1 => ctx_tabs_free k (close_ec_rec K x C1)
  | ctx_tabs_capture X k C1 => ctx_tabs_capture X k (close_ec_rec K x C1)
  | ctx_tapp C1 V => ctx_tapp (close_ec_rec K x C1) V
  | ctx_apair1 C1 e2 => ctx_apair1 (close_ec_rec K x C1) (close_ee_rec K x e2)
  | ctx_apair2 e1 C2 => ctx_apair2 (close_ee_rec K x e1) (close_ec_rec K x C2)
  | ctx_fst C1 => ctx_fst (close_ec_rec K x C1)
  | ctx_snd C1 => ctx_snd (close_ec_rec K x C1)
  end.

Definition open_tc C U := open_tc_rec 0 U C.
Definition open_ec C e := open_ec_rec 0 e C.
Definition close_tc C X := close_tc_rec 0 X C.
Definition close_ec C x := close_ec_rec 0 x C.

Inductive context : ctx -> Prop :=
  | context_hole  : context ctx_hole
  | context_abs_free  :  forall L K T C1,
      type T ->
      (forall x : atom, x `notin` L -> context (open_ec C1 x)) ->
      context (ctx_abs_free K T C1)
  | context_abs_capture  :  forall L K y T C1,
      type T ->
      (forall x : atom, x `notin` L -> context (open_ec C1 x)) ->
      context (ctx_abs_capture K y T C1)
  | context_app1  : forall C1 e2, context C1 -> expr e2 -> context (ctx_app1 C1 e2)
  | context_app2  : forall e1 C2, expr e1 -> context C2 -> context (ctx_app2 e1 C2)
  | context_tabs_free  :  forall L K C1,
      (forall X : atom, X `notin` L -> context (open_tc C1 X)) ->
      context (ctx_tabs_free K C1)
  | context_tabs_capture  :  forall L Y K C1,
      (forall X : atom, X `notin` L -> context (open_tc C1 X)) ->
      context (ctx_tabs_capture Y K C1)
  | context_tapp  : forall C1 V, context C1 -> type V -> context (ctx_tapp C1 V)
  | context_apair1 : forall C1 e2, context C1 -> expr e2 -> context (ctx_apair1 C1 e2)
  | context_apair2 : forall e1 C2,  expr e1 -> context C2 -> context (ctx_apair2 e1 C2)
  | context_fst : forall C1, context C1 -> context (ctx_fst C1)
  | context_snf : forall C1, context C1 -> context (ctx_snd C1)
  .

Inductive vcontext : ctx -> Prop :=
  | vcontext_abs_free  : forall K T C,  context (ctx_abs_free K T C) -> vcontext (ctx_abs_free K T C)
  | vcontext_abs_capture  : forall K x T C,  context (ctx_abs_capture K x T C) -> vcontext (ctx_abs_capture K x T C)
  | vcontext_tabs_free  :  forall K C,  context (ctx_tabs_free K C) -> vcontext (ctx_tabs_free K C)
  | vcontext_tabs_capture  :  forall X K C,  context (ctx_tabs_capture X K C) -> vcontext (ctx_tabs_capture X K C)
  | vcontext_apair1 : forall C1 e2, context (ctx_apair1 C1 e2) -> vcontext (ctx_apair1 C1 e2)
  | vcontext_apair2 : forall v1 C2, context (ctx_apair2 v1 C2) -> vcontext (ctx_apair2 v1 C2)
  .

Hint Constructors ctx vcontext context.

Fixpoint shift_ee_rec (k : nat) (b : nat) (e : exp) {struct e} : exp :=
  match e with
    | exp_bvar i =>
        match (le_lt_dec b i) with
        | left _   (* b <= i *) => exp_bvar (i + k)
        | right _ (* b > i *)  => exp_bvar i
        end
    | exp_fvar x => exp_fvar x
    | exp_abs K V e1 => exp_abs K V (shift_ee_rec k (S b) e1)
    | exp_app e1 e2 => exp_app (shift_ee_rec k b e1) (shift_ee_rec k b e2)
    | exp_tabs K e1 => exp_tabs K (shift_ee_rec k b e1)
    | exp_tapp e1 V => exp_tapp (shift_ee_rec k b e1) V
    | exp_apair e1 e2 => exp_apair (shift_ee_rec k b e1) (shift_ee_rec k b e2)
    | exp_fst e => exp_fst (shift_ee_rec k b e)
    | exp_snd e => exp_snd (shift_ee_rec k b e)
  end.

Fixpoint shift_tt_rec (k : nat) (b : nat) (t : typ) {struct t} : typ :=
  match t with
    | typ_bvar i =>
        match (le_lt_dec b i) with
        | left _   (* b <= i *) => typ_bvar (i + k)
        | right _ (* b > i *)  => typ_bvar i
        end
    | typ_fvar x => typ_fvar x
    | typ_arrow K t1 t2 => typ_arrow K (shift_tt_rec k b t1) (shift_tt_rec k b t2)
    | typ_all K t1 => typ_all K (shift_tt_rec k (S b) t1)
    | typ_with t1 t2 => typ_with (shift_tt_rec k b t1) (shift_tt_rec k b t2)
  end.

Fixpoint shift_te_rec (k : nat) (b : nat) (e : exp) {struct e} : exp :=
  match e with
    | exp_bvar i => exp_bvar i
    | exp_fvar x => exp_fvar x
    | exp_abs K V e1 => exp_abs K (shift_tt_rec k b V) (shift_te_rec k b e1)
    | exp_app e1 e2 => exp_app (shift_te_rec k b e1) (shift_te_rec k b e2)
    | exp_tabs K e1 => exp_tabs K (shift_te_rec k (S b) e1)
    | exp_tapp e1 V => exp_tapp (shift_te_rec k b e1) (shift_tt_rec k b V)
    | exp_apair e1 e2 => exp_apair (shift_te_rec k b e1) (shift_te_rec k b e2)
    | exp_fst e => exp_fst (shift_te_rec k b e)
    | exp_snd e => exp_snd (shift_te_rec k b e)
  end.

Definition shift_ee e := shift_ee_rec 1 0 e.
Definition shift_tt t := shift_tt_rec 1 0 t.
Definition shift_te e := shift_te_rec 1 0 e.

Fixpoint plug (C : ctx) (u : exp) {struct C} : exp :=
  match C  with
  | ctx_hole  => u
  | ctx_abs_free K V C1   => exp_abs K V (plug C1 (shift_ee u ))
  | ctx_abs_capture K x V C1   => exp_abs K V (plug C1 (close_ee (shift_ee u )x))
  | ctx_app1 C1 e2   => exp_app (plug C1 u) e2
  | ctx_app2  v1 C2  => exp_app v1 (plug C2 u)
  | ctx_tabs_free K C1   => exp_tabs K (plug C1 (shift_te u))
  | ctx_tabs_capture X K C1   => exp_tabs K (plug C1 (close_te (shift_te u) X))
  | ctx_tapp C1 V   => exp_tapp (plug C1 u) V
  | ctx_apair1 C1 e2   => exp_apair (plug C1 u) e2
  | ctx_apair2 e1 C2  => exp_apair e1 (plug C2 u)
  | ctx_fst C1       => exp_fst (plug C1 u)
  | ctx_snd C1       => exp_snd (plug C1 u)
  end.

Fixpoint remove_gdom (E:env) {struct E } : env :=
  match E with
  | nil => nil
  | (X, bind_kn K)::E => (X, bind_kn K)::(remove_gdom E)
  | (x, bind_typ T)::E => (remove_gdom E)
  end.

Fixpoint shift_ec_rec (k : nat) (b : nat) (C : ctx) {struct C} : ctx :=
  match C with
  | ctx_hole => ctx_hole
  | ctx_abs_free K V C1 => ctx_abs_free K V (shift_ec_rec k (S b) C1)
  | ctx_abs_capture K x V C1 => ctx_abs_capture K x V (shift_ec_rec k (S b) C1)
  | ctx_app1 C1 e2 => ctx_app1 (shift_ec_rec k b C1) (shift_ee_rec k b e2)
  | ctx_app2 e1 C2 => ctx_app2 (shift_ee_rec k b e1) (shift_ec_rec k b C2)
  | ctx_tabs_free K C1 => ctx_tabs_free K (shift_ec_rec k b C1)
  | ctx_tabs_capture x K C1 => ctx_tabs_capture x K (shift_ec_rec k b C1)
  | ctx_tapp C1 V => ctx_tapp (shift_ec_rec k b C1) V
  | ctx_apair1 C1 e2 => ctx_apair1 (shift_ec_rec k b C1) (shift_ee_rec k b e2)
  | ctx_apair2 e1 C2 => ctx_apair2 (shift_ee_rec k b e1) (shift_ec_rec k b C2)
  | ctx_fst C1 => ctx_fst (shift_ec_rec k b C1)
  | ctx_snd C1 => ctx_snd (shift_ec_rec k b C1)
  end.

Fixpoint shift_tc_rec (k : nat) (b : nat) (C : ctx) {struct C} : ctx :=
  match C with
  | ctx_hole => ctx_hole
  | ctx_abs_free K V C1 => ctx_abs_free K (shift_tt_rec k b V) (shift_tc_rec k b C1)
  | ctx_abs_capture K x V C1 => ctx_abs_capture K x (shift_tt_rec k b V) (shift_tc_rec k b C1)
  | ctx_app1 C1 e2 => ctx_app1 (shift_tc_rec k b C1) (shift_te_rec k b e2)
  | ctx_app2 e1 C2 => ctx_app2 (shift_te_rec k b e1) (shift_tc_rec k b C2)
  | ctx_tabs_free K C1 => ctx_tabs_free K (shift_tc_rec k (S b) C1)
  | ctx_tabs_capture x K C1 => ctx_tabs_capture x K (shift_tc_rec k (S b) C1)
  | ctx_tapp C1 V => ctx_tapp (shift_tc_rec k b C1) (shift_tt_rec k b V)
  | ctx_apair1 C1 e2 => ctx_apair1 (shift_tc_rec k b C1) (shift_te_rec k b e2)
  | ctx_apair2 e1 C2 => ctx_apair2 (shift_te_rec k b e1) (shift_tc_rec k b C2)
  | ctx_fst C1 => ctx_fst (shift_tc_rec k b C1)
  | ctx_snd C1 => ctx_snd (shift_tc_rec k b C1)
  end.

Definition shift_ec C := shift_ec_rec 1 0 C.
Definition shift_tc C := shift_tc_rec 1 0 C.

Fixpoint plugC (C0 C:ctx) {struct C0} : ctx :=
  match C0  with
  | ctx_hole  => C
  | ctx_abs_free K V C1   => ctx_abs_free K V (plugC C1 (shift_ec C ))
  | ctx_abs_capture K x V C1   => ctx_abs_capture K x V (plugC C1 (close_ec (shift_ec C ) x))
  | ctx_app1 C1 e2   => ctx_app1 (plugC C1 C) e2
  | ctx_app2  v1 C2  => ctx_app2 v1 (plugC C2 C)
  | ctx_tabs_free K C1   => ctx_tabs_free K (plugC C1 (shift_tc C))
  | ctx_tabs_capture X K C1   => ctx_tabs_capture X K (plugC C1 (close_tc (shift_tc C) X))
  | ctx_tapp C1 V   => ctx_tapp (plugC C1 C) V
  | ctx_apair1 C1 e2   => ctx_apair1 (plugC C1 C) e2
  | ctx_apair2 e1 C2  => ctx_apair2 e1 (plugC C2 C)
  | ctx_fst C1       => ctx_fst (plugC C1 C)
  | ctx_snd C1       => ctx_snd (plugC C1 C)
  end.

Fixpoint cbv_ctx (C : ctx)  {struct C} : Prop :=
  match C with
  | ctx_hole  => True
  | ctx_app1 C1 e2 => cbv_ctx C1 /\ expr e2
  | ctx_app2  v1 C2 => value v1 /\ cbv_ctx C2
  | ctx_tapp C1 V => cbv_ctx C1 /\ type V
  | ctx_fst C1 => cbv_ctx C1
  | ctx_snd C1 => cbv_ctx C1
  | _ => False
  end.

Fixpoint fv_tc (C : ctx) {struct C} : atoms :=
  match C with
  | ctx_hole  => {}
  | ctx_abs_free k V C1 => (fv_tt V) `union` fv_tc C1
  | ctx_abs_capture k x V C1 => (fv_tt V) `union` fv_tc C1
  | ctx_app1  C1 e2 => (fv_tc C1) `union` (fv_te e2)
  | ctx_app2  v1 C2 => (fv_te v1) `union` (fv_tc C2)
  | ctx_tabs_free k C1 => fv_tc C1
  | ctx_tabs_capture X k C1 => fv_tc C1
  | ctx_tapp C1 V => (fv_tc C1) `union` (fv_tt V)
  | ctx_apair1 C1 e2 => (fv_tc C1) `union` (fv_te e2)
  | ctx_apair2 e1 C2 => (fv_te e1) `union` (fv_tc C2)
  | ctx_fst C1 => (fv_tc C1)
  | ctx_snd C1 => (fv_tc C1)
  end.

Fixpoint remove_typvar (E:env) {struct E} : env :=
  match E with
  | nil => nil
  | (X, bind_kn K)::E' => (remove_typvar E')
  | (x, bind_typ T)::E' => (x, bind_typ T)::remove_typvar E'
  end.

Fixpoint ftv_env (E : env) : atoms :=
  match E with
  | nil => Metatheory.empty
  | pair X (bind_kn K) :: l => (ftv_env l)
  | pair x (bind_typ T) :: l => (fv_tt T) `union` (ftv_env l)
  end.

Fixpoint ftv_lenv (D : lenv) : atoms :=
  match D with
  | nil => Metatheory.empty
  | pair x (lbind_typ T) :: l => (union (fv_tt T) (ftv_lenv l))
  end.

Fixpoint remove_tmvar (E:env) {struct E} : env :=
  match E with
  | nil => nil
  | (X, bind_kn K)::E' => (X, bind_kn K)::(remove_tmvar E')
  | (x, bind_typ T)::E' => remove_tmvar E'
  end.

Definition env_remove b E := Coq.Lists.List.remove eq_binding_dec b E.
Definition lenv_remove b lE := Coq.Lists.List.remove eq_lbinding_dec b lE.
Fixpoint env_remove2 (x:atom) (E:env) {struct E}: env :=
  match E with
  | nil => nil
  | (y, b)::E' =>
    if (x == y )
    then env_remove2 x E'
    else (y,b)::env_remove2 x E'
   end.

Fixpoint cv_ec (C : ctx) {struct C} : atoms :=
  match C with
  | ctx_hole  => {}
  | ctx_abs_free k V C1 => cv_ec C1
  | ctx_abs_capture k x V C1 => {{x}} `union` cv_ec C1
  | ctx_app1  C1 e2 => (cv_ec C1)
  | ctx_app2  v1 C2 => (cv_ec C2)
  | ctx_tabs_free k C1 => cv_ec C1
  | ctx_tabs_capture X k C1 => {{X}} `union`  cv_ec C1
  | ctx_tapp C1 V => (cv_ec C1)
  | ctx_apair1 C1 e2 => (cv_ec C1)
  | ctx_apair2 e1 C2 => (cv_ec C2)
  | ctx_fst C1 => (cv_ec C1)
  | ctx_snd C1 => (cv_ec C1)
  end.

Fixpoint cv_tc (C : ctx) : atoms :=
  match C with
  | ctx_hole => Metatheory.empty
  | ctx_abs_free _  _ C1 => (cv_tc C1)
  | ctx_abs_capture _ x _ C1 => (cv_tc C1)
  | ctx_app1 C1 _ => cv_tc C1
  | ctx_app2 _ C2 => cv_tc C2
  | ctx_tabs_free _ C1 => (cv_tc C1)
  | ctx_tabs_capture X _ C1 => union (singleton X) (cv_tc C1)
  | ctx_tapp C1 _ => cv_tc C1
  | ctx_apair1 C1 _ => cv_tc C1
  | ctx_apair2 _ C2 => cv_tc C2
  | ctx_fst C1 => cv_tc C1
  | ctx_snd C1 => cv_tc C1
  end.

Fixpoint exp_size (e : exp) {struct e} : nat :=
  match e with
  | exp_bvar i => 1
  | exp_fvar x => 1
  | exp_abs T K e => 1 + exp_size e
  | exp_app e1 e2 => 1 + exp_size e1 + exp_size e2
  | exp_tabs K e => 1 + exp_size e
  | exp_tapp e T => 1 + exp_size e
  | exp_apair e1 e2 => 1 + exp_size e1 + exp_size e2
  | exp_fst e => 1 + exp_size e
  | exp_snd e => 1 + exp_size e
  end.

Fixpoint bexp_eupper (e : exp) {struct e} : nat :=
  match e with
  | exp_bvar i => i+1
  | exp_fvar x => 0
  | exp_abs K T e => bexp_eupper e - 1
  | exp_app e1 e2 => max (bexp_eupper e1) (bexp_eupper e2)
  | exp_tabs K e => bexp_eupper e
  | exp_tapp e T => bexp_eupper e
  | exp_apair e1 e2 => max (bexp_eupper e1) (bexp_eupper e2)
  | exp_fst e => bexp_eupper e
  | exp_snd e => bexp_eupper e
  end.

Fixpoint btyp_upper (t : typ) {struct t} : nat :=
  match t with
  | typ_bvar i => i+1
  | typ_fvar x => 0
  | typ_arrow k t1 t2 => max (btyp_upper t1) (btyp_upper t2)
  | typ_all K t => btyp_upper t - 1
  | typ_with t1 t2 => max (btyp_upper t1) (btyp_upper t2)
  end.

Fixpoint bexp_tupper (e : exp) {struct e} : nat :=
  match e with
  | exp_bvar i => 0
  | exp_fvar x => 0
  | exp_abs K T e => max (btyp_upper T) (bexp_tupper e)
  | exp_app e1 e2 => max (bexp_tupper e1) (bexp_tupper e2)
  | exp_tabs K e => bexp_tupper e - 1
  | exp_tapp e T => max (bexp_tupper e) (btyp_upper T)
  | exp_apair e1 e2 => max (bexp_tupper e1) (bexp_tupper e2)
  | exp_fst e => bexp_tupper e
  | exp_snd e => bexp_tupper e
  end.

Fixpoint fv_ec (C : ctx) {struct C} : atoms :=
  match C with
  | ctx_hole  => {}
  | ctx_abs_free k V C1 => fv_ec C1
  | ctx_abs_capture k x V C1 => fv_ec C1
  | ctx_app1  C1 e2 => (fv_ec C1) `union` (fv_ee e2)
  | ctx_app2  v1 C2 => (fv_ee v1) `union` (fv_ec C2)
  | ctx_tabs_free k C1 => fv_ec C1
  | ctx_tabs_capture X k C1 => fv_ec C1
  | ctx_tapp C1 V => (fv_ec C1)
  | ctx_apair1 C1 e2 => (fv_ec C1) `union` (fv_ee e2)
  | ctx_apair2 e1 C2 => (fv_ee e1) `union` (fv_ec C2)
  | ctx_fst C1 => (fv_ec C1)
  | ctx_snd C1 => (fv_ec C1)
  end.

Fixpoint subst_tc (Z : atom) (U : typ) (C : ctx) {struct C} : ctx :=
  match C with
  | ctx_hole => ctx_hole
  | ctx_abs_free K V C1 => ctx_abs_free K (subst_tt Z U V)  (subst_tc Z U C1)
  | ctx_abs_capture K x V C1 => ctx_abs_capture K x (subst_tt Z U V)  (subst_tc Z U C1)
  | ctx_app1 C1 e2 => ctx_app1  (subst_tc Z U C1) (subst_te Z U e2)
  | ctx_app2 v1 C2 => ctx_app2  (subst_te Z U v1) (subst_tc Z U C2)
  | ctx_tabs_free K C1 => ctx_tabs_free K  (subst_tc Z U C1)
  | ctx_tabs_capture x K C1 => ctx_tabs_capture x K  (subst_tc Z U C1)
  | ctx_tapp C1 V => ctx_tapp (subst_tc Z U C1) (subst_tt Z U V)
  | ctx_apair1 C1 e2 => ctx_apair1  (subst_tc Z U C1) (subst_te Z U e2)
  | ctx_apair2 e1 C2 => ctx_apair2  (subst_te Z U e1) (subst_tc Z U C2)
  | ctx_fst C1 => ctx_fst  (subst_tc Z U C1)
  | ctx_snd C1 => ctx_snd  (subst_tc Z U C1)
  end.

Fixpoint subst_ec (z : atom) (u : exp) (C : ctx) {struct C} : ctx :=
  match C with
  | ctx_hole => ctx_hole
  | ctx_abs_free K V C1 => ctx_abs_free K V (subst_ec z u C1)
  | ctx_abs_capture K x V C1 => ctx_abs_capture K x V (subst_ec z u C1)
  | ctx_app1 C1 e2 => ctx_app1 (subst_ec z u C1) (subst_ee z u e2)
  | ctx_app2 e1 C2 => ctx_app2 (subst_ee z u e1) (subst_ec z u C2)
  | ctx_tabs_free K C1 => ctx_tabs_free K (subst_ec z u C1)
  | ctx_tabs_capture x K C1 => ctx_tabs_capture x K (subst_ec z u C1)
  | ctx_tapp C1 V => ctx_tapp (subst_ec z u C1) V
  | ctx_apair1 C1 e2 => ctx_apair1 (subst_ec z u C1) (subst_ee z u e2)
  | ctx_apair2 e1 C2 => ctx_apair2 (subst_ee z u e1) (subst_ec z u C2)
  | ctx_fst C1 => ctx_fst (subst_ec z u C1)
  | ctx_snd C1 => ctx_snd (subst_ec z u C1)
  end.

Fixpoint apply_delta_subst_ctx (dsubst: delta_subst) (C:ctx) {struct dsubst} :=
  match dsubst with
  | nil => C
  | (X, T)::dsubst' => apply_delta_subst_ctx dsubst' (subst_tc X T C)
  end
  .

Fixpoint apply_gamma_subst_ctx (gsubst: gamma_subst) (C:ctx) {struct gsubst} :=
  match gsubst with
  | nil => C
  | (x, E)::gsubst' => apply_gamma_subst_ctx gsubst' (subst_ec x E C)
  end
  .

Fixpoint bctx_eupper (C : ctx) {struct C} : nat :=
  match C with
  | ctx_hole  => 0
  | ctx_abs_free k V C1 => bctx_eupper C1 - 1
  | ctx_abs_capture k x V C1 => bctx_eupper C1 - 1
  | ctx_app1  C1 e2 => max (bctx_eupper C1) (bexp_eupper e2)
  | ctx_app2  v1 C2 => max (bexp_eupper v1) (bctx_eupper C2)
  | ctx_tabs_free k C1 =>  bctx_eupper C1
  | ctx_tabs_capture X k C1 =>  bctx_eupper C1
  | ctx_tapp C1 V => bctx_eupper C1
  | ctx_apair1 C1 e2 => max (bctx_eupper C1) (bexp_eupper e2)
  | ctx_apair2 e1 C2 => max (bexp_eupper e1) (bctx_eupper C2)
  | ctx_fst C1 => bctx_eupper C1
  | ctx_snd C1 => bctx_eupper C1
  end.

Fixpoint bctx_tupper (C : ctx) {struct C} : nat :=
  match C with
  | ctx_hole  => 0
  | ctx_abs_free k V C1 =>max (btyp_upper V) (bctx_tupper C1)
  | ctx_abs_capture k x V C1 =>max (btyp_upper V) (bctx_tupper C1)
  | ctx_app1  C1 e2 => max (bctx_tupper C1) (bexp_tupper e2)
  | ctx_app2  v1 C2 => max (bexp_tupper v1) (bctx_tupper C2)
  | ctx_tabs_free k C1 =>  bctx_tupper C1 -1
  | ctx_tabs_capture X k C1 =>  bctx_tupper C1 -1
  | ctx_tapp C1 V => max (bctx_tupper C1) (btyp_upper V)
  | ctx_apair1 C1 e2 => max (bctx_tupper C1) (bexp_tupper e2)
  | ctx_apair2 e1 C2 => max (bexp_tupper e1) (bctx_tupper C2)
  | ctx_fst C1 => bctx_tupper C1
  | ctx_snd C1 => bctx_tupper C1
  end.

(*
  E lE t => C => E' lE' t'
*)
Inductive contexting : env -> lenv -> typ -> ctx -> env -> lenv -> typ -> Prop :=
  | contexting_hole : forall E D T K,
      wf_lenv E D ->
      wf_typ E T K ->
      contexting E D T ctx_hole E D T
  | contexting_abs_free : forall L K E D T T1' C1 T2' E' D',
      wf_typ E' T1' kn_nonlin ->
      (forall x : atom, x `notin` L->
        contexting E D T (open_ec C1 x) ([(x, bind_typ T1')] ++ E') D' T2') ->
      (K = kn_nonlin -> D' = lempty) ->
      contexting E D T (ctx_abs_free K T1' C1) E' D' (typ_arrow K T1' T2')
  | contexting_labs_free : forall L K E D T T1' C1 T2' E' D',
      wf_typ E' T1' kn_lin ->
      (forall x : atom, x `notin` L ->
        contexting E D T (open_ec C1 x) E' ([(x, lbind_typ T1')] ++ D') T2') ->
      (K = kn_nonlin -> D' = lempty) ->
      contexting E D T (ctx_abs_free K T1' C1) E' D' (typ_arrow K T1' T2')
  | contexting_abs_capture : forall K E D T y T1' C1 T2' E' D',
      wf_typ (env_remove (y, (bind_typ T1')) E') T1' kn_nonlin ->
      binds y (bind_typ T1') E' ->
      y `notin` dom D `union` cv_ec C1 ->
      contexting E D T C1 E' D' T2' ->
      (K = kn_nonlin -> D' = lempty) ->
      contexting E D T (ctx_abs_capture K y T1' (close_ec C1 y)) (env_remove (y, (bind_typ T1')) E') D' (typ_arrow K T1' T2')
  | contexting_labs_capture : forall K E D T y T1' C1 T2' E' D',
      wf_typ E' T1' kn_lin ->
      binds y (lbind_typ T1') D' ->
      y `notin` gdom_env E `union` cv_ec C1 ->
      contexting E D T C1 E' D' T2' ->
      (K = kn_nonlin -> lenv_remove (y, (lbind_typ T1')) D' = lempty) ->
      contexting E D T (ctx_abs_capture K y T1' (close_ec C1 y)) E' (lenv_remove (y, (lbind_typ T1')) D') (typ_arrow K T1' T2')
  | contexting_app1 : forall T1' K E D T E' D1' D2' D3' C1 e2 T2',
      contexting E D T C1 E' D1' (typ_arrow K T1' T2') ->
      typing E' D2' e2 T1' ->
      lenv_split E' D1' D2' D3' ->
      disjdom (fv_ee e2) (dom D) ->
      contexting E D T (ctx_app1 C1 e2) E' D3' T2'
  | contexting_app2 : forall T1' K E D T E' D1' D2' D3' e1 C2 T2',
      typing E' D1' e1 (typ_arrow K T1' T2') ->
      contexting E D T C2 E' D2' T1' ->
      lenv_split E' D1' D2' D3' ->
      disjdom (fv_ee e1) (dom D) ->
      contexting E D T (ctx_app2 e1 C2) E' D3' T2'
  | contexting_tabs_free : forall L E D T K C1 T1' E' D',
      (forall X : atom, X `notin` L -> vcontext (open_tc C1 X)) ->
      (forall X : atom, X `notin` L ->
        contexting E D T (open_tc C1 X) ([(X, bind_kn K)] ++ E') D' (open_tt T1' X)) ->
      contexting E D T (ctx_tabs_free K C1) E' D' (typ_all K T1')
  | contexting_tabs_capture : forall E D T Y K C1 T1' E' D',
      binds Y (bind_kn K) E' ->
      Y `notin` cv_ec C1 ->
      vcontext C1 ->
      contexting E D T C1 E' D' T1' ->
      wf_lenv (env_remove (Y, (bind_kn K)) E') D'  ->
      contexting E D T (ctx_tabs_capture Y K (close_tc C1 Y)) (env_remove (Y, (bind_kn K)) E') D' (typ_all K (close_tt T1' Y))
  | contexting_tapp : forall K E D T C1 T' T2' E' D',
      contexting E D T C1 E' D' (typ_all K T2') ->
      wf_typ E' T' K ->
      contexting E D T (ctx_tapp C1 T') E' D' (open_tt T2' T')
  | contexting_apair1 : forall E D T C1 e2 T1' T2' E' D',
      contexting E D T C1 E' D' T1' ->
      typing E' D' e2 T2' ->
      contexting E D T (ctx_apair1 C1 e2) E' D' (typ_with T1' T2')
  | contexting_apair2 : forall E D T e1 C2 T1' T2' E' D',
      typing E' D' e1 T1' ->
      contexting E D T C2 E' D' T2' ->
     contexting E D T (ctx_apair2 e1 C2) E' D' (typ_with T1' T2')
  | contexting_fst : forall E D T C1 T1' T2' E' D',
      contexting E D T C1 E' D' (typ_with T1' T2') ->
      contexting E D T (ctx_fst C1) E' D' T1'
  | contexting_snd : forall E D T C1 T1' T2' E' D',
      contexting E D T C1 E' D' (typ_with T1' T2') ->
      contexting E D T (ctx_snd C1) E' D' T2'
  .

Tactic Notation "contexting_cases" tactic(first) tactic(c) :=
  first;
  [ c "contexting_hole" |
     c "contexting_abs_free" | c "contexting_labs_free" |
     c "contexting_abs_capture" | c "contexting_labs_capture" |
     c "contexting_app1" | c "contexting_app2" |
    c "contexting_tabs_free" |  c "contexting_tabs_capture" |
     c "contexting_tapp" |
     c "contexting_apair1" | c "contexting_apair2" |
     c "contexting_fst" | c "contexting_snd" ].

Hint Resolve contexting_hole contexting_app1 contexting_app2 contexting_tapp contexting_apair1 contexting_apair2 contexting_fst contexting_snd.

Ltac gather_atoms :=
  let A := ltac_map (fun x : atoms => x) in
  let B := ltac_map (fun x : atom => singleton x) in
  let C := ltac_map (fun x : exp => fv_te x) in
  let D := ltac_map (fun x : exp => fv_ee x) in
  let E := ltac_map (fun x : typ => fv_tt x) in
  let F := ltac_map (fun x : env => dom x) in
  let G := ltac_map (fun x : env => fv_env x) in
  let H := ltac_map (fun x : lenv => dom x) in
  let I := ltac_map (fun x : lenv => fv_lenv x) in
  let J := ltac_map (fun x : ctx => cv_ec x) in
  let K := ltac_map (fun x : ctx => fv_ec x) in
  let L := ltac_map (fun x : ctx => fv_tc x) in
  simplify_list_of_atom_sets (A ++ B ++ C ++ D ++ E ++ F ++ G ++ H ++ I ++ J ++ K ++ L).

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

Lemma vcontext__context : forall C,
  vcontext C -> context C.
Proof.
  intros C H.
  induction H; auto.
Qed.

Lemma env_remove_notin : forall E x b,
  x `notin` dom E ->
  env_remove (x, b) E = E.
Proof.
  induction E; intros; simpl; auto.
    destruct a; simpl in H.
    destruct (eq_binding_dec (x, b) (a, b0)); simpl.
      inversion e; subst.
      destruct_notin.
      contradict NotInTac; auto.

      rewrite IHE; auto.
Qed.

Lemma env_remove2_notin : forall E x,
  x `notin` dom E ->
  env_remove2 x E = E.
Proof.
  induction E; intros; simpl; auto.
    destruct a; simpl in H.
    destruct (x == a); simpl.
      inversion e; subst.
      destruct_notin.
      contradict NotInTac; auto.

      rewrite IHE; auto.
Qed.

Lemma env_remove_inv : forall E y b,
  wf_env E ->
  binds y b E ->
  exists E1, exists E2,
    env_remove (y, b) E = E1 ++ E2 /\
    E = E1 ++ [(y, b)] ++ E2.
Proof.
  intros E y b Wfe.
  generalize dependent y.
  generalize dependent b.
  induction Wfe; intros; simpl.
    inversion H.

    destruct b.
      analyze_binds H0.
        inversion BindsTacVal; subst.
          destruct (eq_binding_dec (X, bind_kn K) (X, bind_kn K)).
            exists nil. exists E.
            split; simpl; auto.
               apply env_remove_notin; auto.

            contradict n; auto.

          destruct (eq_binding_dec (y, bind_kn k) (X, bind_kn K)).
            inversion e; subst.
            exists nil. exists E.
            split; simpl; auto.
               apply env_remove_notin; auto.

            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
            exists ((X, bind_kn K)::E1). exists E2.
            split; simpl; auto.
               simpl_env. rewrite EQ1. auto.

      analyze_binds H0.
        apply IHWfe in BindsTac.
        destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
        destruct (eq_binding_dec (y, bind_typ t) (X, bind_kn K)).
          inversion e.

          exists ((X, bind_kn K)::E1). exists E2.
          split; simpl; auto.
            simpl_env. rewrite EQ1. auto.

    destruct b.
      analyze_binds H1.
        apply IHWfe in BindsTac.
        destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
        destruct (eq_binding_dec (y, bind_kn k) (x, bind_typ T)).
          inversion e.

          exists ((x, bind_typ T)::E1). exists E2.
          split; simpl; auto.
            simpl_env. rewrite EQ1. auto.

      analyze_binds H1.
        inversion BindsTacVal; subst.
          destruct (eq_binding_dec (x, bind_typ T) (x, bind_typ T)).
            exists nil. exists E.
            split; simpl; auto.
               apply env_remove_notin; auto.

            contradict n; auto.

          destruct (eq_binding_dec (y, bind_typ t) (x, bind_typ T)).
            inversion e; subst.
            exists nil. exists E.
            split; simpl; auto.
               apply env_remove_notin; auto.

            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
            exists ((x, bind_typ T)::E1). exists E2.
            split; simpl; auto.
               simpl_env. rewrite EQ1. auto.
Qed.

Lemma env_remove2_inv : forall E y b,
  wf_env E ->
  binds y b E ->
  exists E1, exists E2,
    env_remove2 y E = E1 ++ E2 /\
    E = E1 ++ [(y, b)] ++ E2.
Proof.
  intros E y b Wfe.
  generalize dependent y.
  generalize dependent b.
  induction Wfe; intros; simpl.
    inversion H.

    destruct b.
      analyze_binds H0.
        inversion BindsTacVal; subst.
          destruct (X==X).
            exists nil. exists E.
            split; simpl; auto.
               apply env_remove2_notin; auto.

            contradict n; auto.

          destruct (y==X).
            inversion e; subst.
            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
            simpl_env in H. contradict H; auto.

            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
            exists ((X, bind_kn K)::E1). exists E2.
            split; simpl; auto.
               simpl_env. rewrite EQ1. auto.

      analyze_binds H0.
        apply IHWfe in BindsTac.
        destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
        destruct (y==X).
          subst.
          simpl_env in H.
          contradict H; auto.

          exists ((X, bind_kn K)::E1). exists E2.
          split; simpl; auto.
            simpl_env. rewrite EQ1. auto.

    destruct b.
      analyze_binds H1.
        apply IHWfe in BindsTac.
        destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
        destruct (y == x).
          subst.
          simpl_env in H0.
          contradict H0; auto.

          exists ((x, bind_typ T)::E1). exists E2.
          split; simpl; auto.
            simpl_env. rewrite EQ1. auto.

      analyze_binds H1.
        inversion BindsTacVal; subst.
          destruct (x == x).
            exists nil. exists E.
            split; simpl; auto.
               apply env_remove2_notin; auto.

            contradict n; auto.

          destruct (y == x).
            inversion e; subst.
            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
            simpl_env in H0. contradict H0; auto.

            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 EQ2]]]; subst.
            exists ((x, bind_typ T)::E1). exists E2.
            split; simpl; auto.
               simpl_env. rewrite EQ1. auto.
Qed.

Lemma max_injective : forall a1 a2 b1 b2,
  a1 <= b1 ->
  a2 <= b2 ->
  max a1 a2 <= max b1 b2.
Proof.
  intros a1 a2 b1 b2 a1_le_b1 a2_le_b2.
  destruct (le_lt_dec  b1 b2).
    rewrite max_r with (n:=b1) (m:=b2); auto.
    destruct (le_lt_dec a1 a2).
      rewrite max_r with (n:=a1) (m:=a2); auto.
      rewrite max_l with (n:=a1) (m:=a2); omega.

    rewrite max_l with (n:=b1) (m:=b2); try solve [omega].
    destruct (le_lt_dec a1 a2).
      rewrite max_r with (n:=a1) (m:=a2); omega.
      rewrite max_l with (n:=a1) (m:=a2); omega.
Qed.

Lemma wf_lenv_notin_dom : forall E D x T,
  wf_lenv E D ->
  binds x (lbind_typ T) D ->
  x `notin` dom E.
Proof.
  intros E D x T Wfle Binds.
  generalize dependent x.
  generalize dependent T.
  induction Wfle; intros; simpl.
    fsetdec.

    destruct (x==x0); subst; auto.
      analyze_binds Binds.
      apply IHWfle in BindsTac; auto.
Qed.

Lemma mid_list_inv' : forall A E1 x (b b': A) E2 E1' E2',
  uniq (E1++[(x,b)]++E2) ->
  E1++[(x,b)]++E2 = E1'++[(x,b')]++E2' ->
  (E1 = E1' /\ E2 = E2' /\ b = b').
Proof.
  intros A E1 x b b' E2 E1' E2' Uniq EQ.
  generalize dependent E1'.
  induction E1; intros.
    simpl_env in EQ.
    apply one_eq_app in EQ.
    destruct EQ as [[E1'' [EQ1 EQ2]]|[EQ1 EQ2]]; subst.
      simpl_env in Uniq.
      inversion Uniq; subst.
      simpl_env in H3.
      destruct_notin.
      contradict NotInTac; auto.

      simpl_env in EQ2.
      inversion EQ2; subst. auto.

    destruct a.
    simpl_env in EQ.
    apply one_eq_app in EQ.
    destruct EQ as [[E1'' [EQ1 EQ2]]|[EQ1 EQ2]]; subst.
      simpl_env in Uniq.
      inversion Uniq; subst.
      simpl_env in H1.
      apply IHE1 with (E1':=E1'') in H1; auto.
      destruct H1; subst. auto.

      simpl_env in EQ2.
      inversion EQ2; subst.
      simpl_env in Uniq.
      inversion Uniq; subst.
      simpl_env in H3.
      destruct_notin.
      contradict NotInTac; auto.
Qed.

Lemma app_mid_inv : forall A (E1 E2 F1 F2:list (atom*A)) x b,
  uniq (E1 ++ E2) ->
  E1 ++ E2 = F1 ++ [(x, b)] ++ F2 ->
  (exists D, E1 = F1 ++ [(x, b)] ++ D /\ F2 = D ++ E2) \/
  (exists D, F1 = E1 ++ D /\ E2 = D ++ [(x, b)] ++ F2).
Proof.
  intros A E1 E2 F1 F2 x b Uniq EQ.
  remember (E1++E2) as E.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent F1.
  generalize dependent F2.
  induction Uniq; intros; subst.
    symmetry in EQ.
    contradict EQ.
    simpl.
    apply app_cons_not_nil.

    assert (uniq (F1++[(x, b)]++F2)) as Uniq'.
      rewrite <- EQ. auto.
    assert (x `notin` dom F2) as xnF2.
      apply fresh_mid_tail in Uniq'; auto.
    apply one_eq_app in HeqE. destruct HeqE as [[E0' [eEQ1' eEQ2']] | [eEQ1' eEQ2']]; subst.
      apply one_eq_app in EQ. destruct EQ as [[F0' [fEQ1' fEQ2']] | [fEQ1' fEQ2']]; subst; auto.
        apply IHUniq with (F2:=F2) (F1:=F0') (E1:=E0') (E3:=E2) in fEQ2'; auto.
        destruct fEQ2' as [[D [dEQ1 dEQ2]] | [D [dEQ1 dEQ2]]]; subst.
          left. exists D. split; auto.
          right. exists D. split; auto.

        simpl_env in *.
        inversion fEQ2'; subst.
        left. exists E0'. split; auto.
      apply one_eq_app in EQ. destruct EQ as [[F0' [fEQ1' fEQ2']] | [fEQ1' fEQ2']]; subst; auto.
        right. exists ((x0,a)::F0'). split; auto.

        simpl_env in fEQ2'.
        inversion fEQ2'; subst.
         right. exists nil. split; auto.
Qed.

Lemma env_remove_sub : forall E y b,
  fv_env (env_remove (y, b) E) [<=] fv_env E.
Proof.
  induction E; intros y b; simpl.
    fsetdec.

    destruct a.
    destruct b0.
      destruct (eq_binding_dec (y,b)  (a, bind_kn k)); simpl.
        inversion e; subst.
        assert (J:=@IHE a (bind_kn k)).
        fsetdec.

        assert (J:=@IHE y b).
        fsetdec.

      destruct (eq_binding_dec (y,b)  (a, bind_typ t)); simpl.
        inversion e; subst.
        assert (J:=@IHE a (bind_typ t)).
        fsetdec.

        assert (J:=@IHE y b).
        fsetdec.
Qed.

Lemma env_remove2_sub : forall E y,
  fv_env (env_remove2 y E) [<=] fv_env E.
Proof.
  induction E; intros y; simpl.
    fsetdec.

    destruct a.
    destruct b.
      destruct (y == a); simpl.
        inversion e; subst.
        assert (J:=@IHE a).
        fsetdec.

        assert (J:=@IHE y).
        fsetdec.

      destruct (y == a); simpl.
        inversion e; subst.
        assert (J:=@IHE a).
        fsetdec.

        assert (J:=@IHE y).
        fsetdec.
Qed.

Lemma env_remove_ddom_sub : forall E y b,
  ddom_env (env_remove (y, b) E) [<=] ddom_env E.
Proof.
  induction E; intros y b; simpl.
    fsetdec.

    destruct a.
    destruct b0.
      destruct (eq_binding_dec (y,b)  (a, bind_kn k)); simpl.
        inversion e; subst.
        assert (J:=@IHE a (bind_kn k)).
        fsetdec.

        assert (J:=@IHE y b).
        fsetdec.

      destruct (eq_binding_dec (y,b)  (a, bind_typ t)); simpl.
        inversion e; subst.
        assert (J:=@IHE a (bind_typ t)).
        fsetdec.

        assert (J:=@IHE y b).
        fsetdec.
Qed.

Lemma env_remove2_ddom_sub : forall E y,
  ddom_env (env_remove2 y E) [<=] ddom_env E.
Proof.
  induction E; intros y b; simpl.
    fsetdec.

    destruct a.
    destruct b0.
      destruct (y == a); simpl.
        inversion e; subst.
        assert (J:=@IHE a).
        fsetdec.

        assert (J:=@IHE y).
        fsetdec.

      destruct (y == a); simpl.
        inversion e; subst.
        assert (J:=@IHE a).
        fsetdec.

        assert (J:=@IHE y).
        fsetdec.
Qed.

Lemma notin_fv_env : forall E y t,
  wf_env E ->
  binds y (bind_typ t) E ->
  y `notin` fv_env (env_remove (y, bind_typ t) E).
Proof.
  intros E y t Wfe Binds.
  generalize dependent y.
  generalize dependent t.
  induction Wfe; intros t y Binds; simpl.
    inversion Binds.

    analyze_binds_uniq Binds.
    destruct (eq_binding_dec (y, bind_typ t) (X, bind_kn K)); simpl.
      inversion e; subst.
      apply IHWfe in BindsTac. auto.

    analyze_binds Binds.
      inversion BindsTacVal; subst.
      destruct (eq_binding_dec (x, bind_typ T) (x, bind_typ T)); simpl.
        assert (J:=@env_remove_sub E x (bind_typ T)).
        assert (x `notin` fv_env E) as J'.
          apply wfe_dom_fv_env with (x:=x) in Wfe; auto.
        fsetdec.

        contradict n; auto.

      assert (y `notin` ddom_env E) as J.
        eapply notin_ddom_env; eauto.
      assert (y `notin` fv_tt T) as J'.
        apply dnotin_fv_wf with (X:=y) in H; auto.
      assert (y `in` dom E) as J''.
        apply binds_In in BindsTac; auto.
      apply IHWfe in BindsTac.
      destruct (eq_binding_dec (y, bind_typ t) (x, bind_typ T)); simpl.
        inversion e; subst.
        assert (J1:=@env_remove_sub E x (bind_typ T)).
        assert (x `notin` fv_env E) as J2.
          apply wfe_dom_fv_env with (x:=x) in Wfe; auto.
        fsetdec.

        destruct (y == x); subst.
          contradict H0; auto.
          fsetdec.
Qed.

Lemma notin_fv_env2 : forall E y t,
  wf_env E ->
  binds y (bind_typ t) E ->
  y `notin` fv_env (env_remove2 y E).
Proof.
  intros E y t Wfe Binds.
  generalize dependent y.
  generalize dependent t.
  induction Wfe; intros t y Binds; simpl.
    inversion Binds.

    analyze_binds_uniq Binds.
    destruct (y == X); simpl.
      inversion e; subst.
      simpl_env in H0. contradict H0; auto.

      apply IHWfe in BindsTac. auto.

    analyze_binds Binds.
      inversion BindsTacVal; subst.
      destruct (x == x); simpl.
        assert (J:=@env_remove2_sub E x).
        assert (x `notin` fv_env E) as J'.
          apply wfe_dom_fv_env with (x:=x) in Wfe; auto.
        fsetdec.

        contradict n; auto.

      assert (y `notin` ddom_env E) as J.
        eapply notin_ddom_env; eauto.
      assert (y `notin` fv_tt T) as J'.
        apply dnotin_fv_wf with (X:=y) in H; auto.
      assert (y `in` dom E) as J''.
        apply binds_In in BindsTac; auto.
      apply IHWfe in BindsTac.
      destruct (y == x); simpl.
        inversion e; subst.
        assert (J1:=@env_remove2_sub E x).
        assert (x `notin` fv_env E) as J2.
          apply wfe_dom_fv_env with (x:=x) in Wfe; auto.
        fsetdec.

        destruct (y == x); subst.
          contradict H0; auto.
          fsetdec.
Qed.

Lemma wft_fv_tt_dsub : forall E t K,
  wf_typ E t K ->
  fv_tt t [<=] ddom_env E.
Proof.
  intros E t K Wft.
  induction Wft; simpl.
    apply dbinds_In in H0. fsetdec.
    fsetdec.

    pick fresh X.
    assert (X `notin` L) as XnL. auto.
    apply H0 in XnL.
    assert (fv_tt T2 [<=] fv_tt (open_tt T2 X)) as sub.
      apply open_tt_fv_tt_lower; auto.
    assert (fv_tt T2 [<=] ddom_env ([(X, bind_kn K1)]++E)) as sub'.
      fsetdec.
    assert (AtomSetImpl.diff (fv_tt T2) {{X}} [<=] AtomSetImpl.diff (ddom_env ([(X, bind_kn K1)]++E)) {{X}}) as sub''.
      fsetdec.
    assert (AtomSetImpl.diff (fv_tt T2) {{X}}[=](fv_tt T2)) as eq.
      clear XnL sub sub' sub''. fsetdec.
    assert (X `notin` ddom_env E) as XnE.
      apply free_env__free_ddom; auto.
    assert (AtomSetImpl.diff (ddom_env ([(X, bind_kn K1)]++E)) {{X}}[=]ddom_env E) as eq'.
      clear - XnE. simpl_env. fsetdec.
    rewrite <- eq. rewrite <- eq'.
    assumption.

    fsetdec.

    assumption.
Qed.

Lemma env_remove_typ_inv : forall E y T,
  wf_env E ->
  binds y (bind_typ T) E ->
  exists E1, exists E2,
    env_remove (y, bind_typ T) E = E1 ++ E2 /\
    E = E1 ++ [(y, bind_typ T)] ++ E2 /\
    fv_tt T [<=] ddom_env E2.
Proof.
  intros E y T Wfe.
  generalize dependent y.
  generalize dependent T.
  induction Wfe; intros; simpl.
    inversion H.

    analyze_binds H0.
        apply IHWfe in BindsTac.
        destruct BindsTac as [E1 [E2 [EQ1 [EQ2 Fv]]]]; subst.
        destruct (eq_binding_dec (y, bind_typ T) (X, bind_kn K)).
          inversion e.

          exists ((X, bind_kn K)::E1). exists E2.
          split; simpl; auto.
            simpl_env. rewrite EQ1. auto.

    analyze_binds H1.
        inversion BindsTacVal; subst.
        destruct (eq_binding_dec (x, bind_typ T) (x, bind_typ T)).
            exists nil. exists E.
            split.
               apply env_remove_notin; auto.
            split; simpl; auto.
               eapply wft_fv_tt_dsub; eauto.

            contradict n; auto.

            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 [EQ2 Fv]]]]; subst.
            destruct (eq_binding_dec (y, bind_typ T0) (x, bind_typ T)).
              inversion e; subst.
              simpl_env in H0. destruct_notin.
              contradict NotInTac; auto.

              exists ((x, bind_typ T)::E1). exists E2.
              split.
                 simpl_env. rewrite EQ1. auto.
              split; simpl; auto.
Qed.

Lemma env_remove2_typ_inv : forall E y T,
  wf_env E ->
  binds y (bind_typ T) E ->
  exists E1, exists E2,
    env_remove2 y E = E1 ++ E2 /\
    E = E1 ++ [(y, bind_typ T)] ++ E2 /\
    fv_tt T [<=] ddom_env E2.
Proof.
  intros E y T Wfe.
  generalize dependent y.
  generalize dependent T.
  induction Wfe; intros; simpl.
    inversion H.

    analyze_binds H0.
        apply IHWfe in BindsTac.
        destruct BindsTac as [E1 [E2 [EQ1 [EQ2 Fv]]]]; subst.
        destruct (y == X).
          subst.
          simpl_env in H. contradict H; auto.

          exists ((X, bind_kn K)::E1). exists E2.
          split; simpl; auto.
            simpl_env. rewrite EQ1. auto.

    analyze_binds H1.
        inversion BindsTacVal; subst.
        destruct (x == x).
            exists nil. exists E.
            split.
               apply env_remove2_notin; auto.
            split; simpl; auto.
               eapply wft_fv_tt_dsub; eauto.

            contradict n; auto.

            apply IHWfe in BindsTac.
            destruct BindsTac as [E1 [E2 [EQ1 [EQ2 Fv]]]]; subst.
            destruct (y == x).
              inversion e; subst.
              simpl_env in H0. destruct_notin.
              contradict NotInTac; auto.

              exists ((x, bind_typ T)::E1). exists E2.
              split.
                 simpl_env. rewrite EQ1. auto.
              split; simpl; auto.
Qed.

Lemma lenv_remove_kind_notin : forall E x b,
  x `notin` dom E ->
  lenv_remove (x, b) E = E.
Proof.
  induction E; intros; simpl; auto.
    destruct a; simpl in H.
    destruct (eq_lbinding_dec (x, b) (a, l)); simpl.
      inversion e; subst.
      destruct_notin.
      contradict NotInTac; auto.

      rewrite IHE; auto.
Qed.

Lemma lenv_remove_inv : forall E lE y b,
  wf_lenv E lE ->
  binds y b lE ->
  exists lE1, exists lE2,
    lenv_remove (y, b) lE = lE1 ++ lE2 /\
    lE = lE1 ++ [(y, b)] ++ lE2.
Proof.
  intros E lE y b Wfle.
  generalize dependent y.
  generalize dependent b.
  induction Wfle; intros; simpl.
    inversion H0.

    destruct b.
    analyze_binds H2.
        inversion BindsTacVal; subst.
          destruct (eq_lbinding_dec (x, lbind_typ T) (x, lbind_typ T)).
            exists nil. exists D.
            split; simpl; auto.
               apply lenv_remove_kind_notin; auto.

            contradict n; auto.

          destruct (eq_lbinding_dec (y, lbind_typ t) (x, lbind_typ T)).
            inversion e; subst.
            exists nil. exists D.
            split; simpl; auto.
               apply lenv_remove_kind_notin; auto.

            apply IHWfle in BindsTac.
            destruct BindsTac as [lE1 [lE2 [EQ1 EQ2]]]; subst.
            exists ((x, lbind_typ T)::lE1). exists lE2.
            split; simpl; auto.
               simpl_env. rewrite EQ1. auto.
Qed.

Lemma gdom_dom__inv : forall A (sE : list (atom * A)) E x b t,
  gdom_env ([(x, bind_typ t)]++E) [=] dom ([(x, b)]++sE) ->
  x `notin` gdom_env E ->
  x `notin` dom sE ->
  gdom_env E [=] dom sE.
Proof.
  intros.
  simpl in *.
  fsetdec.
Qed.

Lemma free_env__free_gdom : forall x E,
  x `notin` fv_env E ->
  x `notin` gdom_env E.
Proof.
  induction E as [ | [x1 b1] E ]; simpl; intros H; auto.
  destruct b1; auto.
Qed.

Lemma wft_strengthen_sub : forall E F T K,
  wf_env (F++E) ->
  wf_typ (F++E) T K ->
  fv_tt T [<=] ddom_env E ->
  wf_typ E T K.
Proof.
  intros E F T K Hwfe Hwft Hsub.
  induction F; auto.
    simpl_env in Hwfe.
    destruct a. destruct b; simpl_env in Hwft.
      inversion Hwfe; subst.
      apply IHF; auto.
      assert (a `notin` ddom_env E) as J.
        simpl_env in H3.
        destruct_notin.
        apply dom__ddom; auto.
      rewrite_env (nil ++ [(a, bind_kn k)] ++ (F++E)) in Hwft.
      apply wf_typ_strengthening_typ in Hwft; auto.

      inversion Hwfe; subst.
      apply IHF; auto.
      apply wft_strengthen_ex in Hwft; auto.
Qed.

Lemma env_remove_opt : forall E1 x b E2,
  uniq (E1++[(x, b)]++E2) ->
  env_remove (x, b) (E1++[(x, b)]++E2) = E1 ++ E2.
Proof.
  intros E1 x b E2 Uniq.
  remember (E1++[(x, b)]++E2) as E.
  generalize dependent E1.
  induction Uniq; intros.
    simpl in HeqE.
    symmetry in HeqE.
    contradict HeqE.
    apply app_cons_not_nil.

    apply one_eq_app in HeqE.
    destruct HeqE as [[E'' [EQ1 EQ2]] | [EQ1 EQ2]]; subst.
      simpl.
      destruct (eq_binding_dec (x, b) (x0, a)).
         inversion e; subst.
         simpl_env in H.
         destruct_notin.
         contradict NotInTac1; auto.

         simpl_env.
         rewrite IHUniq with (E1:=E''); auto.

      simpl_env in EQ2.
      inversion EQ2; subst.
      simpl.
      destruct (eq_binding_dec (@pair atom binding x0 a) (@pair AtomSetImpl.elt binding x0 a)).
        apply env_remove_notin; auto.

        contradict n; auto.
Qed.

Lemma env_remove2_opt : forall E1 x b E2,
  uniq (E1++[(x, b)]++E2) ->
  env_remove2 x (E1++[(x, b)]++E2) = E1 ++ E2.
Proof.
  intros E1 x b E2 Uniq.
  remember (E1++[(x, b)]++E2) as E.
  generalize dependent E1.
  induction Uniq; intros.
    simpl in HeqE.
    symmetry in HeqE.
    contradict HeqE.
    apply app_cons_not_nil.

    apply one_eq_app in HeqE.
    destruct HeqE as [[E'' [EQ1 EQ2]] | [EQ1 EQ2]]; subst.
      simpl.
      destruct (x == x0).
         inversion e; subst.
         simpl_env in H.
         destruct_notin.
         contradict NotInTac1; auto.

         simpl_env.
         rewrite IHUniq with (E1:=E''); auto.

      simpl_env in EQ2.
      inversion EQ2; subst.
      simpl.
      destruct (@eq_dec atom _ x0 x0).
        apply env_remove2_notin; auto.

        contradict n; auto.
Qed.

Lemma lenv_remove_opt : forall E1 x b E2,
  uniq (E1++[(x, b)]++E2) ->
  lenv_remove (x, b) (E1++[(x, b)]++E2) = E1 ++ E2.
Proof.
  intros E1 x b E2 Uniq.
  remember (E1++[(x, b)]++E2) as E.
  generalize dependent E1.
  induction Uniq; intros.
    simpl in HeqE.
    symmetry in HeqE.
    contradict HeqE.
    apply app_cons_not_nil.

    apply one_eq_app in HeqE.
    destruct HeqE as [[E'' [EQ1 EQ2]] | [EQ1 EQ2]]; subst.
      simpl.
      destruct (eq_lbinding_dec (x, b) (x0, a)).
         inversion e; subst.
         simpl_env in H.
         destruct_notin.
         contradict NotInTac1; auto.

         simpl_env.
         rewrite IHUniq with (E1:=E''); auto.

      simpl_env in EQ2.
      inversion EQ2; subst.
      simpl.
      destruct (eq_lbinding_dec (@pair atom lbinding x0 a) (@pair AtomSetImpl.elt lbinding x0 a)).
        apply lenv_remove_kind_notin; auto.

        contradict n; auto.
Qed.

Lemma wf_env_notin_fv_env : forall E1 X K E2,
  wf_env (E1++[(X,bind_kn K)]++E2) ->
  wf_env (E1++E2) ->
  X `notin` fv_env E1 `union` fv_env E2.
Proof.
  intros E1 X K E2 Wfe Wfe'.
  remember (E1++[(X, bind_kn K)]++E2) as E.
  generalize dependent E1.
  induction Wfe; intros; subst.
    symmetry in HeqE.
    contradict HeqE.
    simpl.
    apply app_cons_not_nil.

    apply one_eq_app in HeqE. destruct HeqE as [[E0' [eEQ1' eEQ2']] | [eEQ1' eEQ2']]; subst; auto.
      simpl_env. simpl.
      apply uniq_from_wf_env in Wfe.
      assert (X `notin` dom (E0'++E2)) as XnE. solve_uniq.
      simpl_env in Wfe'.
      inversion Wfe'; subst.
      apply wfe_dom_fv_env with (x:=X) in Wfe'; auto.
      simpl_env in Wfe'; auto.

      simpl_env in eEQ2'.
      inversion eEQ2'; subst.
      apply wfe_dom_fv_env with (x:=X0) in Wfe; auto.

    apply one_eq_app in HeqE. destruct HeqE as [[E0' [eEQ1' eEQ2']] | [eEQ1' eEQ2']]; subst; auto.
      simpl_env. simpl.
      apply uniq_from_wf_env in Wfe.
      assert (X `notin` dom (E0'++E2)) as XnE. solve_uniq.
      simpl_env in Wfe'.
      inversion Wfe'; subst.
      apply wfe_dom_fv_env with (x:=X) in Wfe'; auto.
      simpl_env in Wfe'. simpl in Wfe'. auto.

      simpl_env in eEQ2'.
      inversion eEQ2'.
Qed.

Lemma wf_lenv_notin_fv_env : forall E1 X K E2 D,
  wf_lenv (E1++[(X,bind_kn K)]++E2) D ->
  wf_lenv (E1++E2) D ->
  X `notin` fv_env E1 `union` fv_env E2 `union` fv_lenv D.
Proof.
  intros E1 X K E2 D Wfle Wfle'.
  remember (E1++[(X, bind_kn K)]++E2) as E.
  generalize dependent E1.
  induction Wfle; intros; subst.
    apply wf_env_notin_fv_env with (E1:=E1) (E2:=E2) (X:=X) (K:=K) in H; auto.

    inversion Wfle'; subst.
    simpl_env. simpl.
    apply IHWfle in H5; auto.
    apply notin_fv_wf with (X:=X) in H9; auto.
Qed.

Lemma map_subst_tlb_id : forall G D Z P,
  wf_lenv G D ->
  Z `notin` dom G ->
  D = map (subst_tlb Z P) D.
Proof with auto.
  intros G D Z P H.
  (wf_lenv_cases (induction H) Case); simpl; intros Fr; simpl_env...
  Case "wf_lenv_typ".
    rewrite <- IHwf_lenv...
    rewrite <- subst_tt_fresh...
    eapply notin_fv_wf; eauto.
Qed.

Lemma map_subst_tb_id' : forall G G' Z P,
  wf_env (G++G') ->
  Z `notin` dom (G++G') ->
  G = map (subst_tb Z P) G.
Proof with auto.
  induction G; intros G' Z P H Fr...
    destruct a.
    destruct b; simpl; simpl_env.
      simpl_env in H. inversion H; subst.
      rewrite <- IHG with (G':=G'); auto.

      simpl_env in H. inversion H; subst.
      rewrite <- IHG with (G':=G'); auto.
      rewrite <- subst_tt_fresh...
      eapply notin_fv_wf; eauto.
Qed.

Lemma subst_tt_eq__inv : forall T (X Y:atom) t,
  Y `notin` fv_tt t `union` fv_tt T ->
  subst_tt X Y T = subst_tt X Y t ->
  T = t.
Proof.
  induction T; intros X Y t Yn EQ; simpl in EQ.
    destruct t; simpl in EQ; try solve [inversion EQ | auto].
      destruct (a==X); subst; auto.
        inversion EQ.

    destruct (a==X); subst; auto.
      destruct t; simpl in EQ; try solve [inversion EQ | auto].
        destruct (a==X); subst; auto.
          simpl in Yn.
          injection EQ. intros.
          contradict Yn; auto.
      destruct t; simpl in EQ; try solve [inversion EQ | auto].
        destruct (a0==X); subst; auto.
          simpl in Yn.
          injection EQ. intros.
          contradict Yn; auto.

    destruct t; simpl in EQ; try solve [inversion EQ | auto].
      destruct (a==X); subst; try solve [inversion EQ | auto].

      simpl in Yn.
      inversion EQ; subst.
      apply IHT1 in H1; auto.
      apply IHT2 in H2; auto.
      subst. auto.

    destruct t; simpl in EQ; try solve [inversion EQ | auto].
      destruct (a==X); subst; try solve [inversion EQ | auto].

      simpl in Yn.
      inversion EQ; subst.
      apply IHT in H1; auto.
      subst. auto.

    destruct t; simpl in EQ; try solve [inversion EQ | auto].
      destruct (a==X); subst; try solve [inversion EQ | auto].

      simpl in Yn.
      inversion EQ; subst.
      apply IHT1 in H0; auto.
      apply IHT2 in H1; auto.
      subst. auto.
Qed.

Lemma map_lenv_remove : forall D y T X Y,
  uniq D ->
  Y `notin` fv_lenv D `union` fv_tt T ->
  map (subst_tlb X Y) (lenv_remove (y, lbind_typ T) D) =
    lenv_remove (y, lbind_typ (subst_tt X Y T)) (map (subst_tlb X Y) D).
Proof.
  intros D y T X Y Uniq YnD.
  induction Uniq; intros; simpl; auto.
    destruct a.
    destruct (eq_lbinding_dec (y, lbind_typ T) (x, lbind_typ t)).
      inversion e; subst.
      simpl.
      destruct (eq_lbinding_dec (@pair atom lbinding x (lbind_typ (subst_tt X Y t))) (@pair atom lbinding x (lbind_typ (subst_tt X Y t)))).
        simpl_env in YnD.
        rewrite IHUniq; auto.

        contradict n; auto.

      simpl.
      destruct (eq_lbinding_dec (@pair atom lbinding y (lbind_typ (subst_tt X Y T))) (@pair atom lbinding x (lbind_typ (subst_tt X Y t)))).
        inversion e; subst.
        simpl_env in YnD. simpl in YnD.
        apply subst_tt_eq__inv in H2; auto.
        subst.
        contradict n; auto.

        simpl_env in YnD.
        simpl_env.
        rewrite IHUniq; auto.
Qed.

Lemma gdom_map : forall E X Y,
  gdom_env (map (subst_tb X Y) E) [=] gdom_env E.
Proof.
  intros.
  induction E as [ | [? ?] ]; simpl.
    fsetdec.

    destruct b; auto.
    simpl. fsetdec.
Qed.

Lemma subst_tt_id : forall T X,
  subst_tt X X T = T.
Proof.
  induction T; intros X; simpl; auto.
    destruct (a==X); subst; auto.

    rewrite IHT1. rewrite IHT2. auto.

    rewrite IHT. auto.

    rewrite IHT1. rewrite IHT2. auto.
Qed.

Lemma subst_tb_id : forall E X,
  map (subst_tb X X) E = E.
Proof.
  induction E; intros X; simpl; auto.
    destruct a.
    destruct b; simpl.
      rewrite IHE; auto.

      rewrite IHE.
      rewrite subst_tt_id; auto.
Qed.

Lemma dom_dom__inv : forall A B (E : list (atom * A)) (E' : list (atom * B)) x b b',
  dom ([(x, b)]++E) [=] dom ([(x, b')]++E') ->
  x `notin` dom E ->
  x `notin` dom E' ->
  dom E [=] dom E'.
Proof.
  intros.
  simpl in *.
  fsetdec.
Qed.

Lemma empty_typing_disjdom : forall e t D,
  typing nil nil e t ->
  disjdom (fv_ee e) D.
Proof.
  intros e t0 D Htyp.
  split; intros x Fx.
    apply notin_fv_ee_typing with (y:=x) in Htyp; auto.
    apply notin_fv_ee_typing with (y:=x) in Htyp; auto.
Qed.

Lemma empty_typing_disjdom' : forall e t D,
  typing nil nil e t ->
  disjdom (fv_te e) D.
Proof.
  intros e t0 D Htyp.
  split; intros x Fx.
    apply notin_fv_te_typing with (X:=x) in Htyp; auto.
    apply notin_fv_te_typing with (X:=x) in Htyp; auto.
Qed.

Definition Two := (typ_all kn_nonlin (typ_arrow kn_nonlin (typ_bvar 0) (typ_arrow kn_nonlin (typ_bvar 0) (typ_bvar 0)))).
Definition tt := (exp_tabs kn_nonlin (exp_abs kn_nonlin (typ_bvar 0) (exp_abs kn_nonlin (typ_bvar 0) (exp_bvar 1)))).
Definition ff := (exp_tabs kn_nonlin (exp_abs kn_nonlin (typ_bvar 0) (exp_abs kn_nonlin (typ_bvar 0) (exp_bvar 0)))).

Definition Kleene_eq e e' : Prop :=
  typing nil nil e Two /\
  typing nil nil e' Two /\
  ((normalize e tt /\ normalize e' tt)
    \/
    (normalize e ff /\ normalize e' ff)).

Lemma notin_wf_env : forall E x,
  wf_env E ->
  x `notin` dom E ->
  x `notin` fv_env E.
Proof.
  intros E x Hwfe Xnotin.
  induction Hwfe; auto.
    simpl_env in Xnotin. simpl. auto.

    simpl_env in Xnotin. simpl.
    apply notin_fv_wf with (X:=x) in H; auto.
Qed.

Definition F_observational_eq E lE e e' t : Prop :=
  typing E lE e t /\
  typing E lE e' t /\
  forall C,
   contexting E lE t C nil nil Two ->
   Kleene_eq (plug C e) (plug C e').

Lemma plug_vcontext__value : forall C e,
  vcontext C ->
  expr (plug C e) ->
  value (plug C e).
Proof.
  intros C e VC.
  induction VC; simpl; intros; auto.
    inversion H0; auto.
    inversion H0; auto.
Qed.

Lemma bind_kn__in_ddom : forall E X K,
  binds X (bind_kn K) E ->
  X `in` ddom_env E.
Proof.
  induction E; intros X K Binds.
    inversion Binds.
    destruct a. destruct b; simpl.
       analyze_binds Binds. eauto.
       analyze_binds Binds. eauto.
Qed.

Lemma fv_in_open_tt:  forall X t1 t2 k,
   X `in` fv_tt t1 ->
   X `in` fv_tt (open_tt_rec k t2 t1).
Proof.
  intros X. induction t1; intros t2 k1 IN; simpl in IN; simpl;
    try solve [fsetdec |
               apply IHt1; auto].
  assert ((X `in` fv_tt t1_1) \/ (X `in` fv_tt t1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (X `in` fv_tt (open_tt_rec k1 t2 t1_1)).
      apply IHt1_1; auto.
    fsetdec.
    assert (X `in` fv_tt (open_tt_rec k1 t2 t1_2)).
      apply IHt1_2; auto.
    fsetdec.

  assert ((X `in` fv_tt t1_1) \/ (X `in` fv_tt t1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (X `in` fv_tt (open_tt_rec k1 t2 t1_1)).
      apply IHt1_1; auto.
    fsetdec.
    assert (X `in` fv_tt (open_tt_rec k1 t2 t1_2)).
      apply IHt1_2; auto.
    fsetdec.
Qed.

Lemma in_fv_wf' : forall E (X : atom) T K,
  wf_typ E T K ->
  X `in` fv_tt T ->
  X `in` ddom_env E.
Proof.
  (wf_typ_cases (induction 1) Case); intros Fr; simpl in Fr; simpl...
  Case "wf_typ_var".
    apply bind_kn__in_ddom in H0.
    fsetdec.
  Case "wf_typ_arrow".
    assert (X `in` fv_tt T1 \/ X `in` fv_tt T2) as J. fsetdec.
    destruct J as [ J | J ]; auto.
  Case "wf_typ_all".
    pick fresh Y.
    assert (Y `notin` L) as YnL. auto.
    apply H0 in YnL.
      simpl in YnL.
      destruct_notin.
      clear Fr NotInTac0 NotInTac2 NotInTac3 .
      fsetdec.

      apply fv_in_open_tt; auto.
  Case "wf_typ_with".
    assert (X `in` fv_tt T1 \/ X `in` fv_tt T2) as J. fsetdec.
    destruct J as [ J | J ]; auto.
  Case "wf_typ_sub".
    eauto.
Qed.

Lemma fv_te_in_open_ee:  forall X e1 e2 k,
   X `in` fv_te e1 ->
   X `in` fv_te (open_ee_rec k e2 e1).
Proof.
  intros X. induction e1; intros e2 k1 IN; simpl in IN; simpl;
    try solve [fsetdec |
               apply IHe1; auto].
  assert ((X `in` fv_tt t) \/ (X `in` fv_te e1)) as H.
    fsetdec.
  destruct H as [H | H]; auto.

  assert ((X `in` fv_te e1_1) \/ (X `in` fv_te e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (X `in` fv_te (open_ee_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (X `in` fv_te (open_ee_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.

  assert ((X `in` fv_tt t) \/ (X `in` fv_te e1)) as H.
    fsetdec.
  destruct H as [H | H]; auto.

  assert ((X `in` fv_te e1_1) \/ (X `in` fv_te e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (X `in` fv_te (open_ee_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (X `in` fv_te (open_ee_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.
Qed.

Lemma fv_te_in_open_te:  forall X e1 t2 k,
   X `in` fv_te e1 ->
   X `in` fv_te (open_te_rec k t2 e1).
Proof.
  intros X. induction e1; intros t2 k1 IN; simpl in IN; simpl;
    try solve [fsetdec |
               apply IHe1; auto].
  assert ((X `in` fv_tt t) \/ (X `in` fv_te e1)) as H.
    fsetdec.
  destruct H as [H | H]; auto.
    apply fv_in_open_tt with (t2:=t2) (k:=k1) in H; auto.

  assert ((X `in` fv_te e1_1) \/ (X `in` fv_te e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (X `in` fv_te (open_te_rec k1 t2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (X `in` fv_te (open_te_rec k1 t2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.

  assert ((X `in` fv_tt t) \/ (X `in` fv_te e1)) as H.
    fsetdec.
  destruct H as [H | H]; auto.
    apply fv_in_open_tt with (t2:=t2) (k:=k1) in H; auto.

  assert ((X `in` fv_te e1_1) \/ (X `in` fv_te e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (X `in` fv_te (open_te_rec k1 t2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (X `in` fv_te (open_te_rec k1 t2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.
Qed.

Lemma in_fv_te_typing' : forall E lE T (X : atom) e,
  typing E lE e T ->
  X `in` fv_te e ->
  X `in` ddom_env E.
Proof with auto.
  (typing_cases (induction 1) Case); intros Fr; simpl in Fr; simpl...
  Case "typing_var".
    contradict Fr; auto.
  Case "typing_lvar".
    contradict Fr; auto.
  Case "typing_abs".
    pick fresh y.
    assert (y `notin` L) as ynL. auto.
    assert (X `in` fv_tt T1 \/ X `in` fv_te e1) as J. fsetdec.
    destruct J as [J | J].
      apply in_fv_wf' with (X:=X) in H; auto.

      apply H1 in ynL.
        simpl in ynL.
        destruct_notin.
        clear Fr NotInTac0 NotInTac2 NotInTac3 NotInTac4 NotInTac5 NotInTac6 NotInTac7 NotInTac8.
        fsetdec.

        apply fv_te_in_open_ee; auto.
  Case "typing_labs".
    pick fresh y.
    assert (y `notin` L) as ynL. auto.
    assert (X `in` fv_tt T1 \/ X `in` fv_te e1) as J. fsetdec.
    destruct J as [J | J].
      apply in_fv_wf' with (X:=X) in H; auto.

      apply H1 in ynL.
        simpl in ynL.
        destruct_notin.
        clear Fr NotInTac0 NotInTac2 NotInTac3 NotInTac4 NotInTac5 NotInTac6 NotInTac7 NotInTac8.
        fsetdec.

        apply fv_te_in_open_ee; auto.
  Case "typing_app".
    assert (dom D3 [=] dom D1 `union` dom D2) as EQ.
      apply dom_lenv_split in H1; auto.
    fsetdec.
  Case "typing_tabs".
    pick fresh y.
    assert (y `notin` L) as ynL. auto.
    apply H1 in ynL.
      simpl in ynL.
      destruct_notin.
      clear Fr NotInTac0 NotInTac2 NotInTac3 NotInTac4 NotInTac5 NotInTac6 NotInTac7.
      fsetdec.

      apply fv_te_in_open_te; auto.
  Case "typing_tapp".
    assert (X `in` fv_tt T \/ X `in` fv_te e1) as J. fsetdec.
    destruct J as [J | J]; auto.
      apply in_fv_wf' with (X:=X) in H0; auto.
  Case "typing_apair".
    assert (X `in` fv_te e1 \/ X `in` fv_te e2) as xine12. fsetdec.
    destruct xine12; auto.
Qed.

Lemma dbinds_In_inv : forall X E,
  X `in` (ddom_env E) ->
  exists K, binds X (bind_kn K) E.
Proof.
  induction E as [ | y b F IH ]; intros J.
    simpl_alist in J. fsetdec.
    simpl_alist in J. destruct y.  destruct b0; simpl in J.
      assert (X `in` {{a}} \/ X `in` ddom_env b) as J'. fsetdec.
      destruct J' as [J' | J'].
        exists k.
        destruct (X==a); subst; auto.
          contradict J'; auto.

        apply F in J'. destruct J' as [t' J'].
        exists t'. auto.

      apply F in J. destruct J as [k J].
      exists k. auto.
Qed.

Lemma empty_wft_disjdom : forall t k D,
  wf_typ nil t k ->
  disjdom (fv_tt t) D.
Proof.
  intros t0 k0 D Htyp.
  split; intros x Fx.
    apply notin_fv_wf with (X:=x) in Htyp; auto.
    apply notin_fv_wf with (X:=x) in Htyp; auto.
Qed.

Lemma subst_tt_tt : forall T (X Y:atom) t K,
  wf_typ nil t K ->
  Y `notin` fv_tt T ->
  subst_tt Y t (subst_tt X Y T) = subst_tt X t T.
Proof.
  induction T; intros X Y t K Wft Fv; simpl; auto.
    destruct (a == X); subst; simpl.
      destruct (Y == Y); subst; simpl; auto.
         contradict n; auto.
      destruct (a == Y); subst; simpl; auto.
         simpl in Fv.
         contradict Fv; auto.

    simpl in Fv.
    rewrite IHT1 with (K:=K); auto.
    rewrite IHT2 with (K:=K); auto.

    simpl in Fv.
    rewrite IHT with (K:=K); auto.

    simpl in Fv.
    rewrite IHT1 with (K:=K); auto.
    rewrite IHT2 with (K:=K); auto.
Qed.

Lemma env_remove_notin' : forall E x b,
  ~binds x b E ->
  env_remove (x, b) E = E.
Proof.
  induction E; intros; simpl; auto.
    destruct a; simpl in H.
    destruct (eq_binding_dec (x, b) (a, b0)); simpl.
      inversion e; subst.
      contradict H; auto.

      rewrite IHE; auto.
Qed.

Lemma env_remove2_inv' : forall E y,
  wf_env E ->
  y `in` dom E ->
  exists E1, exists E2, exists b,
    env_remove2 y E = E1 ++ E2 /\
    E = E1 ++ [(y, b)] ++ E2.
Proof.
  intros E y Wfe.
  generalize dependent y.
  induction Wfe; intros; simpl.
    contradict H; auto.

    assert (y `in` {{X}} \/ y `in` dom E) as yin.
      simpl_env in H0. fsetdec.
    destruct yin as [yin | yin].
      destruct (y==X).
        inversion e; subst.
        exists nil. exists E. exists (bind_kn K).
        split; auto.
        apply env_remove2_notin; auto.

        contradict yin; auto.
      destruct (y==X).
        inversion e; subst.
        contradict yin; auto.

        apply IHWfe in yin.
        destruct yin as [E1 [E2 [b [EQ1 EQ2]]]]; subst.
        exists ((X, bind_kn K)::E1). exists E2. exists b.
        split; simpl; auto.
          simpl_env. rewrite EQ1. auto.

    assert (y `in` {{x}} \/ y `in` dom E) as yin.
      simpl_env in H1. fsetdec.
    destruct yin as [yin | yin].
      destruct (y==x).
        inversion e; subst.
        exists nil. exists E. exists (bind_typ T).
        split; auto.
        apply env_remove2_notin; auto.

        contradict yin; auto.
      destruct (y==x).
        inversion e; subst.
        contradict yin; auto.

        apply IHWfe in yin.
        destruct yin as [E1 [E2 [b [EQ1 EQ2]]]]; subst.
        exists ((x, bind_typ T)::E1). exists E2. exists b.
        split; simpl; auto.
          simpl_env. rewrite EQ1. auto.
Qed.

Lemma env_remove2_dom_sub : forall E y,
  dom (env_remove2 y E) [<=] dom E.
Proof.
  induction E; intros y b; simpl.
    fsetdec.

    destruct a.
    destruct b0.
      destruct (y == a); simpl.
        inversion e; subst.
        assert (J:=@IHE a).
        fsetdec.

        assert (J:=@IHE y).
        fsetdec.

      destruct (y == a); simpl.
        inversion e; subst.
        assert (J:=@IHE a).
        fsetdec.

        assert (J:=@IHE y).
        fsetdec.
Qed.

Lemma remove_gdom__gdom_nil : forall E,
  gdom_env (remove_gdom E) [=] {}.
Proof.
  induction E; simpl; auto.
    destruct a.
    destruct b; simpl; auto.
Qed.

Lemma remove_gdom_sub : forall E X,
  X `notin` dom E ->
  X `notin` dom (remove_gdom E).
Proof.
  induction E; intros X Xn; simpl; auto.
  destruct a.
  destruct b;simpl; auto.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Floating-point format with gradual underflow *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_float_prop.
Require Import Fcore_FLX.
Require Import Fcore_FIX.
Require Import Fcore_rnd_ne.

Section RND_FLT.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

(* floating-point format with gradual underflow *)
Definition FLT_format (x : R) :=
  exists f : float beta,
  x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z /\ (emin <= Fexp f)%Z.

Definition FLT_exp e := Zmax (e - prec) emin.

(** Properties of the FLT format *)
Global Instance FLT_exp_valid : Valid_exp FLT_exp.
Proof.
intros k.
unfold FLT_exp.
generalize (prec_gt_0 prec).
repeat split ;
  intros ; zify ; omega.
Qed.

Theorem generic_format_FLT :
  forall x, FLT_format x -> generic_format beta FLT_exp x.
Proof.
clear prec_gt_0_.
intros x ((mx, ex), (H1, (H2, H3))).
simpl in H2, H3.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold canonic_exp, FLT_exp.
rewrite ln_beta_F2R with (1 := Zmx).
apply Zmax_lub with (2 := H3).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply ln_beta_le_Zpower.
Qed.

Theorem FLT_format_generic :
  forall x, generic_format beta FLT_exp x -> FLT_format x.
Proof.
intros x.
unfold generic_format.
set (ex := canonic_exp beta FLT_exp x).
set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)).
intros Hx.
rewrite Hx.
eexists ; repeat split ; simpl.
apply lt_Z2R.
rewrite Z2R_Zpower. 2: now apply Zlt_le_weak.
apply Rmult_lt_reg_r with (bpow ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
change (F2R (Float beta (Zabs mx) ex) < bpow (prec + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
unfold canonic_exp in ex.
destruct (ln_beta beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - prec <= ex)%Z. omega.
unfold ex, FLT_exp.
apply Zle_max_l.
apply Zle_max_r.
Qed.

Theorem FLT_format_satisfies_any :
  satisfies_any FLT_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLT_exp)).
intros x.
split.
apply FLT_format_generic.
apply generic_format_FLT.
Qed.

Theorem canonic_exp_FLT_FLX :
  forall x, x <> R0 ->
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  canonic_exp beta FLT_exp x = canonic_exp beta (FLX_exp prec) x.
Proof.
intros x Hx0 Hx.
unfold canonic_exp.
apply Zmax_left.
destruct (ln_beta beta x) as (ex, He).
unfold FLX_exp. simpl.
specialize (He Hx0).
cut (emin + prec - 1 < ex)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
Qed.

(** Links between FLT and FLX *)
Theorem generic_format_FLT_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  generic_format beta (FLX_exp prec) x ->
  generic_format beta FLT_exp x.
Proof.
intros x Hx H.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply generic_format_0.
unfold generic_format, scaled_mantissa.
now rewrite canonic_exp_FLT_FLX.
Qed.

Theorem generic_format_FLX_FLT :
  forall x : R,
  generic_format beta FLT_exp x -> generic_format beta (FLX_exp prec) x.
Proof.
clear prec_gt_0_.
intros x Hx.
unfold generic_format in Hx; rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
unfold canonic_exp, FLX_exp, FLT_exp.
apply Zle_max_l.
Qed.

Theorem round_FLT_FLX : forall rnd x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x.
intros rnd x Hx.
unfold round, scaled_mantissa.
rewrite canonic_exp_FLT_FLX ; trivial.
contradict Hx.
rewrite Hx, Rabs_R0.
apply Rlt_not_le.
apply bpow_gt_0.
Qed.

(** Links between FLT and FIX (underflow) *)
Theorem canonic_exp_FLT_FIX :
  forall x, x <> R0 ->
  (Rabs x < bpow (emin + prec))%R ->
  canonic_exp beta FLT_exp x = canonic_exp beta (FIX_exp emin) x.
Proof.
intros x Hx0 Hx.
unfold canonic_exp.
apply Zmax_right.
unfold FIX_exp.
destruct (ln_beta beta x) as (ex, Hex).
simpl.
cut (ex - 1 < emin + prec)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := Hx).
now apply Hex.
Qed.

Theorem generic_format_FIX_FLT :
  forall x : R,
  generic_format beta FLT_exp x ->
  generic_format beta (FIX_exp emin) x.
Proof.
clear prec_gt_0_.
intros x Hx.
rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
apply Zle_max_r.
Qed.

Theorem generic_format_FLT_FIX :
  forall x : R,
  (Rabs x <= bpow (emin + prec))%R ->
  generic_format beta (FIX_exp emin) x ->
  generic_format beta FLT_exp x.
Proof with auto with typeclass_instances.
clear prec_gt_0_.
apply generic_inclusion_le...
intros e He.
unfold FIX_exp.
apply Zmax_lub.
omega.
apply Zle_refl.
Qed.

(** FLT is a nice format: it has a monotone exponent... *)
Global Instance FLT_exp_monotone : Monotone_exp FLT_exp.
Proof.
intros ex ey.
unfold FLT_exp.
zify ; omega.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLT : Exists_NE beta FLT_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
intros e.
unfold FLT_exp.
destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ;
  rewrite H2 ; clear H2.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (e - prec + 1 - prec) emin).
omega.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (emin + 1 - prec) emin).
omega.
Qed.

End RND_FLT.


(**
  Really simply proof of Claim 5.5 from "The Joy of Cryptography" (p. 94).

  It is simple and easy to follow.
*)

From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Mon Require Import SPropBase.
From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb
  pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude.

From extructures Require Import ord fset fmap.

Import SPropNotations.

Import PackageNotation.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Set Equations With UIP.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Def.
Import Num.Theory.
Import Order.POrderTheory.

Section StretchPRG_example.

Definition tt := Datatypes.tt.

Variable (n: nat).

Definition Word_N: nat := 2^n.
Definition Word: choice_type := 'fin Word_N.

Notation " 'word " := (Word) (in custom pack_type at level 2).
Notation " 'word " := (Word) (at level 2): package_scope.

Context (PRG: Word -> Word * Word).

Definition query: nat := 0.

Definition mkpair {Lt Lf E}
  (t: package Lt [interface] E) (f: package Lf [interface] E):
  loc_GamePair E := fun b => if b then {locpackage t} else {locpackage f}.

Definition GEN_pkg_tt:
  package fset0 [interface]
    [interface #val #[query]: 'unit → 'word × 'word ] :=
  [package
    #def #[query] (_: 'unit): 'word × 'word {
      s <$ uniform Word_N ;;
      ret (PRG s)
    }
  ].

Definition GEN_pkg_ff:
  package fset0 [interface]
    [interface #val #[query]: 'unit → 'word × 'word ] :=
  [package
    #def #[query] (_: 'unit): 'word × 'word {
      x <$ uniform Word_N ;;
      y <$ uniform Word_N ;;
      ret (x, y)
    }
  ].

Definition GEN := mkpair GEN_pkg_tt GEN_pkg_ff.

Definition GEN_STRETCH_pkg_tt:
  package fset0 [interface]
    [interface #val #[query]: 'unit → 'word × 'word × 'word ] :=
  [package
    #def #[query] (_: 'unit): 'word × 'word × 'word {
      s <$ uniform Word_N ;;
      let (x, y) := PRG s in
      ret (x, PRG y)
    }
  ].

Definition GEN_STRETCH_pkg_ff:
  package fset0 [interface]
    [interface #val #[query]: 'unit → 'word × 'word × 'word ] :=
  [package
    #def #[query] (_: 'unit): 'word × 'word × 'word {
      x <$ uniform Word_N ;;
      u <$ uniform Word_N ;;
      v <$ uniform Word_N ;;
      ret (x, (u, v))
    }
  ].

Definition GEN_STRETCH := mkpair GEN_STRETCH_pkg_tt GEN_STRETCH_pkg_ff.

Definition GEN_STRETCH_HYB_pkg_1:
  package fset0
    [interface #val #[query]: 'unit → 'word × 'word ]
    [interface #val #[query]: 'unit → 'word × 'word × 'word ] :=
  [package
    #def #[query] (_: 'unit): 'word × 'word × 'word {
      #import {sig #[query]: 'unit → 'word × 'word } as query ;;
      '(x, y) ← query tt ;;
      ret (x, PRG y)
    }
  ].

Definition GEN_STRETCH_HYB_pkg_2:
  package fset0
    [interface #val #[query]: 'unit → 'word × 'word ]
    [interface #val #[query]: 'unit → 'word × 'word × 'word ] :=
  [package
    #def #[query] (_: 'unit): 'word × 'word × 'word {
      #import {sig #[query]: 'unit → 'word × 'word } as query ;;
      x <$ uniform Word_N ;;
      uv ← query tt ;;
      ret (x, uv)
    }
  ].

Lemma GEN_equiv_true:
  GEN_STRETCH true ≈₀ GEN_STRETCH_HYB_pkg_1 ∘ GEN true.
Proof.
  apply: eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  apply rpost_weaken_rule with eq;
    last by move=> [? ?] [? ?] [].
  simplify_linking.
  ssprove_code_simpl.
  by apply: rreflexivity_rule.
Qed.

Lemma GEN_HYB_equiv:
  GEN_STRETCH_HYB_pkg_1 ∘ GEN false ≈₀ GEN_STRETCH_HYB_pkg_2 ∘ GEN true.
Proof.
  apply: eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  apply rpost_weaken_rule with eq;
    last by move=> [? ?] [? ?] [].
  simplify_linking.
  by apply: rreflexivity_rule.
Qed.

Lemma GEN_equiv_false:
  GEN_STRETCH_HYB_pkg_2 ∘ GEN false ≈₀ GEN_STRETCH false.
Proof.
  apply: eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  apply rpost_weaken_rule with eq;
    last by move=> [? ?] [? ?] [].
  simplify_linking.
  by apply: rreflexivity_rule.
Qed.

Local Open Scope ring_scope.

(**
  The advantage an adversary can gain over the PRG, i.e. the chance by
  which an adversary can distinguish the PRG from truly random numbers.
  Negligible by assumption.
*)
Definition prg_epsilon := Advantage GEN.

Theorem security_based_on_prg LA A:
  ValidPackage LA
    [interface #val #[query]: 'unit → 'word × 'word × 'word ]
    A_export A ->
  Advantage GEN_STRETCH A <=
  prg_epsilon (A ∘ GEN_STRETCH_HYB_pkg_1) +
  prg_epsilon (A ∘ GEN_STRETCH_HYB_pkg_2).
Proof.
  move=> vA.
  rewrite Advantage_E Advantage_sym.
  ssprove triangle (GEN_STRETCH true) [::
    GEN_STRETCH_HYB_pkg_1 ∘ GEN true ;
    GEN_STRETCH_HYB_pkg_1 ∘ GEN false ;
    GEN_STRETCH_HYB_pkg_2 ∘ GEN true ;
    GEN_STRETCH_HYB_pkg_2 ∘ GEN false
  ] (GEN_STRETCH false) A
  as ineq.
  apply: le_trans.
  1: by apply: ineq.
  rewrite GEN_equiv_true ?fdisjointUr ?fdisjoints0 // GRing.add0r.
  rewrite GEN_HYB_equiv ?fdisjointUr ?fdisjoints0 // GRing.addr0.
  rewrite GEN_equiv_false ?fdisjointUr ?fdisjoints0 // GRing.addr0.
  by rewrite /prg_epsilon !Advantage_E -!Advantage_link !(Advantage_sym (GEN true)).
Qed.

End StretchPRG_example.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Common.CommonDefinitions.

Definition _ledgerCorrectPositive (l : Ledger) :=
    0 < MAX_MSG_PER_TR l /\
    0 < m_minStake l /\
    0 < now l /\
    0 < PROXY_FEE l /\
    0 < RET_OR_REINV_FEE l /\
    0 < m_participantRewardFraction l /\
    0 <= msgValue l /\
    0 < m_validatorAssurance l /\
    0 < ELECTOR_UNFREEZE_LAG l.

Definition _ledgerCorrectRoundsIds (l : Ledger) :=
    forall r, roundIn l r ->
    eval_state (RoundsBase_Ф_fetchRound (RoundsBase_ι_Round_ι_id r)) l = Some r.

Definition _ledgerCorrectNotTooLarge (l : Ledger) :=
    m_participantRewardFraction l <= 100.

Definition _ledgerCorrectBalance (l : Ledger) :=
    0 < m_balanceThreshold l /\
    m_balanceThreshold l <= balance l.

Definition ledgerCorrectLocally (l : Ledger) :=
    _ledgerCorrectPositive l /\
    _ledgerCorrectRoundsIds l /\
    _ledgerCorrectNotTooLarge l /\
    _ledgerCorrectBalance l.


Set Implicit Arguments.
Require Import List Lia.
From Undecidability.HOU Require Import std.std calculus.calculus unification.higher_order_unification unification.nth_order_unification.

Set Default Proof Using "Type".

(* * Enumerability *)

(* ** Terms, Types and Contexts *)
Section ListEnumerability.
  Variable (X: Const).

  Hypothesis (enumX: enumT X).

  Fixpoint L_exp (n: nat) : list (exp X) :=
    match n with
    | 0 => nil
    | S n => L_exp n
                  ++ [var x | x ∈ L_T nat n]
                  ++ [const c | c ∈ L_T X n]
                  ++ [lambda s | s ∈ L_exp n]
                  ++ [app s t | (s, t) ∈ (L_exp n × L_exp n)]
    end.

  Global Instance enumT_exp: enumT (exp X).
  Proof using enumX.
    exists L_exp.
    - eauto.
    - induction x as [y|c|s| s IH1 t IH2].
      + destruct (el_T y). exists (S x). cbn.
        in_app 2. now in_collect y.
      + destruct (el_T c). exists (S x). cbn.
        in_app 3. now in_collect c.
      + destruct IHs. exists (S x). cbn.
        in_app 4. now in_collect s.
      + destruct IH1 as [x1], IH2 as [x2]. exists (S (x1 + x2)). cbn.
        in_app 5. in_collect (s, t); eapply cum_ge'; eauto.
  Qed.

  Fixpoint L_type (n: nat) : list (type) :=
    match n with
    | 0 => nil
    | S n => L_type n
                   ++ [typevar x | x ∈ L_T nat n]
                   ++ [A → B | (A, B) ∈ (L_type n × L_type n)]
    end.

  Global Instance enumT_type: enumT type.
  Proof.
    exists L_type.
    - eauto.
    - induction x as [beta|A IH1 B IH2].
      + destruct (el_T beta). exists (S x). cbn.
        in_app 2. now in_collect beta.
      + destruct IH1 as [x1], IH2 as [x2]. exists (S (x1 + x2)). cbn.
        in_app 5. in_collect (A, B); eapply cum_ge'; eauto.
  Qed.

  (* ** Typing Proofs *)
  Fixpoint L_typingT Gamma s A n : list (Gamma ⊢ (s: exp X) : A) :=
    match n with
    | 0 => nil
    | S n => L_typingT Gamma s A n ++
                      match s as s return list (Gamma ⊢ s : A) with
                      | var i => [typingVar Gamma i H where H: nth Gamma i = Some A]
                      | const c => [cast (typingConst Gamma c) H where H : ctype X c = A]
                      | lambda s => match A with
                              | typevar beta => nil
                              | A → B => [ typingLam H | H ∈ L_typingT (A :: Gamma) s B n]
                              end
                      | app s t =>
                        [typingApp H1 H2 | (H1, H2) ∈ (L_typingT Gamma s (A1 → A) n × L_typingT Gamma t A1 n) & A1 ∈ L_T n]
                      end
    end.

  Scheme typing_strong_ind := Induction for typing Sort Prop.

  Global Instance enumT_typing Gamma (s: exp X) A: enumT (Gamma ⊢ s: A).
  Proof.
    exists (L_typingT Gamma s A).
    - eauto.
    - intros x.
      induction x using typing_strong_ind.
      + exists 1. cbn. destruct dec; intuition. in_app 1. f_equal.
        eapply Eqdep_dec.inj_pair2_eq_dec. eapply eq_dec. now destruct e, e0.
      + exists 1. cbn. destruct dec; intuition; cbn. left.
        unfold cast; rewrite <-Eqdep_dec.eq_rect_eq_dec; eauto. decide equality. decide equality.
      + edestruct IHx as [m]. exists (S m); cbn.
        in_app 2. now in_collect x.
      + edestruct IHx1 as [x1'], IHx2 as [x2'], (el_T A) as [x3'].
        exists (S (x1' + x2' + x3')); cbn; in_app 3.
        eapply in_flat_map. exists A. split.
        2: in_collect (x1, x2).
        all: eauto using cum_ge'.
  Qed.

  Fixpoint L_typing n : list (ctx * exp X * type) :=
    match n with
    | 0 => nil
    | S n =>
      L_typing n ++ [(Gamma, s, A) | (Gamma, s, A) ∈ (L_T n × L_T n × L_T n), |@L_T (Gamma ⊢ s : A) _ n| <> 0]
    end.

  Lemma enum_typing:
    enum (fun '(Gamma, s, A) => Gamma ⊢ (s: exp X) : A) L_typing.
  Proof with eauto using cum_ge'.
    split; eauto.
    intros [[Gamma s] A]; split.
    - intros H. destruct (el_T Gamma) as [x1], (el_T s) as [x2], (el_T A) as [x3], (el_T H) as [x4]. exists (S (x1+x2+x3+x4)); cbn.
      in_app 2. in_collect (Gamma, s, A).
      1 - 3: eapply cum_ge'; eauto; lia.
      eapply dec_decb. eapply cum_ge' with (m := x1 + x2 + x3 + x4) in H3; eauto.
      destruct (@L_T (Gamma ⊢ s : A) _ _); cbn; eauto.
    - intros [m H];  induction m in Gamma, s, A, H |-*; cbn in *. eauto.
      inv_collect; injection H; intros; subst.  eapply decb_dec in H1; intuition; subst.
      destruct (@L_T (Gamma ⊢ s : A) _ m); intuition.
  Qed.

  Fixpoint L_uni (n: nat) : list (uni X) :=
    match n with
    | 0 => nil
    | S n => L_uni n ++ flat_map (fun '(Gamma, s, t, A) => [@Build_uni _ Gamma s t A H1 H2 | (H1, H2) ∈ (L_T n × L_T n)])
                  [(Gamma, s, t, A) | (Gamma, s, t, A) ∈ (L_T n × L_T n × L_T n × L_T n)]
    end.

  Global Instance enumT_uni :
    enumT (uni X).
  Proof using enumX with eauto using cum_ge'.
    exists L_uni.
    - eauto.
    - intros [Gamma s t A H1 H2].
      destruct (el_T Gamma) as [x1], (el_T s) as [x2], (el_T t) as [x3], (el_T A) as [x4], (el_T H1) as [x5], (el_T H2) as [x6].
      exists (S (x1 + x2 + x3 + x4 + x5 + x6)); cbn. in_app 2.
      eapply in_flat_map. exists (Gamma, s, t, A). intuition.
      + in_collect (Gamma, s, t, A); eapply cum_ge'; eauto;lia.
      + in_collect (H1, H2)...
  Qed.

  Fixpoint L_subst (tau: fin -> exp X) (n: nat) :  list (ctx * (fin -> exp X) * ctx) :=
    match n with
    | 0 => nil
    | S n => L_subst tau  n
                    ++ [(Delta, tau, nil) | Delta ∈ L_T n]
                    ++ [(Delta, s .: sigma, A :: Gamma) | ((Delta, sigma, Gamma), (Delta', s, A)) ∈ (L_subst (S >> tau) n × L_typing n), Delta = Delta']
    end.

  (* ** Substitutions *)
  Lemma enum_substs tau:
    enum (fun '(Delta, sigma, Gamma) => Delta ⊩ (sigma: fin -> exp X) : Gamma /\ forall x, x >= | Gamma | -> sigma x = tau x) (L_subst tau).
  Proof.
    destruct enum_typing as [_ E'].
    split; eauto; intros [[Delta sigma] Gamma]; split.
    - intros [H1 H2].
      induction Gamma as [| A Gamma] in sigma, tau, H1, H2 |-*.
      + destruct (el_T Delta) as [x]; exists (S x); cbn.
        in_app 2. in_collect Delta; eauto. repeat f_equal. symmetry; fext; intros; eapply H2; cbn; lia.
      + specialize (IHGamma (S >> tau) (S >> sigma) ); mp IHGamma; [| mp IHGamma]; eauto.
        * intros ???. now eapply H1.
        * intros; unfold funcomp; eapply H2; cbn; lia.
        * assert (Delta ⊢ sigma 0 : A) by eauto.
          specialize (E' (Delta, sigma 0, A)); cbn in E'. eapply E' in H as [x1].
          destruct IHGamma as [x2]. exists (1 + x1 + x2); cbn.
          in_app 3. in_collect ((Delta, S >> sigma, Gamma), (Delta, sigma 0, A)); eauto using cum_ge'.
          repeat f_equal; fext; now intros [].
    - intros [m H]; induction m in tau, sigma, Gamma, H |-*; cbn in H; eauto.
      inv_collect; try injection H; intros; subst; eauto.
      1 - 2: eapply IHm in H; intuition.
      + intros []?; cbn; discriminate.
      + eapply decb_dec in H1; subst. eapply typingSubst_cons.
        eapply IHm; eauto. eapply (E' (c, e, t)). eauto.
      + eapply decb_dec in H2; subst. destruct x; cbn in H0; try lia; cbn.
        edestruct IHm as [_ ->]; eauto; lia.
  Qed.

  Definition Uextended '(I, Delta, sigma) :=
    Delta ⊩ sigma : @Gammaᵤ X I /\ sigma • sᵤ ≡ sigma • tᵤ /\ forall x, x >= |Gammaᵤ| -> sigma x = var x.

  Fixpoint L_Uextended (n: nat) : list (uni X * ctx * (fin -> exp X)) :=
    match n with
    | 0 => nil
    | S n => L_Uextended n ++ [(I, Delta, sigma) | (I, (Delta, sigma, Gamma)) ∈ (@L_T (uni X) _ n × L_subst var n ),
                                  Gamma = Gammaᵤ  /\ xi n (sigma • sᵤ) <> None /\ xi n (sigma • tᵤ) <> None /\ xi n (sigma • sᵤ) = xi n (sigma • tᵤ)]

    end.

  Lemma enum_unification' : enum Uextended L_Uextended.
  Proof.
    split; eauto.
    intros [[I Delta] sigma]. unfold Uextended; cbn; split.
    - intros (H3 & H4 & H5). destruct (el_T I) as [x1].
      destruct (enum_substs var) as [_ E].
      specialize (E (Delta, sigma, Gammaᵤ)); cbn in E; destruct E as [[x2 E] _]; [intuition|].
      assert ({ s' | (sigma • sᵤ) ▷ s' }) as [s' E1] by
            (eapply compute_evaluation_step, termination_steps, preservation_under_substitution; eauto using H1ᵤ).
      assert ({ t' | (sigma • tᵤ) ▷ t' }) as [t' E2] by
            (eapply compute_evaluation_step, termination_steps, preservation_under_substitution; eauto using H2ᵤ).
      eapply xi_correct in E1 as E1'; destruct E1' as [x3];
        eapply xi_correct in E2 as E2'; destruct E2' as [x4].
      exists (S (x1 + x2 + x3 + x4)); cbn. in_app 2.
      in_collect (I, (Delta, sigma, Gammaᵤ)).
      + eapply cum_ge'; eauto; lia.
      + eapply cum_ge'; eauto; lia.
      + eapply xi_monotone with (m := x1 + x2 + x3 + x4) in H0; [|lia].
        eapply xi_monotone with (m := x1 + x2 + x3 + x4) in H1; [|lia].
        eapply dec_decb; intuition; try congruence.
        rewrite H0, H1. f_equal. destruct E1, E2.
        rewrite H2, H7 in H4. eapply equiv_unique_normal_forms; eauto.
    - intros [m H]; induction m; cbn in H; eauto.
      eapply (inhabited_ind id).
      inv_collect; injection H; intros; subst.
      eapply decb_dec in H1. intuition; subst.
      destruct (enum_substs var) as [_ H'].
      specialize (H' (Delta, sigma, Gammaᵤ)) as [_ H']; cbn in H'.
      mp H'; eauto. eapply inhabits; intuition.
      destruct (xi m (sigma • sᵤ)) eqn: Hs; intuition.
      destruct (xi m (sigma • tᵤ)) eqn: Ht; intuition.
      injection H6 as <-.
      eapply equiv_huet_backward with (v1 := e) (v2 := e); eauto.
      all: eapply xi_correct; now (exists m).
  Qed.

End ListEnumerability.

(* ** Higher-Order Unification *)
Theorem enumerable_unification (X: Const): enumerable__T X -> enumerable (U X).
Proof.
  rewrite enum_enumT. intros [EX].
  eapply enumerable_iff with (P := fun I => exists Delta sigma, Uextended (I, Delta, sigma)).
  - intros [Gamma s t A ? ?]; unfold Uextended, U; cbn; split; intros [Delta [sigma []]].
    exists Delta; exists sigma; intuition.
    pose (tau x := if nth Gamma x then sigma x else var x). exists Delta; exists tau; intuition.
    unfold tau; intros ?? H'; rewrite H'; eauto.
    repeat rewrite subst_extensional with (sigma := tau) (tau := sigma); eauto.
    1 - 2: intros ? H'; assert (x ∈ dom Gamma) as H1 by eauto using typing_variables; unfold tau; now domin H1.
    unfold tau. now eapply nth_error_None in H1 as ->.
  - eapply projection with (p := fun x: uni X * ctx => exists sigma, let (I, Delta) := x in Uextended (I, Delta, sigma)).
    eapply projection with (p := @Uextended X).
    eapply enumerable_enum; exists (@L_Uextended X EX); eapply enum_unification'.
Qed.