(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(****************************************************************************)
(*                                                                          *)
(*  Proof of the three gap theorem.                                         *)
(*                                                                          *)
(*  Micaela Mayero (INRIA-Rocquencourt)                                     *)
(*  September 1998                                                          *)
(*                                                                          *)
(****************************************************************************)
(****************************************************************************)
(*                               preuve2.v                                  *)
(****************************************************************************)

(*********************************************************)
(*                 Intermediate proof 2                  *)
(*                                                       *)
(*********************************************************)

Require Export preuve1.
(*********************************************************)

Section Three.
Hypothesis alpha_irr : forall n p : Z, (alpha * IZR p)%R <> IZR n.
Hypothesis prop_alpha : (0 < alpha)%R /\ (alpha < 1)%R.
Hypothesis prop_N : forall N : nat, N >= 2.

(**********)
Lemma three_gap1 :
 forall N n : nat, 0 < n -> n < N - first N -> after N n = n + first N.
intros; generalize (inter31a alpha_irr prop_alpha prop_N N n); intros;
 generalize (eq_after_M_N1 alpha_irr prop_alpha prop_N N n H H0);
 intro; rewrite <- H2; cut (n < last (M N)).
intro;
 rewrite
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))); apply (H1 H H3).
generalize
 (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (first N + last N)));
 intro; generalize (le_lt_or_eq N (first N + last N) H3);
 intro; elim H4; intro.
cut (N - first N < last (M N)).
intro; apply (lt_trans n (N - first N) (last (M N)) H0 H6).
rewrite <-
 (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
    (refl_equal (first N + last N)));
 apply (lt_plus_minus N (first N) (last N) (first_N N (prop_N N)) H5).
rewrite <-
 (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
    (refl_equal (first N + last N))); cut (M N = first N + last N).
intro; rewrite <- H6 in H5; rewrite H5 in H0;
 rewrite <-
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))) in H0;
 rewrite (plus_minus (M N) (first N) (last N) H6);
 auto with arith real.
auto with arith real.
Qed.

(**********)
Lemma three_gap2 :
 forall N n : nat,
 N - first N <= n -> n < last N -> after N n = n + first N - last N.
intros; apply sym_equal;
 apply (tech_after alpha_irr N n (n + first N - last N)).
generalize (first_N N (prop_N N)); intro;
 generalize (lt_minus2 (first N) N H1); intro;
 apply (lt_le_trans 0 (N - first N) n H2 H).
generalize (last_N N (prop_N N)); intro; apply (lt_trans n (last N) N H0 H1).
auto with arith real.
generalize (plus_lt_compat_r n (last N) (first N) H0); intro;
 generalize (lt_reg_minus (n + first N) (last N + first N) (last N) H1);
 intro; rewrite (minus_plus (last N) (first N)) in H2;
 cut (last N <= n + first N).
intro;
 apply
  (lt_trans (n + first N - last N) (first N) N (H2 H3) (first_N N (prop_N N))).
clear H1 H2; generalize (le_minus_plus N (first N) n H); intro;
 apply (le_trans (last N) N (n + first N) (last_N01 N) H1).
apply (tech1 alpha_irr prop_alpha prop_N N n H H0).
generalize (tech_suc_M alpha_irr prop_alpha prop_N N n H H0);
 auto with arith real.
Qed.

(**********)
Lemma three_gap3 :
 forall N n : nat, last N <= n -> n < N -> after N n = n - last N.
intros; generalize (inter31b alpha_irr prop_alpha prop_N N n); intros;
 generalize (eq_after_M_N2 alpha_irr prop_alpha prop_N N n H H0);
 intro; rewrite <- H2; cut (n < M N).
intro;
 rewrite
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N)));
 rewrite
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))) in H; apply (H1 H H3).
generalize
 (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (first N + last N)));
 intro; unfold M in |- *; apply (lt_le_trans n N (first N + last N) H0 H3).
Qed.

End Three.


Require Import Classical.
(* Used in various places:
    - existence of a derivation in the axiomatic system for a sequent
      (should be decidable as Bi-Int is, but this would require extra work)
    - some set-theoretic arguments (maybe they can be constructivised *)

Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import BiInt_GHC.
Require Import BiInt_logics.
Require Import BiInt_extens_interactions.
Require Import wBIH_meta_interactions.
Require Import sBIH_meta_interactions.
Require Import BiInt_Kripke_sem.
Require Import BiInt_Lindenbaum_lem.

Definition CompNotDer (s: prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V))) : Prop :=
  (complete (fst s, snd s) /\ (wpair_derrec (fst s, snd s) -> False)).

Lemma clos_deriv : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) ->
                                (forall A, wBIH_rules (Γ, A) -> (In _ Γ A)).
Proof.
intros. destruct H. simpl in H. simpl in H1. pose (H A). destruct o.
auto. simpl in H2. exfalso. apply H1. exists [A]. repeat split.
apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H3. subst.
auto. inversion H4. simpl. apply MP with (ps:=[(Γ, Imp A (Or A (Bot V)));(Γ, A)]).
2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
apply RA2_I. exists A. exists (Bot V). auto. inversion H4. subst. 2: inversion H5.
assumption.
Qed.

Lemma primeness : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) ->
                                (forall A B, (In _ Γ (Or A B))  -> ((In _ Γ A) \/ (In _ Γ B))).
Proof.
intros. destruct H. simpl in H. simpl in H1. pose (H A). pose (H B).
destruct o ; destruct o0 ; auto. simpl in H2. simpl in H3. exfalso. apply H1.
destruct (eq_dec_form A B). subst. exists [B].
repeat split. apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H4.
subst. auto. inversion H5. simpl. apply MP with (ps:=[(Γ, Imp B (Or B (Bot V)));(Γ, B)]).
2: apply MPRule_I. intros. inversion H4. subst. apply Ax. apply AxRule_I.
apply RA2_I. exists B. exists (Bot V). auto. inversion H5. 2: inversion H6. subst.
apply MP with (ps:=[(Γ,(Or B B) → B);(Γ,(Or B B))]). 2: apply MPRule_I.
intros. inversion H6. subst.
apply MP with (ps:=[(Γ,(B → B) → (Or B B) → B);(Γ,(B → B))]). 2: apply MPRule_I.
intros. inversion H7. subst.
apply MP with (ps:=[(Γ,(B → B) → (B → B) → (Or B B) → B);(Γ,(B → B))]). 2: apply MPRule_I.
intros. inversion H8. subst. apply Ax. apply AxRule_I. apply RA4_I.
exists B. exists B. exists B. auto. inversion H9. 2: inversion H10.
subst. apply wimp_Id_gen. inversion H8. 2: inversion H9. subst. apply wimp_Id_gen.
inversion H7. subst. 2: inversion H8. apply Id. apply IdRule_I. auto.
exists (A :: [B]). repeat split. apply NoDup_cons. intro. inversion H4. auto.
inversion H5. apply NoDup_cons ; auto ; apply NoDup_nil. intros.
simpl. inversion H4. subst. auto. inversion H5. subst. auto. inversion H6.
simpl. apply MP with (ps:=[(Γ, Imp (Or A B) (Or A (Or B (Bot V))));(Γ, Or A B)]).
2: apply MPRule_I. intros. inversion H4. subst.
apply MP with (ps:=[(Γ,(B → Or A (Or B (Bot V))) → (Or A B → Or A (Or B (Bot V))));
(Γ, (B → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros. inversion H5. subst.
apply MP with (ps:=[(Γ,(A → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))) → (Or A B → Or A (Or B (Bot V))));
(Γ, (A → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros. inversion H6. subst.
apply Ax. apply AxRule_I. apply RA4_I. exists A. exists B. exists (Or A (Or B (Bot V))).
auto. inversion H7. subst. 2: inversion H8. apply Ax. apply AxRule_I.
apply RA2_I. exists A. exists (Or B (Bot V)). auto. inversion H6. 2: inversion H7.
subst.
apply MP with (ps:=[(Γ, ((Or B (Bot V)) → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))));
(Γ, ((Or B (Bot V)) → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros.
inversion H7. subst.
apply MP with (ps:=[(Γ, (B → (Or B (Bot V))) → ((Or B (Bot V)) → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))));
(Γ, (B → (Or B (Bot V))))]). 2: apply MPRule_I. intros.
inversion H8. subst. apply Ax. apply AxRule_I. apply RA1_I. exists B.
exists (Or B (Bot V)). exists (Or A (Or B (Bot V))). auto. inversion H9. subst.
2: inversion H10. apply Ax. apply AxRule_I. apply RA2_I. exists B. exists (Bot V). auto.
inversion H8. 2: inversion H9. subst. apply Ax. apply AxRule_I. apply RA3_I.
exists A. exists (Or B (Bot V)). auto. inversion H5. subst. 2: inversion H6.
apply Id. apply IdRule_I. auto.
Qed.

Lemma cp_Bot_R : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) -> (In _ Δ (Bot V)).
Proof.
intros. destruct H. simpl in H. simpl in H0. pose (H (Bot V)). destruct o ; auto.
simpl in H1. exfalso. apply H0. exists []. repeat split. apply NoDup_nil.
intros. inversion H2. simpl. apply Id. apply IdRule_I. auto.
Qed.

Definition Canon_worlds : Type :=
  {x : prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V)) | CompNotDer x}.

Definition Canon_rel (P0 P1 : Canon_worlds) : Prop :=
  Included _ (fst (proj1_sig P0)) (fst (proj1_sig P1)).

Definition Canon_val (P : Canon_worlds) (q : V) : Prop :=
  In _ (fst (proj1_sig P)) (# q).

Lemma C_R_refl u : Canon_rel u u.
Proof.
unfold Canon_rel. intro. auto.
Qed.

Lemma C_R_trans u v w: Canon_rel u v -> Canon_rel v w -> Canon_rel u w.
Proof.
intros. unfold Canon_rel.
intro. intros. unfold Canon_rel in H0. unfold Canon_rel in H.
apply H0. apply H. auto.
Qed.

Lemma C_val_persist : forall u v, Canon_rel u v -> forall p, Canon_val u p -> Canon_val v p.
Proof.
intros.
unfold Canon_val in H0. unfold Canon_rel in H.
unfold Canon_val. apply H. auto.
Qed.

Instance CM : model :=
      {|
        nodes := Canon_worlds ;
        reachable := Canon_rel ;
        val := Canon_val ;

        reach_refl := C_R_refl ;
        reach_tran := C_R_trans ;

        persist := C_val_persist;
      |}.

Lemma truth_lemma : forall A (cp : Canon_worlds),
  (wforces CM cp A) <-> (In _ (fst (proj1_sig cp)) A).
Proof.
induction A ; intro ; split ; intros ; destruct cp ; simpl ; try simpl in H ; auto.
(* Bot V *)
- inversion H.
- destruct x. simpl in H. unfold CompNotDer in c. destruct c. simpl in H1. apply H1.
  unfold wpair_derrec. simpl. exists []. repeat split. apply NoDup_nil. intros.
  inversion H2. simpl. apply Id. apply IdRule_I. auto.
(* Top V *)
- pose (classic (In (BPropF V) (fst x) (Top V))). destruct o. auto.
  exfalso. destruct x. simpl in H0. simpl in c. unfold CompNotDer in c.
  clear H. destruct c. simpl in H. simpl in H1. apply H1. unfold wpair_derrec.
  exists [Top V]. repeat split. apply NoDup_cons. auto. apply NoDup_nil.
  intros. inversion H2. subst. simpl. unfold complete in H. simpl in H. clear H2.
  pose (H (Top V)). destruct o. exfalso. apply H0. auto. auto. inversion H3.
  simpl. apply MP with (ps:=[(e, Imp (Top V) (Or (Top V) (Bot V))); (e, (Top V))]).
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA2_I.
  exists (Top V). exists (Bot V). auto. inversion H3. subst.
  apply MP with (ps:=[(e, Imp (Imp (Top V) (Top V)) (Top V)); (e, Imp (Top V) (Top V))]).
  intros. inversion H4. subst. apply Ax. apply AxRule_I. apply RA15_I.
  exists (Top V → Top V). auto. inversion H5. subst. apply wimp_Id_gen. inversion H6.
  apply MPRule_I. inversion H4. apply MPRule_I.
(* And A1 A2 *)
- destruct H. apply IHA1 in H. simpl in H. apply IHA2 in H0. simpl in H0.
  apply clos_deriv with (Δ:=snd x). auto.
  apply MP with (ps:=[(fst x, A1 → (And A1 A2));(fst x, A1)]).
  2: apply MPRule_I. intros. inversion H1. subst.
  apply MP with (ps:=[(fst x, (A1 → A2) → (A1 → (And A1 A2)));(fst x, (A1 → A2))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(fst x, (A1 → A1) → (A1 → A2) → (A1 → (And A1 A2)));(fst x, (A1 → A1))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
  apply RA7_I. exists A1. exists A1. exists A2. auto. inversion H4.
  subst. 2: inversion H5. apply wimp_Id_gen. inversion H3. subst. 2: inversion H4.
  apply MP with (ps:=[(fst x, A2 → (A1 → A2));(fst x, A2)]).
  2: apply MPRule_I. intros. inversion H4. subst. apply wThm_irrel.
  inversion H5. subst. 2: inversion H6. apply Id. apply IdRule_I. assumption.
  inversion H2. subst. apply Id. apply IdRule_I. assumption. inversion H3.
- split. apply IHA1. simpl. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp (And A1 A2) A1);(fst x, (And A1 A2))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA5_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
  apply IHA2. simpl. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp (And A1 A2) A2);(fst x, (And A1 A2))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA6_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
(* Or A1 A2 *)
- destruct H.
  apply IHA1 in H. simpl in H. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp A1 (Or A1 A2));(fst x, A1)]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA2_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
  apply IHA2 in H. simpl in H. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp A2 (Or A1 A2));(fst x, A2)]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA3_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
- apply primeness with (Δ:=snd x) in H ; auto. destruct H. left. apply IHA1 ; auto.
  right. apply IHA2 ; auto.
(* Imp A1 A2 *)
- destruct x. simpl. destruct (classic (In (BPropF V) e (A1 → A2))).
  auto. exfalso. unfold CompNotDer in c. simpl in c. destruct c.
  assert (wpair_derrec (Union _ e (Singleton _ A1), Singleton _ A2) -> False).
  intro. apply gen_wBIH_Deduction_Theorem in H1. apply H0.
  { apply clos_deriv with (Δ:=e0). unfold CompNotDer ; auto. destruct H1.
    destruct H1. destruct H2. destruct x. simpl in H3. simpl in H2.
    apply MP with (ps:=[(e, Imp (Bot V) (A1 → A2));(e, Bot V)]). 2: apply MPRule_I.
    intros. inversion H4. subst. apply wEFQ. inversion H5. 2: inversion H6. subst.
    assumption. inversion H1. subst. pose (H2 b). assert (List.In b (b :: x)). apply in_eq.
    apply s in H4. inversion H4. subst. destruct x. simpl in H3.
    apply absorp_Or1 in H3. auto. pose (H2 b). assert (List.In b (A1 → A2 :: b :: x)).
    apply in_cons. apply in_eq. apply s0 in H5. inversion H5. subst. inversion H1.
    subst. exfalso. apply H10. apply in_eq. }
  apply Lindenbaum_lemma in H1. destruct H1. destruct H1.
  destruct H1. destruct H2. destruct H3.
  assert (J1: complete (fst (x, x0), snd (x, x0)) /\ (wpair_derrec (fst (x, x0), snd (x, x0)) -> False)). auto.
  pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x,x0) J1).
  pose (H s).
  assert (J2: Canon_rel (exist (fun x : Ensemble (BPropF V) * Ensemble (BPropF V) =>
  CompNotDer x) (e, e0) (conj c f)) s). unfold Canon_rel. simpl.
  intro. intros. apply H1. apply Union_introl. auto. apply w in J2.
  apply IHA2 in J2. simpl in J2.
  apply H4. exists [A2]. repeat split. apply NoDup_cons. auto. apply NoDup_nil.
  intros. inversion H5. subst. simpl. apply H2. apply In_singleton. inversion H6.
  simpl. apply MP with (ps:=[(x, Imp A2 (Or A2 (Bot V)));(x, A2)]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2. exists (Bot V).
  auto. inversion H6. 2: inversion H7. subst. apply Id. apply IdRule_I. auto.
  apply IHA1. simpl. apply H1. apply Union_intror. apply In_singleton.
- intros. destruct x. simpl in H. destruct v. simpl. destruct x. simpl.
  apply IHA1 in H1. simpl in H1. unfold Canon_rel in H0. simpl in H0.
  apply H0 in H. unfold CompNotDer in c0. destruct c0. simpl in f. simpl in c0.
  apply IHA2. simpl.
  assert (wpair_derrec (e1, Singleton _ A2)). exists [A2]. repeat split.
  apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H2. subst. apply In_singleton.
  inversion H3. simpl.
  apply MP with (ps:=[(e1, Imp A2 (Or A2 (Bot V)));(e1, A2)]). 2: apply MPRule_I.
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2. exists (Bot V).
  auto. inversion H3. subst.
  apply MP with (ps:=[(e1, Imp A1 A2);(e1, A1)]). 2: apply MPRule_I.
  intros. inversion H4. subst. apply Id. apply IdRule_I. auto.
  inversion H5. 2: inversion H6. subst. apply Id. apply IdRule_I. auto.
  inversion H4.
  apply clos_deriv with (Δ:=e2). unfold CompNotDer ; auto. destruct H2. destruct H2.
  destruct H3. destruct x. simpl in H4. apply MP with (ps:=[(e1, Imp (Bot V) A2);(e1, Bot V)]).
  2: apply MPRule_I. intros. inversion H5. subst. apply wEFQ. inversion H6. 2: inversion H7.
  subst. auto. inversion H2. subst. pose (H3 b). assert (List.In b (b :: x)).
  apply in_eq. apply s in H5. inversion H5. subst. destruct x. simpl in H4.
  apply absorp_Or1 in H4. auto. exfalso. pose (H3 b0). assert (List.In b0 (b :: b0 :: x)).
  apply in_cons. apply in_eq. apply s0 in H6. inversion H6. subst. apply H7. apply in_eq.
(* Excl A1 A2 *)
- destruct H. destruct H. destruct H0. apply IHA1 in H0.
  assert (In (BPropF V) (fst (proj1_sig x0)) (Or A2 (Excl A1 A2))).
  apply clos_deriv with (Δ:=(snd (proj1_sig x0))). unfold CompNotDer ; auto.
  destruct x0. simpl. auto. destruct x0. simpl.
  apply MP with (ps:=[(fst x0, Imp A1 (Or A2 (Excl A1 A2)));(fst x0, A1)]). 2: apply MPRule_I.
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA11_I. exists A1.
  exists A2. auto. inversion H3. 2: inversion H4. subst. apply Id. apply IdRule_I.
  auto. apply primeness with (Δ:=snd (proj1_sig x0)) in H2. destruct H2 ; auto. exfalso.
  apply H1. apply IHA2 ; auto. destruct x0. simpl in H2. auto.
- assert (wpair_derrec ((Singleton _ A1), Union _ (snd x) (Singleton _ A2)) -> False).
  intro. destruct H0. destruct H0. destruct H1. simpl in H2. simpl in H1.
  destruct x. simpl in H. simpl in H1. destruct c. simpl in H3. simpl in H4.
  pose (remove_disj x0 A2 (Singleton (BPropF V) A1)).
  assert (wBIH_rules (Singleton (BPropF V) A1, Or A2 (list_disj (remove eq_dec_form A2 x0)))).
  apply MP with (ps:=[(Singleton (BPropF V) A1, list_disj x0 → Or A2
   (list_disj (remove eq_dec_form A2 x0)));(Singleton (BPropF V) A1, list_disj x0)]).
  2: apply MPRule_I. intros. inversion H5. subst. auto. inversion H6. subst.
  auto. inversion H7. clear w. clear H2.
  assert (Singleton (BPropF V) A1 = Union _ (Empty_set _) (Singleton (BPropF V) A1)).
  apply Extensionality_Ensembles. split. intro. intros. inversion H2. subst.
  apply Union_intror. apply In_singleton. intro. intros. inversion H2.
  subst. inversion H6. inversion H6. subst. apply In_singleton. rewrite H2 in H5.
  assert (J1: Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1) =
  Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1)). auto.
  assert (J2: Or A2 (list_disj (remove eq_dec_form A2 x0)) = Or A2 (list_disj (remove eq_dec_form A2 x0))). auto.
  pose (wBIH_Deduction_Theorem (Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1),
  Or A2 (list_disj (remove eq_dec_form A2 x0))) H5 A1 (Or A2 (list_disj (remove eq_dec_form A2 x0)))
  (Empty_set _) J1 J2). apply wdual_residuation in w. clear J2. clear J1. clear H2.
  clear H5.
  apply H4. exists (remove eq_dec_form A2 x0). repeat split. apply NoDup_remove.
  auto. intros. simpl. pose (H1 A). assert (List.In A x0). apply In_remove with (B:= A2).
  auto. apply u in H5. inversion H5. subst. auto. subst. inversion H6.
  subst. exfalso. apply remove_In in H2. auto. simpl.
  apply MP with (ps:=[(e, Excl A1 A2 → list_disj (remove eq_dec_form A2 x0));(e, Excl A1 A2)]).
  2: apply MPRule_I. intros. inversion H2. subst.
  pose (wBIH_monot (Empty_set (BPropF V), Excl A1 A2 → list_disj (remove eq_dec_form A2 x0))
  w e). apply w0. clear w0. simpl. intro. intros. inversion H5. inversion H5.
  subst. 2: inversion H6. clear H2. clear H5. apply Id. apply IdRule_I. auto.
  apply Lindenbaum_lemma in H0. destruct H0. destruct H0. destruct H0.
  destruct H1. destruct H2.
  assert (J1: CompNotDer (x0, x1)). unfold CompNotDer. auto.
  pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x0,x1) J1).
  exists s. unfold Canon_rel. simpl. split. destruct x. simpl.
  intro. intros. destruct c. simpl in H5. pose (H5 x). destruct o.
  simpl in H7. auto. simpl in H7. exfalso. pose (H1 x). simpl in i.
  assert (In (BPropF V) (Union (BPropF V) e0 (Singleton (BPropF V) A2)) x).
  apply Union_introl. auto. apply i in H8. apply H3. exists [x].
  repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
  intros. inversion H9. subst. simpl. auto. inversion H10.
  simpl. apply MP with (ps:=[(x0, Imp x (Or x (Bot V))); (x0, x)]).
  2: apply MPRule_I. intros. inversion H9. subst.
  apply Ax. apply AxRule_I. apply RA2_I. exists x. exists (Bot V). auto.
  inversion H10. 2: inversion H11. subst. apply Id. apply IdRule_I.
  auto. split. apply IHA1. simpl. apply H0. apply In_singleton.
  intro. apply IHA2 in H4. simpl in H4. apply H3. exists [A2].
  repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
  intros. inversion H5. subst. simpl. apply H1. apply Union_intror.
  apply In_singleton. inversion H6. simpl.
  apply MP with (ps:=[(x0, Imp A2 (Or A2 (Bot V)));(x0, A2)]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2.
  exists (Bot V). auto. inversion H6. 2: inversion H7. subst. clear H5.
  clear H6. apply Id. apply IdRule_I. auto.
Qed.

Theorem wCounterCompleteness : forall (Γ Δ : @Ensemble (BPropF V)),
    (wpair_derrec (Γ, Δ) -> False) -> ((loc_conseq Γ Δ) -> False).
Proof.
intros Γ Δ WD.
apply Lindenbaum_lemma in WD. destruct WD. destruct H. destruct H. destruct H0.
destruct H1. intro. unfold loc_conseq in H3.
assert (J1: complete (fst (x, x0), snd (x, x0)) /\ (wpair_derrec (fst (x, x0), snd (x, x0)) -> False)). auto.
pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x,x0) J1).
pose (H3 CM s).
assert ((forall A : BPropF V, In (BPropF V) Γ A -> wforces CM s A)). intros. apply truth_lemma. auto.
apply e in H4. destruct H4. destruct H4. apply truth_lemma in H5. simpl in H5.
apply H2. exists [x1]. repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
intros. inversion H6. simpl. subst. apply H0 ; auto. inversion H7. simpl.
apply MP with (ps:=[(x, Imp x1 (Or x1 (Bot V)));(x, x1)]). 2: apply MPRule_I.
intros. inversion H6. subst. apply Ax. apply AxRule_I. apply RA2_I. exists x1. exists (Bot V).
auto. inversion H7. subst. 2: inversion H8. apply Id. apply IdRule_I. auto.
Qed.

Theorem wCompleteness : forall (Γ Δ : @Ensemble (BPropF V)),
    (loc_conseq Γ Δ) -> wpair_derrec (Γ, Δ).
Proof.
intros Γ Δ LC. pose (wCounterCompleteness Γ Δ).
pose (classic (wpair_derrec (Γ, Δ))). destruct o. auto. exfalso.
apply f ; assumption.
Qed.


Require Export Metalib.Metatheory.
Require Export LibTactics.
Require Export SystemF_inf.
Require Export Fii_inf.
Require Export TypeSystems.

Coercion ty_var_b : nat >-> ty.
Coercion ty_var_f : typvar >-> ty.
Coercion exp_var_b : nat >-> exp.
Coercion exp_var_f : expvar >-> exp.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let C1 := gather_atoms_with (fun x : ctx => dom x) in
  let C2 := gather_atoms_with (fun x : tctx => dom x) in
  let C3 := gather_atoms_with (fun x : stctx => dom x) in
  let C4 := gather_atoms_with (fun x : sctx => dom x) in
  let D1 := gather_atoms_with (fun x => fv_ty_in_ty x) in
  let D2 := gather_atoms_with (fun x => fv_ty_in_exp x) in
  let D3 := gather_atoms_with (fun x => fv_exp_in_exp x) in
  let D4 := gather_atoms_with (fun x => fv_sty_in_sty x) in
  let D5 := gather_atoms_with (fun x => fv_sty_in_sexp x) in
  let D6 := gather_atoms_with (fun x => fv_sexp_in_sexp x) in
  constr:(A \u B \u C1 \u C2 \u C3 \u C4 \u D1 \u D2 \u D3 \u D4 \u D5 \u D6).

(* ********************************************************************** *)
(** * Notations *)

Notation "'|' A '|'" := (sty2ty A) (at level 60).

Notation "'∥' Γ '∥'" := (map sty2ty Γ) (at level 60).

Lemma trans_open_sty_rec : forall A B n,
    | open_sty_wrt_sty_rec n B A | = open_ty_wrt_ty_rec n (| B |) (| A |).
Proof with eauto.
  intros A.
  induction A; intros B m; simpls...

  destruct (lt_eq_lt_dec n m)...
  destruct s...

  rewrite IHA2.
  rewrite IHA1...

  rewrite IHA2.
  rewrite IHA1...

  rewrite IHA2...
Qed.

Lemma trans_open_sty : forall A B,
    | open_sty_wrt_sty B A | = open_ty_wrt_ty (| B |) (| A |).
Proof.
  intros.
  unfold open_sty_wrt_sty.
  unfold open_ty_wrt_ty.
  rewrite trans_open_sty_rec.
  reflexivity.
Qed.

Lemma trans_subst_sty : forall B A X,
    | subst_sty_in_sty A X B | = subst_ty_in_ty (| A |) X (| B |).
Proof with eauto.
  intros B.
  induction B; intros; simpls...
  case_if...

  rewrite IHB1...
  rewrite IHB2...

  rewrite IHB1...
  rewrite IHB2...

  rewrite IHB2...
Qed.

Lemma lc_sty_ty : forall A,
    lc_sty A -> lc_ty (| A |).
Proof with eauto.
  intros A H.
  induction H; simpls...

  pick fresh X.
  apply (lc_ty_all_exists X).
  unfold open_ty_wrt_ty.
  simpls...

  pick_fresh X.
  apply (lc_ty_all_exists X).
  asserts_rewrite (ty_var_f X = | sty_var_f X |)...
  rewrite <- trans_open_sty...
Qed.

Lemma notin_sty_ty : forall X A,
    X `notin` fv_sty_in_sty A -> X `notin` fv_ty_in_ty (| A |).
Proof with eauto.
  intros.
  induction A; simpls...
Qed.

(* ********************************************************************** *)
(** * Properties of monotype  *)

Hint Constructors mono.

Lemma sty_mono_or_not : forall A,
    lc_sty A ->
    mono A \/ ~mono A.
Proof with eauto.
  introv LC.
  induction LC; try solve [left; constructor].

  destruct IHLC1.
  destruct IHLC2.
  left; constructor...
  right.
  introv Bad.
  inverts Bad.
  tryfalse.
  destruct IHLC2.
  right.
  introv Bad.
  inverts Bad.
  tryfalse.
  right.
  introv Bad.
  inverts Bad.
  tryfalse.

  destruct IHLC1.
  destruct IHLC2.
  left; constructor...
  right.
  introv Bad.
  inverts Bad.
  tryfalse.
  destruct IHLC2.
  right.
  introv Bad.
  inverts Bad.
  tryfalse.
  right.
  introv Bad.
  inverts Bad.
  tryfalse.

  right.
  introv Bad.
  inverts Bad.

  destruct IHLC.
  left; constructor...
  right.
  introv Bad.
  inverts Bad.
  tryfalse.
Qed.

Lemma mono_lc : forall t,
    mono t -> lc_sty t.
Proof with eauto.
  induction 1...

Qed.

Lemma poly_lc : forall t,
    poly t -> lc_sty t.
Proof with eauto using mono_lc.
  induction 1...
Qed.

Lemma not_mono_arrow : forall A B,
    lc_sty A ->
    lc_sty B ->
    ~mono (sty_arrow A B) ->
    ~mono A \/ ~mono B.
Proof with eauto.
  introv HA HB H.
  apply sty_mono_or_not in HA.
  apply sty_mono_or_not in HB.
  destruct HA.
  destruct HB.
  false.
  apply H...
  right...
  destruct HB.
  left...
  left...
Qed.

Lemma not_mono_and : forall A B,
    lc_sty A ->
    lc_sty B ->
    ~mono (sty_and A B) ->
    ~mono A \/ ~mono B.
Proof with eauto.
  introv HA HB H.
  apply sty_mono_or_not in HA.
  apply sty_mono_or_not in HB.
  destruct HA.
  destruct HB.
  false.
  apply H...
  right...
  destruct HB.
  left...
  left...
Qed.

Lemma not_mono_is_poly : forall A,
    lc_sty A -> ~mono A -> poly A.
Proof with eauto.
  introv LC.
  induction LC; introv Mono; try solve [false; apply Mono; eauto]...

  - Case "arrow".
    apply not_mono_arrow in Mono...
    destruct Mono as [Mono1 | Mono2].
    forwards HB : sty_mono_or_not B...
    destruct HB as [HB1 | HB2].
    apply IHLC1 in Mono1...
    apply IHLC1 in Mono1...
    forwards HA : sty_mono_or_not A...
    destruct HA as [HA1 | HA2].
    apply IHLC2 in Mono2...
    apply IHLC1 in HA2...

  - Case "and".
    apply not_mono_and in Mono...
    destruct Mono as [Mono1 | Mono2].
    forwards HB : sty_mono_or_not B...
    destruct HB as [HB1 | HB2].
    apply IHLC1 in Mono1...
    apply IHLC1 in Mono1...
    forwards HA : sty_mono_or_not A...
    destruct HA as [HA1 | HA2].
    apply IHLC2 in Mono2...
    apply IHLC1 in HA2...

  - Case "record".
    constructor...

Qed.

Lemma subst_mono: forall x t t',
    mono t' ->
    mono t ->
    mono (subst_sty_in_sty t x t').
Proof with eauto.
  introv Mono.
  gen t x.
  induction Mono; introv M; simpls; try constructor...
  case_if...
Qed.

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

Lemma fv_sty_dom : forall D A,
    swft D A -> fv_sty_in_sty A [<=] dom D.
Proof.
  introv H.
  induction H; simpls; try fsetdec.

  apply binds_In in H.
  fsetdec.

  pick fresh X.
  assert (fv_sty_in_sty (open_sty_wrt_sty B (sty_var_f X)) [<=] add X (dom DD)) by eauto.
  assert (fv_sty_in_sty B [<=] fv_sty_in_sty (open_sty_wrt_sty B (sty_var_f X))) by eapply fv_sty_in_sty_open_sty_wrt_sty_lower.
  fsetdec.
Qed.

Lemma fv_sty_nil : forall A,
    swft nil A ->
    fv_sty_in_sty A [=] {}.
Proof.
  introv H.
  forwards~  : fv_sty_dom H.
  fsetdec.
Qed.

Lemma uniq_from_swfe : forall D E,
  swfe D E ->
  uniq E.
Proof with eauto.
  intros D E H; induction H...
Qed.

Lemma uniq_from_swfte : forall D,
  swfte D ->
  uniq D.
Proof with eauto.
  intros D H; induction H...
Qed.

Lemma uniq_from_swfte_push : forall X A D,
  swfte ([(X, A)] ++ D) ->
  uniq D.
Proof with eauto.
  introv WFTE; inversions WFTE. apply uniq_from_swfte...
Qed.

Lemma swft_type : forall E T,
  swft E T -> lc_sty T.
Proof.
  induction 1; eauto.
Qed.

Lemma swft_wft : forall Δ A,
    swft Δ A -> wft (map (const tt) Δ) (| A |).
Proof with eauto.
  introv H.
  induction H; simpls...

  pick fresh X and apply wft_all...
  unfold open_ty_wrt_ty.
  simpls...

  constructor...
  apply binds_map_2 with (f := const tt) (a := A)...

  pick fresh X and apply wft_all...
  asserts_rewrite (ty_var_f X = | sty_var_f X |)...
  rewrite <- trans_open_sty...
  apply (H1 X)...
Qed.

Lemma swft_wft_nil : forall A,
    swft nil A -> wft nil (| A |).
Proof with eauto.
  introv H.
  apply swft_wft in H.
  simpls...
Qed.

Lemma swfe_wfe : forall Δ Γ,
    uniq Δ ->
    swfe Δ Γ ->
    wfe (map (const tt) Δ) (∥ Γ ∥).
Proof with eauto using swft_wft.
  introv W H.
  induction H; simpls...

  constructor...
Qed.

Lemma swfe_notin : forall D G x A,
    swfe D G ->
    binds x A G ->
    x `notin` dom D.
Proof with eauto.
  induction 1; introv Bind; simpls...
  analyze_binds Bind...
Qed.

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

Lemma wft_weaken : forall T E F G,
  wft (G ++ E) T ->
  uniq (G ++ F ++ E) ->
  wft (G ++ F ++ E) T.
Proof with simpl_env; eauto.
  intros T E F G Hwf_typ Hk.
  remember (G ++ E) as F'.
  generalize dependent G.
  induction Hwf_typ; intros G Hok Heq; subst...
  Case "ty_all".
    pick fresh Y and apply wft_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma swft_weaken : forall T E F G,
  swft (G ++ E) T ->
  uniq (G ++ F ++ E) ->
  swft (G ++ F ++ E) T.
Proof with simpl_env; eauto.
  intros T E F G Hwf_typ Hk.
  remember (G ++ E) as F'.
  generalize dependent G.
  induction Hwf_typ; intros G Hok Heq; subst...
  Case "ty_all".
    pick fresh Y and apply swft_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma wft_weaken_head : forall T E F,
  wft E T ->
  uniq (F ++ E) ->
  wft (F ++ E) T.
Proof.
  intros.
  rewrite_env (nil ++ F++ E).
  auto using wft_weaken.
Qed.

Lemma swft_weaken_head : forall T E F,
  swft E T ->
  uniq (F ++ E) ->
  swft (F ++ E) T.
Proof.
  intros.
  rewrite_env (nil ++ F++ E).
  auto using swft_weaken.
Qed.

Lemma swft_from_swfte : forall Y A D,
    swfte D ->
    binds Y A D ->
    swft D A.
Proof with eauto using uniq_from_swfte.
  induction 1; intros J; analyze_binds J...
  eapply swft_weaken_head...
  apply IHswfte in BindsTac.
  eapply swft_weaken_head...
Qed.

Lemma wft_subst_tb : forall F E Z P T,
  wft (F ++ Z ~ tt ++ E) T ->
  wft E P ->
  uniq (F ++ E) ->
  wft (F ++ E) (subst_ty_in_ty P Z T).
Proof with simpl_env; eauto using wft_weaken_head, wft_type.
  intros F E Z P T WT WP.
  remember (F ++ Z ~ tt ++ E) as G.
  generalize dependent F.
  induction WT; intros F EQ Ok; subst; simpl subst_ty_in_ty...
  - Case "ty_var".
    case_if...
  - Case "ty_all".
    pick fresh Y and apply wft_all...
    rewrite subst_ty_in_ty_open_ty_wrt_ty_var...
    rewrite_env (([(Y, tt)] ++ F) ++ E).
    apply H0...
Qed.

Lemma swft_subst_tb : forall F E Z P T B,
  swft (F ++ Z ~ B ++ E) T ->
  swft E P ->
  uniq (map (subst_sty_in_sty P Z) F ++ E) ->
  swft (map (subst_sty_in_sty P Z) F ++ E) (subst_sty_in_sty P Z T).
Proof with simpl_env; eauto using swft_weaken_head, swft_type.
  intros F E Z P T B WT WP.
  remember (F ++ Z ~ B ++ E) as G.
  generalize dependent F.
  induction WT; intros F EQ Ok; subst; simpl subst_sty_in_sty...
  - Case "swft_var".
    case_if...
    analyze_binds H...
  - Case "swft_all".
    pick fresh Y and apply swft_all...
    rewrite subst_sty_in_sty_open_sty_wrt_sty_var...
    rewrite_env (map (subst_sty_in_sty P Z) (Y ~ A ++ F) ++ E).
    apply H0...
Qed.

Lemma swft_subst_sty : forall E Z P T B,
  swft ([(Z, B)] ++ E) T ->
  swft E P ->
  uniq E ->
  swft E (subst_sty_in_sty P Z T).
Proof.
  introv HY WTF UNI.
  rewrite_env (nil ++ Z ~ B ++ E) in HY.
  forwards I : swft_subst_tb HY WTF UNI.
  simpl_alist in I; auto.
Qed.

Lemma wft_open : forall E U T2,
  uniq E ->
  wft E (ty_all T2) ->
  wft E U ->
  wft E (open_ty_wrt_ty T2 U).
Proof with simpl_env; eauto.
  intros E U T2 Ok WA WU.
  inversion WA; subst.
  pick fresh X.
  rewrite (subst_ty_in_ty_intro X)...
  rewrite_env (nil ++ E).
  eapply wft_subst_tb...
Qed.

Lemma swft_open : forall E U T1 T2,
  uniq E ->
  swft E (sty_all T1 T2) ->
  swft E U ->
  swft E (open_sty_wrt_sty T2 U).
Proof with simpl_env; eauto.
  intros E U T1 T2 Ok WA WU.
  inversion WA; subst.
  pick fresh X.
  rewrite (subst_sty_in_sty_intro X)...
  rewrite_env (map (subst_sty_in_sty U X) nil ++ E).
  eapply swft_subst_tb...
Qed.

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

Lemma swft_tvar : forall D X A,
    swft D A ->
    X `notin` dom D ->
    X `notin` fv_sty_in_sty A.
Proof with eauto.
  introv H.
  gen X.
  induction H; introv W; simpls...
  lets : binds_In H.
  fsetdec.

  pick_fresh Y.

  forwards~ : H1 Y X.
  lets : IHswft W.
  lets : fv_sty_in_sty_open_sty_wrt_sty_lower B (sty_var_f Y).
  fsetdec.

Qed.

Lemma swfte_tvar : forall X A D,
    swfte D ->
    binds X A D ->
    X `notin` fv_sty_in_sty A.
Proof with eauto.
  introv H.
  gen X A.
  induction H; introv B.
  analyze_binds B.

  analyze_binds B.
  eapply swft_tvar...

Qed.

Inductive same_stctx {a b} : list (atom * a) -> list (atom * b) -> Prop :=
| same_empty : same_stctx nil nil
| same_cons : forall X A B s1 s2,
    same_stctx s1 s2 ->  same_stctx ([(X , A)] ++ s1) ([(X , B)] ++ s2).

Hint Constructors same_stctx.

Lemma same_stctx_dom : forall a b (ctxa : list (atom * a))  (ctxb : list (atom * b)),
    same_stctx ctxa ctxb ->
    dom ctxa [=] dom ctxb.
Proof with eauto; try fsetdec.
  induction 1; simpls...
Qed.

Lemma same_eq : forall a (s1 : list (atom * a)),
    same_stctx s1 s1.
Proof with eauto.
  alist induction s1...
Qed.

Lemma same_map : forall a b (s1 : list (atom * a)) (f : a -> b),
    same_stctx s1 (map f s1).
Proof with eauto; simpl_env.
  alist induction s1...
  intros.
  simpls...

  intros.
  simpls...
  constructor...
Qed.

Lemma same_sym : forall a b (s1 : list (atom * a)) (s2 : list (atom * b)),
    same_stctx s1 s2 -> same_stctx s2 s1.
Proof with eauto.
  introv H.
  induction H...
Qed.

Lemma same_var : forall a b (s1 : list (atom * a)) (s2 : list (atom * b)) X A,
    same_stctx s1 s2 ->
    binds X A s1 ->
    exists B, binds X B s2.
Proof with eauto.
  introv Eq.
  gen X A.
  induction Eq; introv H.

  analyze_binds H.

  analyze_binds H...
  lets (B0 & ?) : IHEq BindsTac.

  exists B0...
Qed.

Lemma swft_change : forall Δ Δ' A,
    swft Δ A ->
    same_stctx Δ Δ' ->
    swft Δ' A.
Proof with eauto.
  introv H.
  gen Δ'.
  induction H; introv Eq...

  lets (B & ?): same_var Eq H...
Qed.

(* ******************************************************************************* *)
(** *Properties of [wfe]  *)

Lemma uniq_from_wfe : forall D E,
  wfe D E ->
  uniq E /\ uniq D.
Proof with eauto.
  intros D E H; induction H...
  invert IHwfe...
Qed.

Lemma wft_from_wfe : forall x U E D,
  wfe D E ->
  binds x U E ->
  wft D U.
Proof.
  induction 1; intros J; analyze_binds J.
Qed.

Lemma swft_from_swfe : forall x U E D,
  swfe D E ->
  binds x U E ->
  swft D U.
Proof.
  induction 1; intros J; analyze_binds J.
Qed.

Lemma wfe_weaken : forall T E G X,
  wfe (G ++ E) T ->
  uniq (G ++ [(X, tt)] ++ E) ->
  X `notin` dom T ->
  wfe (G ++ [(X, tt)] ++ E) T.
Proof with simpl_env; eauto.
  introv Hwf_typ Hk Notin.
  remember (G ++ E) as F'.
  generalize dependent G.
  induction Hwf_typ; intros G Hok Heq; subst...
  constructor...
  apply wft_weaken...
Qed.

Lemma wfe_subst_tb : forall Z P E F D,
  wfe (F ++ Z ~ tt ++ E) D ->
  wft E P ->
  uniq (F ++ E) ->
  wfe (F ++ E) (map (subst_ty_in_ty P Z) D).
Proof with eauto using wft_subst_tb.
  introv WFE WFT.
  remember (F ++ Z ~ tt ++ E) as G.
  generalize dependent F.
  induction WFE; introv EQ Uniq; subst; simpl...
  constructor...
Qed.

Lemma notin_fv_typ_in_typ_open : forall (Y X : typvar)  T,
  X `notin` fv_ty_in_ty (open_ty_wrt_ty T Y) ->
  X `notin` fv_ty_in_ty T.
Proof.
 intros Y X T. unfold open_ty_wrt_ty.
 generalize 0.
 induction T; simpl; intros k Fr; eauto.
Qed.

Lemma notin_fv_wf : forall E (X : typvar) T,
  wft E T ->
  X `notin` dom E ->
  X `notin` fv_ty_in_ty T.
Proof with auto.
  intros E X T Wf_typ.
  induction Wf_typ; intros Fr; simpl...
  Case "wf_typ_var".
    assert (X0 `in` (dom dd))...
    eapply binds_In; eauto. fsetdec.
  Case "wft_all".
    pick fresh Y.
    apply (notin_fv_typ_in_typ_open Y)...
Qed.

Lemma map_subst_typ_in_binding_id : forall G Z P D,
  wfe D G ->
  Z `notin` dom D ->
  G = map (subst_ty_in_ty P Z) G.
Proof with eauto.
  introv H.
  induction H; simpl; intros Fr; simpl_env...
  rewrite <- IHwfe...
  rewrite subst_ty_in_ty_fresh_eq...
  eapply notin_fv_wf...
Qed.

Lemma wfe_strengthen : forall E F x U T,
 wfe T (F ++ x ~ U ++ E) ->
 wfe T (F ++ E).
Proof with eauto.
  induction F;
  introv Wfe; inversion Wfe; subst; simpl_env in *...
Qed.

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

Lemma sub_regular : forall Δ A B c,
    sub Δ A B c ->
    swft Δ A /\ swft Δ B.
Proof with eauto using same_eq, same_sym.
  introv Sub.
  induction* Sub.

  (* Case 1 *)
  destruct IHSub.
  splits.

  pick fresh Y and apply swft_all...
  forwards (? & ?) : H0...
  apply swft_change with (Δ := ([(Y , A2)] ++ DD))...

  pick fresh Y and apply swft_all...
  forwards (? & ?) : H0...

  (* Case 2 *)
  splits...

  pick fresh Y and apply swft_all...
  unfold open_sty_wrt_sty.
  simpls...

  Unshelve.
  exact (dom DD).
Qed.

Lemma disjoint_regular : forall Δ A B,
    disjoint Δ A B ->
    swft Δ A /\ swft Δ B.
Proof with eauto using same_eq.
  introv Dis.
  induction* Dis.

  splits...
  eapply sub_regular...

  splits...
  eapply sub_regular...

  splits...

  pick fresh X and apply swft_all...
  apply swft_change with (Δ := ([(X , sty_and A1 A2)] ++ DD))...
  eapply H0...

  pick fresh X and apply swft_all...
  apply swft_change with (Δ := ([(X , sty_and A1 A2)] ++ DD))...
  eapply H0...
Qed.

Lemma styping_regular : forall D G E dir e A,
  has_type D G E dir A e ->
  lc_sexp E /\ swfe D G /\ swft D A /\ swfte D.
Proof with simpl_env; try solve [auto | intuition auto].
  introv H.
  induction H...

  - Case "var".
    splits...
    eauto using swft_from_swfe.

  - Case "app".
    splits...
    destruct IHhas_type1 as (_ & _ & K & _).
    inverts K...

  - Case "anno".
    splits...
    destructs IHhas_type...
    lets :  swft_type H2.
    constructor~.

  - Case "tabs".
    pick_fresh Y.
    destructs (H1 Y)...
    inverts H6.
    splits...
    + SCase "lc_sexp".
      apply (lc_sexp_tabs_exists Y).
      destructs (H1 Y)...
      eauto using  swft_type.
      eauto using  swft_type.
    + SCase "wft".
      pick fresh Z and apply swft_all...
      destructs (H1 Z)...

  - Case "tapp".
    splits...
    + SCase "lc_exp".
      forwards (? & ?) : disjoint_regular H1.
      apply lc_sexp_tapp...
      eauto using swft_type.
    + SCase "wft".
      forwards (? & ?) : disjoint_regular H1.
      destructs IHhas_type.
      eapply swft_open; eauto.
      apply uniq_from_swfte...

  - Case "proj".
    destructs IHhas_type.
    inverts H2.
    splits...

  - Case "abs".
    pick_fresh y.
    destructs (H1 y)...
    inverts H3.
    splits...
    + SCase "lc_exp".
      apply (lc_sexp_abs_exists y).
      destructs (H1 y)...
Qed.

Lemma typing_regular : forall D E e T,
  typ D E e T ->
  lc_exp e /\ wfe D E /\ wft D T.
Proof with simpl_env; try solve [auto | intuition auto].
  introv H; induction H...
  - Case "typ_var".
    splits...
    eauto using wft_from_wfe.
  - Case "typ_abs".
    pick_fresh y.
    destructs (H0 y)...
    inverts H3.
    splits...
    + SCase "lc_exp".
      apply (lc_exp_abs_exists y).
      destructs (H0 y)...
  - Case "typ_app".
    splits...
    destruct IHtyp1 as (_ & _ & K).
    inverts K...
  - Case "typ_tabs".
    pick_fresh Y.
    destructs (H0 Y)...
    splits...
    + SCase "lc_exp".
      apply (lc_exp_tabs_exists Y).
      destructs (H0 Y)...
    + SCase "wft".
      pick fresh Z and apply wft_all...
      destructs (H0 Z)...
  - Case "tapp".
    splits...
    + SCase "lc_exp".
      apply lc_exp_tapp...
      eauto using wft_type.
    + SCase "wft".
      destructs IHtyp.
      eapply wft_open; eauto.
      lets* : uniq_from_wfe H2.
Qed.

Lemma value_regular : forall v,
    value v ->
    lc_exp v.
Proof.
  intros v H.
  induction H; auto.
Qed.

Lemma step_regular : forall e e',
  step e e' ->
  lc_exp e /\ lc_exp e'.
Proof with eauto using value_regular, lc_body_exp_wrt_ty, lc_body_exp_wrt_exp, lc_body_exp_abs_1, lc_body_exp_tabs_1.
  intros e e' H.
  induction H; intuition eauto 6; try constructor...
Qed.

Lemma ctyp_wft : forall G c T1 T2,
    ctyp G c T1 T2 ->
    wft G T1 /\ wft G T2.
Proof with eauto.
  introv Ctyp.
  induction* Ctyp.

  splits...
  pick fresh X and apply wft_all.
  unfold open_ty_wrt_ty.
  simpls...

  (* Case 1 *)
  splits...

  pick fresh X and apply wft_all.
  forwards (? & ?): H0 X...

  pick fresh X and apply wft_all.
  forwards (? & ?): H0 X...

  (* Case 2 *)
  inverts H.
  inverts H0.

  splits; eauto.
  pick fresh X and apply wft_all; auto.
  unfold open_ty_wrt_ty.
  simpls; eauto.

  Unshelve.
  exact (dom dd).

Qed.

(* Automations to the resue *)

Hint Extern 1 (wfe ?D ?E) =>
  match goal with
  | H: typ D E _ _ |- _ => apply (proj1 (proj2 (typing_regular _ _ _ _ H)))
  end.

Hint Extern 1 (wft ?E ?T) =>
  match goal with
  | H: typ E _ _ T |- _ => apply (proj2 (proj2 (typing_regular _ _ _ _ H)))
  | H: ctyp E _ T _ |- _ => apply (proj1 (ctyp_wft _ _ _ _ H))
  | H: ctyp E _ _ T |- _ => apply (proj2 (ctyp_wft _ _ _ _ H))
  end.

Hint Extern 1 (lc_exp ?e) =>
  match goal with
  | H: typ _ _ ?e _ |- _ => apply (proj1 (typing_regular _ _ _ _ H))
  | H: step ?e _ |- _ => apply (proj1 (step_regular _ _ H))
  | H: step _ ?e |- _ => apply (proj2 (step_regular _ _ H))
  | H : value ?v |- _ => apply value_regular
  end.

Hint Extern 1 (lc_ty ?T) =>
  match goal with
  | H: wft _ ?T |- _ => apply (wft_type _ _ H)
  | H : typ _ _ _ ?T |- _ => apply (wft_type _ _ (proj2 (proj2 (typing_regular _ _ _ _ H))))
  end.

Hint Extern 1 (uniq ?E) =>
  match goal with
  | H: swfe _ E |- _ => apply (uniq_from_swfe _ _ H)
  | H: swfte E |- _ => apply (uniq_from_swfte _ H)
  | H: wfe E _ |- _ => apply (proj2 (uniq_from_wfe _ _ H))
  | H: wfe _ E |- _ => apply (proj1 (uniq_from_wfe _ _ H))
  end.

(* ******************************************************************************* *)
(** *Properties of typing *)

Lemma typing_var_weakening : forall E F G e T D,
  typ D (G ++ E) e T ->
  wfe D (G ++ F ++ E) ->
  typ D (G ++ F ++ E) e T.
Proof with simpl_env; eauto using wft_weaken, wft_from_wfe.
  intros E F G e T D Typ.
  remember (G ++ E) as H.
  generalize dependent G.
  induction Typ; intros G EQ Ok; subst...

  - Case "typ_abs".
    pick fresh x and apply typ_abs...
    rewrite <- app_assoc.
    apply (H0 x)...
  - Case "typing_tabs".
    pick fresh X and apply typ_tabs...
    apply (H0 X)...
    rewrite_env (nil ++ [(X, tt)] ++ dd).
    apply wfe_weaken...
Qed.

Lemma ctyp_weaken : forall E F G c T1 T2,
    ctyp (G ++ E) c T1 T2 ->
    uniq (G ++ F ++ E) ->
    ctyp (G ++ F ++ E) c T1 T2.
Proof with eauto using wft_weaken.
  introv Ctyp.
  remember (G ++ E) as H.
  generalize dependent G.
  induction Ctyp; introv EQ Ok; subst...

  pick fresh X and apply ctyp_forall.
  rewrite_env (([(X, tt)] ++ G) ++ F ++ E).
  eapply H0...
  solve_uniq.
Qed.

Lemma typing_tvar_weakening : forall E G e T D X,
  typ (G ++ E) D e T ->
  uniq (G ++ [(X, tt)] ++ E) ->
  X \notin dom D ->
  typ (G ++ [(X, tt)] ++ E) D e T.
Proof with simpl_env; eauto using wfe_weaken, wft_weaken, ctyp_weaken.
  introv Typ Uniq Notin.
  remember (G ++ E) as H.
  generalize dependent G.
  induction Typ; introv Ok Uniq; subst...

  - Case "typ_abs".
    pick fresh x and apply typ_abs...

  - Case "typ_tabs".
    pick fresh Y and apply typ_tabs...
    rewrite_env (([(Y, tt)] ++ G) ++ [(X, tt)] ++ E).
    apply (H0 Y)...
Qed.

Lemma ctyp_through_subst_typ_in_typ : forall E F Z S T P c,
    ctyp (F ++ Z ~ tt ++ E) c S T ->
    uniq (F ++ E) ->
    wft E P ->
    ctyp (F ++ E) c (subst_ty_in_ty P Z S) (subst_ty_in_ty P Z T).
Proof with simpl_env; eauto using wft_subst_tb.
  introv Ctyp Uniq Wf.
  remember (F ++ Z ~ tt ++ E) as G.
  generalize dependent F.
  induction Ctyp; introv EQ Uniq; subst; simpls...

  - Case "ctyp_forall".
    pick fresh X and apply ctyp_forall...
    rewrite subst_ty_in_ty_open_ty_wrt_ty_var...
    rewrite subst_ty_in_ty_open_ty_wrt_ty_var...
    rewrite_env (([(X, tt)] ++ F) ++ E).
    eapply H0...

  - Case "ctyp_distPoly".
    constructor...
    replace (ty_all (subst_ty_in_ty P Z T1)) with (subst_ty_in_ty P Z (ty_all T1))...
    replace (ty_all (subst_ty_in_ty P Z T2)) with (subst_ty_in_ty P Z (ty_all T2))...
Qed.

Lemma typing_through_subst_typ_in_exp : forall E F Z e T P D,
  typ (F ++ Z ~ tt ++ E) D e T ->
  uniq (F ++ E) ->
  wft E P ->
  typ (F ++ E) (map (subst_ty_in_ty P Z) D) (subst_ty_in_exp P Z e) (subst_ty_in_ty P Z T).
Proof with simpl_env; eauto 6 using wfe_subst_tb, wft_subst_tb.
  introv Typ Uniq Wf.
  remember (F ++ Z ~ tt ++ E) as G.
  generalize dependent F.
  induction Typ; intros F EQ Uniq; subst;
    simpl subst_ty_in_exp in *; simpl subst_ty_in_ty in *...

  - Case "typ_abs".
    pick fresh y and apply typ_abs...
    rewrite subst_ty_in_exp_open_exp_wrt_exp_var...
    rewrite_env (map (subst_ty_in_ty P Z) ([(y, T1)] ++ gg)).
    apply H0...

  - Case "typ_tabs".
    pick fresh Y and apply typ_tabs...
    rewrite subst_ty_in_exp_open_exp_wrt_ty_var...
    rewrite subst_ty_in_ty_open_ty_wrt_ty_var...
    rewrite_env (([(Y, tt)] ++ F) ++ E).
    apply H0...

  - Case "typ_tapp".
    rewrite subst_ty_in_ty_open_ty_wrt_ty...

  - Case "typ_capp".
    eapply typ_capp...
    apply ctyp_through_subst_typ_in_typ...
Qed.

Lemma typing_through_subst_exp_in_exp : forall U E F x T e u D,
  typ D (F ++ x ~ U ++ E) e T ->
  typ D E u U ->
  typ D (F ++ E) (subst_exp_in_exp u x e) T.
Proof with simpl_env; eauto 4 using wfe_strengthen.

  introv TypT TypU.
  remember (F ++ x ~ U ++ E) as E'.
  generalize dependent F.
  induction TypT; introv EQ; subst; simpl subst_exp_in_exp in *...

  - Case "typ_var".
    destruct (x0 == x); subst...
    analyze_binds_uniq H0.
    rewrite_env (nil ++ F ++ E).
    apply typing_var_weakening...

  - Case "typ_abs".
    pick fresh y and apply typ_abs...
    rewrite subst_exp_in_exp_open_exp_wrt_exp_var...
    rewrite_env (([(y, T1)] ++ F) ++ E).
    apply H0...

  - Case "typ_tabs".
    pick fresh Y and apply typ_tabs...
    rewrite subst_exp_in_exp_open_exp_wrt_ty_var...
    apply H0...
    rewrite_env (nil ++ [(Y, tt)] ++ dd).
    apply typing_tvar_weakening...

Qed.

Lemma prod_canonical : forall t T1 T2,
    value t ->
    typ nil nil t (ty_prod T1 T2) ->
    exists t1 t2, value t1 /\ value t2 /\ t = exp_pair t1 t2.
Proof.
  introv VAL TY. inductions TY; try (solve [inversion VAL]).
  inversions VAL. exists e1 e2. splits~.
  inversions VAL; inversions H.
Qed.

Lemma unit_canonical : forall t,
    value t ->
    typ nil nil t ty_unit ->
    t = exp_unit.
Proof with eauto.
  introv Val Typ. lets Typ' : Typ. inductions Typ; inverts Val; try solve [inverts H]...
Qed.

(* ********************************************************************** *)
(** * Properties of reductions *)

Lemma value_irred : forall v,
    value v -> irred step v.
Proof with eauto.
  introv V.
  induction V; unfolds; try solve [introv C; inverts C]...

  - Case "value_pair".
    introv H.
    inverts H as _ H.
    lets : IHV1 H...
    lets : IHV2 H...

  - Case "value_arr".
    introv H.
    inverts H as H.
    lets : IHV H...

  - Case "value_forall".
    introv H.
    inverts H as H.
    lets : IHV H...

  - Case "value_distArr".
    introv H.
    inverts H as H.
    lets : IHV H...

  - Case "value_topArr".
    introv H.
    inverts H as H.
    lets : IHV H...

  - Case "vaue_topAll".
    introv H.
    inverts H as H.
    lets : IHV H...

  - Case "value_distArr".
    introv H.
    inverts H as H.
    lets : IHV H...

Qed.

Ltac sweet :=
  match goal with
  | H : value ?t, H1 : step ?t ?e |- _ =>
    forwards* :  (value_irred _ H e)
  end.

Lemma step_unique: forall (t t1 t2 : exp),
  step t t1 -> step t t2 -> t1 = t2.
Proof with eauto; try sweet.
  introv Red1.
  gen t2.
  induction Red1; introv Red2.

  - Case "topArr".
    inverts Red2...
    inverts H3.
    inverts H4.
    inverts H3.
    inverts H1.

  - Case "topAll".
    inverts Red2...
    inverts H4.
    inverts H5.

  - Case "distArr".
    inverts Red2...
    inverts H6...
    inverts H7...

  - Case "distPoly".
    inverts Red2...
    inverts H6...
    inverts H7...

  - Case "id".
    inverts Red2...

  - Case "trans".
    inverts Red2...

  - Case "top".
    inverts Red2...

  - Case "arr".
    inverts Red2...
    inverts H5...

  - Case "pair".
    inverts Red2...

  - Case "projl".
    inverts Red2...
    inverts H4...

  - Case "projr".
    inverts Red2...
    inverts H4...

  - Case "forall".
    inverts Red2...
    inverts H5...

  - Case "beta".
    inverts Red2...
    inverts H5...

  - Case "tbeta".
    inverts Red2...
    inverts H5...

  - Case "app1".
    inverts Red2...
    inverts Red1...
    inverts H3...
    inverts Red1...
    inverts H6...
    inverts Red1...
    inverts Red1...
    erewrite IHRed1...

  - Case "app2".
    inverts Red2...
    inverts Red1...
    erewrite IHRed1...

  - Case "pairl".
    inverts Red2...
    erewrite IHRed1...

  - Case "pairr".
    inverts Red2...
    erewrite IHRed1...

  - Case "tapp".
    inverts Red2...
    inverts Red1...
    inverts H4...
    inverts Red1...
    inverts H6...
    inverts Red1...
    inverts Red1...
    erewrite IHRed1...

  - Case "pairr".
    inverts Red2...
    inverts Red1...
    inverts Red1...
    erewrite IHRed1...

Qed.

Lemma value_no_step : forall v1 v2,
    value v1 ->
    v1 ->* v2 ->
    v2 = v1.
Proof.
  introv ? Red.
  induction* Red.
  lets : value_irred H.
  pose (H1 b).
  tryfalse.
Qed.

Lemma multi_red_capp : forall c t t',
    t ->* t' -> (exp_capp c t) ->* (exp_capp c t').
Proof.
  intros.
  induction* H.
Qed.

Lemma multi_red_app1 : forall v1 t2 t2',
    value v1 ->
    t2 ->* t2' ->
    (exp_app v1 t2) ->* (exp_app v1 t2').
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_app2 : forall t1 t2 t1',
    lc_exp t2 ->
    t1 ->* t1' ->
    (exp_app t1 t2) ->* (exp_app t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_app : forall t1 t2 v1 v2,
    value v1 -> lc_exp t2 ->
    t1 ->* v1 -> t2 ->* v2 ->
    (exp_app t1 t2) ->* (exp_app v1 v2).
Proof.
  intros.
  apply star_trans with (b := exp_app v1 t2).
  sapply* multi_red_app2.
  sapply* multi_red_app1.
Qed.

Lemma multi_red_pair1 : forall t1 t2 t1',
    lc_exp t2 ->
    t1 ->* t1' ->
    (exp_pair t1 t2) ->* (exp_pair t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_pair2 : forall v1 t2 t2',
    value v1 ->
    t2 ->* t2' ->
    (exp_pair v1 t2) ->* (exp_pair v1 t2').
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_pair : forall t1 t2 v1 v2,
    value v1 -> lc_exp t2 ->
    t1 ->* v1 -> t2 ->* v2 ->
    (exp_pair t1 t2) ->* (exp_pair v1 v2).
Proof.
  intros.
  apply star_trans with (b := exp_pair v1 t2).
  sapply* multi_red_pair1.
  sapply* multi_red_pair2.
Qed.

Lemma multi_red_tapp : forall t t' T,
    lc_ty T -> t ->* t' -> (exp_tapp t T) ->* (exp_tapp t' T).
Proof with eauto.
  intros.
  induction* H0.
Qed.

(* ********************************************************************** *)
(** * Properties of subtyping *)

Lemma sub_subst : forall Z E F C A B P c,
  sub (F ++ Z ~ C ++ E) A B c ->
  swft E P ->
  uniq (map (subst_sty_in_sty P Z) F ++ E) ->
  sub (map (subst_sty_in_sty P Z) F ++ E) (subst_sty_in_sty P Z A) (subst_sty_in_sty P Z B) c.
Proof with eauto using swft_subst_tb, swft_type.
  introv WT WP.
  remember (F ++ Z ~ C ++ E) as G.
  generalize dependent F.
  induction WT; intros F EQ Ok; subst; simpl subst_sty_in_sty...

  (* Case 1 *)
  pick fresh Y and apply S_forall...
  repeat rewrite subst_sty_in_sty_open_sty_wrt_sty_var...
  rewrite_env (map (subst_sty_in_sty P Z) (Y ~ A2 ++ F) ++ E).
  apply H0...
  simpls...

  (* Case 2 *)
  pick fresh Y and apply S_distPoly...
  repeat rewrite subst_sty_in_sty_open_sty_wrt_sty_var...
  rewrite_env (map (subst_sty_in_sty P Z) (Y ~ A ++ F) ++ E).
  eapply swft_subst_tb; simpls...

  repeat rewrite subst_sty_in_sty_open_sty_wrt_sty_var...
  rewrite_env (map (subst_sty_in_sty P Z) (Y ~ A ++ F) ++ E).
  eapply swft_subst_tb; simpls...

Qed.

Lemma sub_subst_push : forall Z E C A B P c,
  sub (Z ~ C ++ E) A B c ->
  swft E P ->
  uniq E ->
  sub E (subst_sty_in_sty P Z A) (subst_sty_in_sty P Z B) c.
Proof with auto.
  introv SUB WFT UNI.
  rewrite_env (nil ++ Z ~ C ++ E) in SUB.
  forwards : sub_subst SUB WFT...
Qed.

Lemma sub_change : forall Δ Δ' A B c,
    sub Δ A B c ->
    same_stctx Δ Δ' ->
    sub Δ' A B c.
Proof with eauto using swft_change.
  introv Sub.
  gen Δ'.
  induction Sub; introv Eq...

  eapply S_distPoly...

Qed.

Lemma sub_andr : forall Δ A B C c,
    sub Δ A (sty_and B C) c ->
    exists c1 c2, sub Δ A B c1 /\ sub Δ A C c2.
Proof.
  introv SUB. inductions SUB.

  inversions H.
  eexists. eexists. splits~.

  forwards ~ (c1' & c2' & [co1 co2]) : IHSUB1.
  exists (co_trans c1' c2) (co_trans c2' c2).
  splits*.

  inverts H.
  eexists. eexists. splits*.

  eexists. eexists. splits*.

  inversions H.
  exists (co_trans co_proj1 co_proj1) (co_trans co_proj2 co_proj1).
  splits*.

  inversions H0.
  exists (co_trans co_proj1 co_proj2) (co_trans co_proj2 co_proj2).
  splits*.
Qed.

Lemma sub_weakening : forall G F E A B c,
  sub (G ++ E) A B c ->
  uniq (G ++ F ++ E) ->
  sub (G ++ F ++ E) A B c.
Proof with eauto using swft_weaken.
  introv Sub.
  remember (G ++ E) as H.
  generalize dependent G.
  induction Sub; introv EQ Ok; subst...

  pick fresh X and apply S_forall...
  rewrite_env (([(X, A2)] ++ G) ++ F ++ E).
  eapply H0...
  solve_uniq.

  pick fresh X and apply S_distPoly...
  rewrite_env (([(X, A)] ++ G) ++ F ++ E).
  eapply swft_weaken...
  eapply H0...
  solve_uniq.
  rewrite_env (([(X, A)] ++ G) ++ F ++ E).
  eapply swft_weaken...
  eapply H1...
  solve_uniq.

Qed.

Lemma topArr : forall Δ A,
    swft Δ A ->
    sub Δ A (sty_arrow sty_top sty_top) (co_trans co_topArr co_top).
Proof with eauto.
  introv Wft.
  eapply S_trans...
Qed.

Lemma rcdTop : forall Δ l A,
    swft Δ A ->
    sub Δ A (sty_rcd l sty_top) (co_trans co_id co_top).
Proof with eauto.
  introv Wft.
  eapply S_trans...
Qed.

Lemma same_mid : forall a (F E : list (atom * a)) X V U,
    same_stctx (F ++ [(X, V)] ++ E) (F ++ [(X, U)] ++ E).
Proof with eauto using same_eq.
  intros a F.
  alist induction F; intros; simpls...
  constructor...
  constructor...

Qed.

Lemma swft_narrow : forall V F U T E X,
  swft (F ++ X ~ V ++ E) T ->
  swft (F ++ X ~ U ++ E) T.
Proof with eauto using same_mid.
  intros.
  eapply swft_change...
Qed.

Lemma sub_narrow : forall Q F E Z P S T c,
  sub (F ++ Z ~ Q ++ E) S T c ->
  sub (F ++ Z ~ P ++ E) S T c.
Proof with eauto using same_mid.
  intros.
  eapply sub_change...
Qed.

Lemma sub_renaming : forall X Y A D B B' c,
    uniq ([(X, A)] ++ D) ->
    sub ([(X, A)] ++ D) (open_sty_wrt_sty B (sty_var_f X)) (open_sty_wrt_sty B' (sty_var_f X)) c ->
    X `notin` fv_sty_in_sty B ->
    X `notin` fv_sty_in_sty B' ->
    Y `notin` fv_sty_in_sty B ->
    Y `notin` fv_sty_in_sty B' ->
    Y `notin` dom D ->
    sub ([(Y, A)] ++ D) (open_sty_wrt_sty B (sty_var_f Y)) (open_sty_wrt_sty B' (sty_var_f Y)) c.
Proof with eauto.
  introv Uniq Sub ? ? ? ? ?.
  destruct (X == Y); substs...

  assert (Eq1 : (open_sty_wrt_sty B (sty_var_f Y)) = (subst_sty_in_sty (sty_var_f Y) X (open_sty_wrt_sty B (sty_var_f X)))).
    rewrite (subst_sty_in_sty_intro X)...

  assert (Eq2 : (open_sty_wrt_sty B' (sty_var_f Y)) = (subst_sty_in_sty (sty_var_f Y) X (open_sty_wrt_sty B' (sty_var_f X)))).
    rewrite (subst_sty_in_sty_intro X)...

  rewrite Eq1.
  rewrite Eq2.

  simpls.

  eapply sub_subst_push...
  simpl_env in *.
  eapply sub_weakening...
  solve_uniq.
Qed.

Lemma swfte_tvar_push: forall X A D,
    swfte ([(X, A)] ++ D) ->
    swfte D /\ swft D A /\ X `notin` fv_sty_in_sty A.
Proof with eauto.
  introv WFTE.
  splits...
  inverts WFTE...
  inverts WFTE...
  eapply swfte_tvar...

Qed.

Lemma swfte_subst_tb : forall Q Z P E F,
  swfte (F ++ Z ~ Q ++ E) ->
  swft E P ->
  swfte (map (subst_sty_in_sty P Z) F ++ E).
Proof with eauto.
  introv Wfte.
  alist induction F; introv Wft; simpls...

  lets (? & ? & ?) : swfte_tvar_push Wfte...

  lets (? & ? & ?) : swfte_tvar_push Wfte...

  constructor...
  simpl_env in *.
  eapply swft_subst_tb...
  lets : uniq_from_swfte H...

  lets Imp: uniq_from_swfte Wfte.
  inverts Imp...
Qed.

Lemma swfte_strength: forall E G,
    swfte (E ++ G) ->
    swfte G.
Proof with eauto.
  intros E.
  alist induction E; introv Wfte; simpls...
  eapply IHE...
  rewrite_env ((map (subst_sty_in_sty sty_top x)) nil ++ (E ++ G)).
  eapply swfte_subst_tb...
  simpl_env in *...
Qed.

(* ********************************************************************** *)
(** * Misc *)

Lemma ftv_in_dom : forall Δ T,
    wft Δ T ->
    fv_ty_in_ty T [<=] dom Δ.
Proof.
  introv H.
  induction H; simpl; try fsetdec.

  apply binds_In in H.
  fsetdec.

  pick fresh X.
  assert (Fx : fv_ty_in_ty (open_ty_wrt_ty T2 (ty_var_f X)) [<=] dom ([(X,tt)] ++ dd)) by auto.
  simpl in Fx.
  assert (Fy : fv_ty_in_ty T2 [<=] fv_ty_in_ty (open_ty_wrt_ty T2 (ty_var_f X))).
  eapply fv_ty_in_ty_open_ty_wrt_ty_lower.
  fsetdec.
Qed.

Lemma fv_in_dom : forall Δ G e T,
    typ Δ G e T ->
    fv_exp_in_exp e [<=] dom G /\
    fv_ty_in_exp e [<=] dom Δ.
Proof.
  introv H.
  induction H; simpl; splits; try fsetdec.

  - Case "var".
    apply binds_In in H0.
    fsetdec.

  - Case "abs: var".
    pick fresh x.
    forwards~ (? & ?): H0 x.
    assert (Fx : fv_exp_in_exp (open_exp_wrt_exp e (exp_var_f x)) [<=] dom ([(x,T1)] ++ gg)) by auto.
    simpl in Fx.
    assert (Fy : fv_exp_in_exp e [<=] fv_exp_in_exp (open_exp_wrt_exp e (exp_var_f x))).
    eapply fv_exp_in_exp_open_exp_wrt_exp_lower.
    fsetdec.

  - Case "abs: tvar".
    pick fresh x.
    forwards~ (? & ?): H0 x.
    assert (Fy : fv_ty_in_exp e [<=] fv_ty_in_exp (open_exp_wrt_exp e (exp_var_f x))).
    eapply fv_ty_in_exp_open_exp_wrt_exp_lower.
    fsetdec.

  - Case "tabs: var".
    pick fresh X.
    forwards~ (? & ?): H0 X.
    assert (Fy : fv_exp_in_exp e [<=] fv_exp_in_exp (open_exp_wrt_ty e (ty_var_f X))).
    eapply fv_exp_in_exp_open_exp_wrt_ty_lower.
    fsetdec.

  - Case "tabs: tvar".
    pick fresh X.
    forwards~ (? & ?): H0 X.
    assert (Fy : fv_ty_in_exp e [<=] fv_ty_in_exp (open_exp_wrt_ty e (ty_var_f X))).
    eapply fv_ty_in_exp_open_exp_wrt_ty_lower.
    fsetdec.

  - Case "tapp".
    lets: ftv_in_dom H0.
    inverts IHtyp.
    fsetdec.
Qed.

Lemma closed_no_var : forall v T,
    typ nil nil v T ->
    fv_ty_in_exp v [=] {} /\ fv_exp_in_exp v [=] {}.
Proof.
  introv Typ.
  forwards (? & ?) : fv_in_dom Typ.
  splits; fsetdec.
Qed.

Definition exp_relation := exp -> exp -> Prop.

Definition getR (p : list (atom * (sty * sty * exp_relation))) : list (atom * exp_relation) :=
  map (fun t => match t with | (a, b, R) => R end) p.

Definition getOne (p : list (atom * (sty * sty * exp_relation))) : list (atom * sty) :=
  map (fun t => match t with | (a, b, R) => a end) p.

Definition getTwo (p : list (atom * (sty * sty * exp_relation))) : list (atom * sty) :=
  map (fun t => match t with | (a, b, R) => b end) p.

Definition mtsubst_in_sty (s : list (atom * sty)) (ty : sty) : sty :=
  fold_left (fun acc p => subst_sty_in_sty (snd p) (fst p) acc) s ty.

Definition mtsubst_in_exp (s : list (atom * sty)) (e : exp) : exp :=
  fold_left (fun acc p => subst_ty_in_exp (| snd p |) (fst p)  acc) s e.

Definition msubst_in_exp (s : list (atom * exp)) (t : exp) : exp :=
  fold_left (fun acc p => subst_exp_in_exp (snd p) (fst p) acc) s t.

Lemma mtsubst_arr : forall s A1 A2,
    mtsubst_in_sty s (sty_arrow A1 A2) = sty_arrow (mtsubst_in_sty s A1) (mtsubst_in_sty s A2).
Proof with eauto.
  intros s.
  induction s; intros; simpls...
Qed.

Lemma mtsubst_forall : forall s A1 A2,
    mtsubst_in_sty s (sty_all A1 A2) = sty_all (mtsubst_in_sty s A1) (mtsubst_in_sty s A2).
Proof with eauto.
  intros s.
  induction s; intros; simpls...
Qed.

Lemma mtsubst_and : forall s A1 A2,
    mtsubst_in_sty s (sty_and A1 A2) = sty_and (mtsubst_in_sty s A1) (mtsubst_in_sty s A2).
Proof with eauto.
  intros s.
  induction s; intros; simpls...
Qed.

Lemma mtsubst_nat : forall s,
    mtsubst_in_sty s sty_nat = sty_nat.
Proof with eauto.
  intros s.
  induction s; intros; simpls...
Qed.

Lemma mtsubst_top : forall s,
    mtsubst_in_sty s sty_top = sty_top.
Proof with eauto.
  intros s.
  induction s; intros; simpls...
Qed.

Lemma mtsubst_bot : forall s,
    mtsubst_in_sty s sty_bot = sty_bot.
Proof with eauto.
  intros s.
  induction s; intros; simpls...
Qed.

Lemma mtsubst_rcd : forall s l A,
    mtsubst_in_sty s (sty_rcd l A) = sty_rcd l (mtsubst_in_sty s A).
Proof with eauto.
  intros s.
  induction s; intros; simpls...
Qed.

Lemma mtsubst_unit : forall s,
    mtsubst_in_exp s exp_unit = exp_unit.
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma mtsubst_lit : forall s i,
    mtsubst_in_exp s (exp_lit i) = exp_lit i.
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma mtsubst_tabs : forall s e,
    mtsubst_in_exp s (exp_tabs e)  = exp_tabs (mtsubst_in_exp s e).
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma mtsubst_capp : forall s c e,
    mtsubst_in_exp s (exp_capp c e) = exp_capp c (mtsubst_in_exp s e).
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma msubst_unit : forall s,
    msubst_in_exp s exp_unit = exp_unit.
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma msubst_lit : forall s i,
    msubst_in_exp s (exp_lit i) = exp_lit i.
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma msubst_capp : forall s c e,
    msubst_in_exp s (exp_capp c e) = exp_capp c (msubst_in_exp s e).
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma mtsubst_pair : forall s e1 e2,
    mtsubst_in_exp s (exp_pair e1 e2) = exp_pair (mtsubst_in_exp s e1) (mtsubst_in_exp s e2).
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma msubst_pair : forall s e1 e2,
    msubst_in_exp s (exp_pair e1 e2) = exp_pair (msubst_in_exp s e1) (msubst_in_exp s e2).
Proof.
  intros s.
  induction s; intros; simpls; eauto.
Qed.

Lemma mtsubst_tapp : forall s e A,
    mtsubst_in_exp s (exp_tapp e (| A |)) = exp_tapp (mtsubst_in_exp s e) (|mtsubst_in_sty s A|).
Proof with eauto.
  intros s.
  alist induction s; intros; simpls...

  rewrite <- trans_subst_sty.
  rewrite IHs...

Qed.

Lemma msubst_tapp : forall s e T,
    msubst_in_exp s (exp_tapp e T) = exp_tapp (msubst_in_exp s e) T.
Proof with eauto.
  induction s; intros; simpls; eauto.
Qed.

Lemma mtsubst_app : forall s e e',
    mtsubst_in_exp s (exp_app e e') = exp_app (mtsubst_in_exp s e) (mtsubst_in_exp s e') .
Proof with eauto.
  intros s.
  alist induction s; intros; simpls...
Qed.

Lemma msubst_app : forall s e e',
    msubst_in_exp s (exp_app e e') = exp_app (msubst_in_exp s e) (msubst_in_exp s e').
Proof with eauto.
  induction s; intros; simpls; eauto.
Qed.

Lemma mtsubst_abs : forall s e,
    mtsubst_in_exp s (exp_abs e) = exp_abs (mtsubst_in_exp s e).
Proof with eauto.
  intros s.
  alist induction s; intros; simpls...
Qed.

Lemma msubst_abs : forall s e,
    msubst_in_exp s (exp_abs e) = exp_abs (msubst_in_exp s e).
Proof with eauto.
  induction s; intros; simpls; eauto.
Qed.

Lemma msubst_tabs : forall s e,
    msubst_in_exp s (exp_tabs e) = exp_tabs (msubst_in_exp s e).
Proof with eauto.
  induction s; intros; simpls; eauto.
Qed.

Inductive all_value : list (atom * exp) -> Prop :=
| all_empty : all_value nil
| all_cons : forall x v T g,
    value v ->
    typ nil nil v T ->
    all_value g ->
    all_value ([(x , v)] ++ g).

Hint Constructors all_value.

Lemma msubst_ty_open_wrt_ty : forall s e T,
    all_value s ->
    msubst_in_exp s (open_exp_wrt_ty e T) =
    open_exp_wrt_ty (msubst_in_exp s e) T.
Proof with eauto.
  intros s.
  alist induction s; intros; simpls...
  inverts H.
  rewrite <- IHs...
  rewrite subst_exp_in_exp_open_exp_wrt_ty...
Qed.

Lemma msubst_open : forall g t a,
    all_value g ->
    msubst_in_exp g (open_exp_wrt_exp t a) = open_exp_wrt_exp (msubst_in_exp g t) (msubst_in_exp g a).
Proof with eauto.
  intro g.
  alist induction g; intros; simpls...
  inverts H.
  rewrite subst_exp_in_exp_open_exp_wrt_exp...
Qed.

Lemma msubst_fresh : forall g e,
    fv_exp_in_exp e [=] {} ->
    msubst_in_exp g e = e.
Proof.
  intros.
  alist induction g.
  reflexivity.
  simpl.
  rewrite~ subst_exp_in_exp_fresh_eq.
  fsetdec.
Qed.

Lemma mtsubst_exp_fresh : forall s e,
    fv_ty_in_exp e [=] {} ->
    mtsubst_in_exp s e = e.
Proof.
  intros.
  alist induction s.
  reflexivity.
  simpl.
  rewrite~ subst_ty_in_exp_fresh_eq.
  fsetdec.
Qed.

(* ********************************************************************** *)
(** * Logical interpretation of type contexts *)

Inductive rel_d : stctx -> sctx -> Prop :=
| rel_d_empty : rel_d nil nil
| rel_d_cons : forall X Δ t B p,
    X `notin` dom Δ ->
    rel_d Δ p ->
    swft nil t ->
    mono t ->
    disjoint nil t (mtsubst_in_sty p B) ->
    rel_d ([(X, B)] ++ Δ) ([(X, t)] ++ p).

Hint Constructors rel_d.

Lemma rel_d_same : forall Δ p,
    rel_d Δ p -> same_stctx Δ p.
Proof with simpl_env; eauto.
  induction 1; simpls...
Qed.

Lemma rel_d_notin : forall Δ p X,
    rel_d Δ p ->
    X `notin` dom Δ ->
    X `notin` dom p.
Proof with eauto.
  introv RelD.
  induction RelD; simpls...
Qed.

Lemma rel_d_uniq : forall Δ p,
    rel_d Δ p ->
    uniq Δ /\ uniq p.
Proof with eauto using rel_d_notin.
  introv RelD.
  induction RelD; simpls...
  splits...
  solve_uniq.
  destruct IHRelD...
Qed.

Lemma mtsubst_open : forall Δ p A1 A2,
    rel_d Δ p ->
    mtsubst_in_sty p (open_sty_wrt_sty A1 A2) =
    open_sty_wrt_sty (mtsubst_in_sty p A1) (mtsubst_in_sty p A2).
Proof with eauto using swft_type.
  introv RelD.
  gen A1 A2.
  induction RelD; intros; simpls...
  rewrite subst_sty_in_sty_open_sty_wrt_sty...
Qed.

Lemma mtsubst_ty_open : forall Δ p e A,
    rel_d Δ p ->
    mtsubst_in_exp p (open_exp_wrt_ty e (|A|)) =
    open_exp_wrt_ty (mtsubst_in_exp p e) (|mtsubst_in_sty p A|).
Proof with eauto using swft_type, lc_sty_ty.
  introv RelD.
  gen A e.
  induction RelD; intros; simpls...
  rewrite <- IHRelD...
  rewrite subst_ty_in_exp_open_exp_wrt_ty...
  rewrite trans_subst_sty...
Qed.

Lemma mtsubst_exp_open : forall s e1 e2,
    mtsubst_in_exp s (open_exp_wrt_exp e1 e2) =
    open_exp_wrt_exp (mtsubst_in_exp s e1) (mtsubst_in_exp s e2).
Proof with eauto.
  intros s.
  alist induction s; intros; simpls...
  rewrite subst_ty_in_exp_open_exp_wrt_exp...
Qed.

Lemma mtsubst_fresh : forall s C,
    fv_sty_in_sty C [=] {} ->
    mtsubst_in_sty s C = C.
Proof.
  intros.
  alist induction s.
  reflexivity.
  simpl.
  rewrite~ subst_sty_in_sty_fresh_eq.
  fsetdec.
Qed.

Lemma mtsubst_in_exp_subst : forall s v x t,
    fv_ty_in_exp v [=] {} ->
    subst_exp_in_exp v x (mtsubst_in_exp s t) = mtsubst_in_exp s (subst_exp_in_exp v x t).
Proof with eauto.
  intros s.
  alist induction s; intros; simpls...

  rewrite IHs...
  rewrite subst_exp_in_exp_subst_ty_in_exp...
  fsetdec.
Qed.

Lemma mtsubst_var_notin : forall p x,
    x `notin` dom p ->
    mtsubst_in_exp p (exp_var_f x) = (exp_var_f x).
Proof with auto.
  intros p.
  alist induction p; intros; simpls...
Qed.

Lemma mtsubst_notin: forall X Δ p B,
    rel_d Δ p ->
    X `notin` dom p ->
    X `notin` (fv_sty_in_sty B) ->
    X `notin` fv_sty_in_sty (mtsubst_in_sty p B).
Proof with eauto.
  introv Wf.
  gen B.
  induction Wf; introv ? ?; simpls...
  eapply IHWf...
  eapply fv_sty_in_sty_subst_sty_in_sty_notin...
  eapply swft_tvar...
Qed.

Lemma mtsubst_swft : forall Δ A s,
    rel_d Δ s ->
    swft Δ A ->
    swft nil (mtsubst_in_sty s A).
Proof with eauto.
  introv H.
  gen A.
  induction H; introv WF; simpls...

  eapply IHrel_d...

  lets (? & ?) : rel_d_uniq...
  rewrite_env (map (subst_sty_in_sty t X) nil ++ Δ).
  eapply swft_subst_tb...
  exact WF.
  rewrite_env (Δ ++ nil).
  eapply swft_weaken_head...
Qed.

(* Lemma mtsubst_tvar: forall s Δ X (A : sty), *)
(*     rel_d Δ s -> *)
(*     binds X A Δ -> *)
(*     swft nil (mtsubst_in_sty s (sty_var_f X)). *)
(* Proof with eauto. *)
(*   introv H. *)
(*   gen X A. *)
(*   induction H; introv Bind; simpls... *)

(*   case_if... *)
(*   substs. *)
(*   inverts WF. *)
(*   inverts Uniq. *)
(*   eapply mtsubst_swft... *)
(*   rewrite_env (s1 ++ nil). *)
(*   eapply swft_weaken_head... *)
(*   inverts WF. *)
(*   inverts Uniq. *)
(*   analyze_binds Bind. *)
(*   eapply IHsame_stctx... *)
(* Qed. *)

Lemma mtsubst_nil : forall Γ,
    map (mtsubst_in_sty nil) Γ = Γ.
Proof with eauto.
  intros.
  alist induction Γ; simpls...
  rewrite IHΓ...
Qed.

Lemma mtsubst_cons : forall Γ X B s,
    map (mtsubst_in_sty ([(X, B)] ++ s)) Γ = map (mtsubst_in_sty s) (map (subst_sty_in_sty B X) Γ).
Proof with eauto.
  intros Γ.
  alist induction Γ; intros; simpls...
  rewrite IHΓ...
Qed.

Lemma mtsubst_trans : forall Γ B X,
    ∥ map (subst_sty_in_sty B X) Γ ∥ = map (subst_ty_in_ty (| B |) X) (∥ Γ ∥).
Proof with eauto.
  intros Γ.
  alist induction Γ; intros; simpls...
  rewrite IHΓ...
  rewrite trans_subst_sty...
Qed.

Lemma mtsubst_typ : forall (Δ : stctx) Γ s t A,
    rel_d Δ s ->
    typ (map (const tt) Δ) (∥ Γ ∥) t (| A |) ->
    typ nil (∥ map (mtsubst_in_sty s) Γ ∥) (mtsubst_in_exp s t) (| mtsubst_in_sty s A |).
Proof with eauto using swft_wft.
   introv H.
   gen Γ t A.
  induction H; introv Typ.

  - Case "empty".
    simpls.
    rewrite mtsubst_nil...

  - Case "cons".
    simpls.

    lets (? & ?) : rel_d_uniq...
    simpl_env.

    rewrite mtsubst_cons...
    eapply IHrel_d...
    rewrite trans_subst_sty.
    rewrite mtsubst_trans...
    rewrite_env (nil ++ map (const tt) Δ).
    eapply typing_through_subst_typ_in_exp...

    rewrite_env (map (const tt) Δ ++ nil).
    eapply wft_weaken_head...
    apply swft_wft_nil...
 Qed.

Lemma mtsubst_sub : forall A B Δ c s,
    rel_d Δ s ->
    sub Δ A B c ->
    sub nil (mtsubst_in_sty s A) (mtsubst_in_sty s B) c.
Proof with eauto.
  introv Eq.
  gen A B c.
  induction Eq; introv Sub; simpls...
  lets (? & ?) : rel_d_uniq...
  apply IHEq...
  rewrite_env (map (subst_sty_in_sty t X) nil ++ Δ).
  eapply sub_subst; simpls...
  rewrite_env (nil ++ Δ ++ nil).
  eapply swft_weaken; simpls...
Qed.

Lemma mtsubst_mono : forall Δ p t,
    rel_d Δ p ->
    mono t ->
    mono (mtsubst_in_sty p t).
Proof with eauto.
  introv WF.
  gen t.
  induction WF; introv Mono; simpls...
  apply IHWF...
  apply subst_mono...
Qed.

Lemma swft_subst_ctx: forall Δ2 Δ1 A p,
   swft (Δ1 ++ Δ2) A ->
   swfte (Δ1 ++ Δ2) ->
   rel_d Δ2 p ->
   swft (map (mtsubst_in_sty p) Δ1) (mtsubst_in_sty p A).
Proof with eauto.
  intros Δ2.
  induction Δ2; introv Wft Wfte RelD; simpls...
  inverts RelD.
  simpls...
  rewrite mtsubst_nil...
  simpl_env in Wft...

  inverts RelD as ? RelD.
  lets (? & ?) : rel_d_uniq RelD.
  assert (swft Δ2 t).
  rewrite_env (Δ2 ++ nil).
  eapply swft_weaken_head...

  rewrite mtsubst_cons.
  simpls.
  eapply IHΔ2...
  eapply swft_subst_tb...
  exact Wft.

  lets : uniq_from_swfte Wfte.
  solve_uniq.
  eapply swfte_subst_tb...
  exact Wfte.
Qed.

Lemma sub_subst_ctx: forall Δ2 Δ1 p A B c,
   sub (Δ1 ++ Δ2) A B c->
   swfte (Δ1 ++ Δ2) ->
   rel_d Δ2 p ->
   sub (map (mtsubst_in_sty p) Δ1) (mtsubst_in_sty p A) (mtsubst_in_sty p B) c.
Proof with eauto.
  intros Δ2.
  induction Δ2; introv Sub Wfte RelD.
  inverts RelD.
  rewrite mtsubst_nil...
  simpls...
  simpl_env in Sub...

  inverts RelD as ? RelD.
  lets (? & ?) : rel_d_uniq RelD.
  assert (swft Δ2 t).
  rewrite_env (Δ2 ++ nil).
  eapply swft_weaken_head...

  rewrite mtsubst_cons...
  simpls...
  eapply IHΔ2...
  eapply sub_subst...
  exact Sub.

  lets : uniq_from_swfte Wfte.
  solve_uniq.
  eapply swfte_subst_tb...
  exact Wfte.

Qed.

Lemma swfte_subst_ctx: forall Δ2 Δ1 p,
   swfte (Δ1 ++ Δ2) ->
   rel_d Δ2 p ->
   swfte (map (mtsubst_in_sty p) Δ1).
Proof with eauto.
  intros Δ2.
  induction Δ2; introv Wfte RelD.
  inverts RelD.
  rewrite mtsubst_nil...
  simpl_env in Wfte...

  inverts RelD as ? RelD.
  lets (? & ?) : rel_d_uniq RelD.

  rewrite mtsubst_cons...
  eapply IHΔ2...
  eapply swfte_subst_tb...
  exact Wfte.
  rewrite_env (Δ2 ++ nil).
  eapply swft_weaken_head...

Qed.

Lemma mtsubst_tvar_notin : forall p X,
    X `notin` dom p ->
    mtsubst_in_sty p (sty_var_f X) = (sty_var_f X).
Proof with auto.
  intros p.
  alist induction p; intros; simpls...
  case_if...
  substs...
  false H.
  solve_notin.
Qed.

(* ********************************************************************** *)
(** ** Renaming lemmas . *)

Lemma swft_renaming : forall X Y A D B,
    uniq ([(X, A)] ++ D) ->
    swft ([(X, A)] ++ D) (open_sty_wrt_sty B (sty_var_f X)) ->
    X `notin` fv_sty_in_sty B ->
    Y `notin` fv_sty_in_sty B ->
    Y `notin` dom D ->
    swft ([(Y, A)] ++ D) (open_sty_wrt_sty B (sty_var_f Y)).
Proof with eauto.
  introv Uniq Wft Frx Fry Fry'.
  destruct (X == Y); substs...
  rewrite (subst_sty_in_sty_intro X)...
  rewrite_env ((map (subst_sty_in_sty (sty_var_f Y) X) nil) ++ [(Y, A)] ++ D).
  apply swft_subst_tb with (B := A); simpls...
  simpl_env.
  eapply swft_weaken...
  solve_uniq.
Qed.

Lemma typing_tvar_rename : forall X Γ Y G e T,
    typ ([(X, tt)] ++ G) Γ (open_exp_wrt_ty e (ty_var_f X)) (open_ty_wrt_ty T (ty_var_f X)) ->
    wfe G Γ ->
    X `notin` dom G ->
    X `notin` dom Γ ->
    X `notin` fv_ty_in_ty T ->
    X `notin` fv_ty_in_exp e ->
    Y `notin` dom G ->
    Y `notin` dom Γ ->
    Y `notin` fv_ty_in_ty T ->
    Y `notin` fv_ty_in_exp e ->
    typ ([(Y, tt)] ++ G) Γ (open_exp_wrt_ty e (ty_var_f Y)) (open_ty_wrt_ty T (ty_var_f Y)).
Proof with eauto.
  introv TypX ? ? ? ? ? ? ? ? ?.
  destruct (X == Y); substs...

  assert (Wfe : wfe ([(X, tt)] ++ G) Γ)...
  assert (Uniq : uniq ([(X, tt)] ++ G))...
  inverts Uniq.

  rewrite (subst_ty_in_exp_intro X)...
  rewrite (subst_ty_in_ty_intro X)...
  rewrite_env (nil ++ [(Y, tt)] ++ G).
  replace Γ with (map (subst_ty_in_ty (ty_var_f Y) X) Γ).
  apply typing_through_subst_typ_in_exp...
  rewrite_env ([(X , tt)] ++ [(Y, tt)] ++ G).
  eapply typing_tvar_weakening...
  rewrite map_subst_typ_in_binding_id with (Z := X) (P := ty_var_f Y) (D := G)...
Qed.

Lemma typing_rename : forall x y E t U T G,
    typ G ([(x, U)] ++ E) (open_exp_wrt_exp t (exp_var_f x)) T ->
    x `notin` dom G \u dom E \u fv_exp_in_exp t ->
    y `notin` dom G \u dom E \u fv_exp_in_exp t ->
    typ G ([(y, U)] ++ E) (open_exp_wrt_exp t (exp_var_f y)) T.
Proof with eauto.
  introv TyX ? ?.
  destruct (x == y); substs...

  assert (Wfe : wfe G ([(x, U)] ++ E))...
  inverts Wfe.

  rewrite (subst_exp_in_exp_intro x)...
  rewrite_env (nil ++ [(y, U)] ++ E).
  apply typing_through_subst_exp_in_exp with (U := U)...
  rewrite_env ([(x, U)] ++ [(y, U)] ++ E).
  eapply typing_var_weakening...
Qed.

(* ********************************************************************** *)
(** * Enhance auto *)

Hint Rewrite mtsubst_ty_open msubst_ty_open_wrt_ty mtsubst_nat mtsubst_top mtsubst_arr mtsubst_forall mtsubst_and mtsubst_rcd mtsubst_open mtsubst_tabs mtsubst_abs msubst_tabs msubst_abs mtsubst_app msubst_unit msubst_lit msubst_app  mtsubst_tapp msubst_tapp mtsubst_pair msubst_pair mtsubst_lit mtsubst_unit mtsubst_capp msubst_capp trans_open_sty trans_subst_sty : lr_rewrite.

Hint Resolve mono_lc poly_lc swft_wft swft_wft_nil swft_type lc_sty_ty fv_sty_nil multi_red_tapp multi_red_capp multi_red_pair multi_red_app1 same_eq same_sym star_one star_trans swft_change swft_from_swfte swft_from_swfe mtsubst_swft swft_subst_ctx.


Require Import VST.floyd.proofauto.
Require Import sqrt1.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Require Import float_lemmas sqrt1_f.

Definition sqrt_newton_spec :=
   DECLARE _sqrt_newton
   WITH x: float32
   PRE [ tfloat ]
       PROP () PARAMS (Vsingle x) SEP ()
    POST [ tfloat ]
       PROP () RETURN (Vsingle (fsqrt x)) SEP ().

Definition Gprog : funspecs :=
         [sqrt_newton_spec].

Lemma body_sqrt_newton:  semax_body Vprog Gprog f_sqrt_newton sqrt_newton_spec.
Proof.
start_function.
forward_if. (* if (x<=0) *)
forward.  (*  return 0; *) {
   entailer!.
   unfold fsqrt.
   change (float_of_Z ?A) with (Float32.of_int (Int.repr A)).
   change float_cmp with Float32.cmp.
   rewrite H. auto.
}
pose (t := if Float32.cmp Cge x (Float32.of_int (Int.repr 1))
                    then x else Float32.of_int (Int.repr 1)).
forward_if  (* if (x >= 1) *)
     (temp _t'1 (Vsingle t)).
forward. (* t'1=x; *) {
  entailer!.
  subst t; rewrite H0; auto.
}
forward. (* t'1=1; *) {
  entailer!.
  subst t; rewrite H0; auto.
}
forward. (* y = t'1; *)
forward_loop
   (EX y:float32, PROP(main_loop (x,y) = fsqrt x)
                 (LOCAL (temp _x (Vsingle x); temp _y (Vsingle y)) SEP()))
 continue: (EX y z:float32, PROP((if Float32.cmp Clt y z
                                then main_loop  (x,y) else y) = fsqrt x)
                     (LOCAL (temp _x (Vsingle x); temp _y (Vsingle y);
                                  temp _z (Vsingle z))
                     SEP()))
   break: (PROP()(LOCAL (temp _y (Vsingle (fsqrt x))) SEP())).
-  (* Prove that precondition implies loop invariant *)
Exists t.
entailer!.
unfold fsqrt.
change (float_of_Z ?A) with (Float32.of_int (Int.repr A)).
change float_cmp with Float32.cmp.
rewrite H.
fold t. auto.
-  (* body of loop *)
Intros y.
forward. (* z=y; *)
forward. (* y=(z+x/z)/2; *)
    (* end of loop body; prove invariant is reestablished *)
do 2 EExists; entailer!.
rewrite main_loop_equation in H0.
auto.
-  (* ... while (y<z);  *)
Intros y z.
forward_if.  (* if (y<z) *)
+
forward.  (* skip; *)
Exists y.
entailer!.
rewrite H1 in H0.
auto.
+
forward.  (* break; *)
entailer!.
rewrite H1 in H0.
f_equal; auto.
-
forward. (* return y; *)
Qed.