Require Export List.
Require Import Bool.

Lemma in_fold_cons : forall (A B:Type) (f:A->B) l,
  fold_right (fun a q => (f a)::q) nil l = map f l.
Proof.
  induction l; simpl; intros; auto.
Qed.

Lemma fold_right_map : forall (A B C:Type) (f:A->B->B) (g:C->A) (b:B) l,
  fold_right f b (map g l) = fold_right (fun a => f (g a)) b l.
Proof.
  induction l; simpl; auto.
  rewrite IHl; auto.
Qed.

Lemma fold_right_eq : forall (A B:Type) (f1 f2:A->B->B) (b:B) l,
  (forall a, f1 a = f2 a) ->
  fold_right f1 b l = fold_right f2 b l.
Proof.
  induction l; simpl; intros; auto.
   rewrite IHl ;auto.
   rewrite H; auto.
Qed.

Lemma fold_right_eq2 : forall (A B:Type) (f1 f2:A->B->B) (b:B) l,
  (forall a b, f1 a b = f2 a b) ->
  fold_right f1 b l = fold_right f2 b l.
Proof.
  induction l; simpl; intros; auto.
   rewrite IHl ;auto.
Qed.

Lemma in_map_inv : forall (A B:Type) x (f:A->B) l,
  In x (map f l) -> exists y, x=f y /\ In y l.
Proof.
 induction l; simpl; intuition.
 subst; eauto.
 destruct H; intuition eauto.
Qed.

Lemma in_flat_map_inv : forall (A B:Type) (f:A->list B) b l,
  In b (flat_map f l) -> exists a,
    In b (f a) /\ In a l.
Proof.
  induction l; simpl; intros.
  destruct H.
  destruct (@in_app_or _ _  _ _ H).
  exists a; split; auto.
  destruct (IHl H0).
  intuition eauto.
Qed.

Lemma in_flat_map : forall (A B:Type) (f:A->list B) b a l,
  In b (f a) -> In a l -> In b (flat_map f l).
Proof.
  induction l; simpl; intros.
  destruct H0.
  destruct H0; apply in_or_app.
  subst; auto.
  auto.
Qed.

Lemma fold_right_app : forall (B C:Type)(f:B->C->C) c l1 l2,
  fold_right f c (l1++l2) =
     fold_right f (fold_right f c l2) l1.
Proof.
  induction l1; simpl; auto; intros.
  rewrite IHl1; auto.
Qed.

Lemma fold_right_flat_map : forall (A B C:Type)(f:B->C->C)(g:A->list B) c l,
  fold_right f c (flat_map g l) =
     fold_right (fun a c => fold_right f c (g a)) c l.
Proof.
  induction l; simpl; auto.
  rewrite fold_right_app.
  rewrite IHl; auto.
Qed.

Section assoc.

Variable A B :Type.
Variable Aeq : A -> A -> bool.
Variable Aeq_spec : forall x y, if Aeq x y then x = y else x <> y.
Implicit Types x a : A.
Implicit Types l : list (A*B).

Fixpoint assoc x l {struct l} : option B :=
  match l with
    nil => None
  | (a,b)::q =>
     if (Aeq x a) then Some b else (assoc x q)
  end.

Fixpoint mem_assoc x l {struct l} : bool :=
  match l with
    nil => false
  | (a,_)::q =>
     if (Aeq x a) then true else (mem_assoc x q)
  end.

Fixpoint remove_assoc x l {struct l} : list (A*B) :=
  match l with
    nil => nil
  | (a,b)::q => if (Aeq x a) then q else (a,b)::(remove_assoc x q)
  end.

Fixpoint remove_all_assoc x l {struct l} : list (A*B) :=
  match l with
    nil => nil
  | (a,b)::q => if (Aeq x a) then remove_all_assoc x q
                else (a,b)::(remove_all_assoc x q)
  end.

Fixpoint modify_assoc x l (f:option B->option B) {struct l} : list (A*B) :=
  match l with
    nil => match f None with
             None => nil
           | Some b => (x,b)::nil
           end
  | (a,b)::q => if (Aeq x a) then
                  match f (Some b) with
                    None => remove_all_assoc x q
                  | Some b => (a,b)::q
                  end
                else (a,b)::(modify_assoc x q f)
  end.

  Lemma assoc_remove_all_assoc1 : forall a l,
    assoc a (remove_all_assoc a l) = None.
  Proof.
    induction l; simpl; auto.
    destruct a0.
    assert (UU:=Aeq_spec a a0);destruct (Aeq a a0); simpl; subst; auto.
    assert (UU':=Aeq_spec a a0);destruct (Aeq a a0);simpl; subst; intuition.
  Qed.

  Lemma assoc_remove_all_assoc2 : forall x a l,
    x <> a ->
    assoc x (remove_all_assoc a l) = assoc x l.
  Proof.
    induction l; simpl; intros; auto.
    destruct a0.
    assert (UU:=Aeq_spec a a0);destruct (Aeq a a0); simpl; subst.
    assert (UU:=Aeq_spec x a0);destruct (Aeq x a0); simpl; subst; intuition.
    assert (UU':=Aeq_spec x a0);destruct (Aeq x a0); simpl; subst; intuition.
  Qed.

  Lemma assoc_modify_assoc1 : forall l x f,
    assoc x (modify_assoc x l f) = f (assoc x l).
  Proof.
    induction l; simpl; intros.
    destruct (f None); simpl; auto.
    assert (UU:=Aeq_spec x x);destruct (Aeq x x); intuition.
    destruct a.
    assert (UU:=Aeq_spec x a);destruct (Aeq x a); subst; simpl.
    destruct f; simpl.
     assert (UU:=Aeq_spec a a);destruct (Aeq a a); intuition.
    apply assoc_remove_all_assoc1.
    assert (UU':=Aeq_spec x a);destruct (Aeq x a);intuition.
  Qed.

  Lemma assoc_modify_assoc2 : forall l x a f,
    x <> a ->
    assoc x (modify_assoc a l f) = assoc x l.
  Proof.
    induction l; simpl; intros.
    destruct f; simpl; auto.
     assert (UU:=Aeq_spec x a);destruct (Aeq x a); intuition.
    destruct a.
    assert (UU:=Aeq_spec x a);destruct (Aeq x a); intuition.
    assert (UU':=Aeq_spec a0 a);destruct (Aeq a0 a); subst.
    intuition. simpl.
    assert (UU:=Aeq_spec a a);destruct (Aeq a a); intuition.
    assert (UU':=Aeq_spec a0 a);destruct (Aeq a0 a); subst.
    destruct f; simpl.
   assert (UU':=Aeq_spec x a);destruct (Aeq x a); intuition.
   apply assoc_remove_all_assoc2; auto.
   simpl.   assert (VV':=Aeq_spec x a);destruct (Aeq x a); intuition.
  Qed.

End assoc.

Implicit Arguments assoc.
Implicit Arguments mem_assoc.
Implicit Arguments remove_assoc.
Implicit Arguments remove_all_assoc.
Implicit Arguments modify_assoc.

Section assoc_distinct.

Variable A B :Type.
Variable Aeq : A -> A -> bool.
Variable Aeq_spec : forall x y, if Aeq x y then x = y else x <> y.
Implicit Types x a : A.
Implicit Types l : list (A*B).

Inductive in_dom x : list (A*B) -> Prop :=
  in_dom_head : forall b l, in_dom x ((x,b)::l)
| in_dom_queue : forall a b l,
    in_dom x l -> in_dom x ((a,b)::l).

Inductive distinct_key : list (A*B) -> Prop :=
  distinct_key_nil : distinct_key nil
| distinct_key_cons : forall a b l,
    ~ in_dom a l -> distinct_key l -> distinct_key ((a,b)::l).

Record dlist : Type := mk_dlist {
  dlist_list :> list (A*B);
  dlist_distinct_key :> distinct_key dlist_list }.

Definition dassoc x (l:dlist) := assoc Aeq x l.

Fixpoint dmodify_assoc_aux x l (f:option B->option B) {struct l} : list (A*B) :=
  match l with
    nil => match f None with
             None => nil
           | Some b => (x,b)::nil
           end
  | (a,b)::q => if (Aeq x a) then
                  match f (Some b) with
                    None => q
                  | Some b => (a,b)::q
                  end
                else (a,b)::(dmodify_assoc_aux x q f)
  end.

Lemma in_dom_dmodify_assoc_aux : forall l a x f,
   in_dom a (dmodify_assoc_aux x l f) ->
   x=a \/ in_dom a l.
Proof.
  induction l; simpl; intros.
  destruct (f None); inversion_clear H; auto.
  destruct a.
  assert (UU:= Aeq_spec x a);destruct (Aeq x a).
  subst; destruct (f (Some b)).
  inversion_clear H; auto.
  right; constructor 2; auto.
  right; constructor 2; auto.
  inversion_clear H.
  right; constructor 1; auto.
  destruct (IHl _ _ _ H0); subst; auto.
  right; right; auto.
Qed.

Lemma dmodify_assoc_aux_distinct_key : forall x l f,
  distinct_key l -> distinct_key (dmodify_assoc_aux x l f).
Proof.
  induction 1; simpl.
  destruct f; simpl; repeat constructor.
  intros H; inversion H.
  assert (UU:=Aeq_spec x a);destruct (Aeq x a); subst; simpl.
  destruct (f (Some b)); auto.
  constructor; auto.
  constructor; auto.
  intros H'; elim H.
  destruct (in_dom_dmodify_assoc_aux _ _ _ _ H'); intuition.
Qed.

Definition dmodify_assoc x (l:dlist) f : dlist :=
  mk_dlist (dmodify_assoc_aux x l f) (dmodify_assoc_aux_distinct_key x l f l).

Lemma assoc_not_in_dom : forall l x,
  ~ in_dom x l -> assoc Aeq x l = None.
Proof.
  induction l; simpl; intros; auto.
  destruct a.
  assert (UU := Aeq_spec x a);destruct (Aeq x a).
  elim H; subst; constructor 1.
  apply IHl; intro; elim H; constructor 2; auto.
Qed.

  Lemma assoc_dmodify_assoc_aux1 : forall l x f,
    distinct_key l ->
    assoc Aeq x (dmodify_assoc_aux x l f) = f (assoc Aeq x l).
  Proof.
    induction l; simpl; intros.
    destruct (f None); simpl; auto.
    assert (UU:= Aeq_spec x x); destruct  (Aeq x x);intuition.
    destruct a.
    assert (UU:= Aeq_spec x a); destruct (Aeq x a); subst; simpl.
    destruct f; simpl.
     assert (UU:= Aeq_spec a a); destruct  (Aeq a a);intuition.
    apply assoc_not_in_dom; inversion H; auto.
    assert (UU':= Aeq_spec x a);destruct (Aeq x a); inversion H; intuition.
  Qed.

  Lemma assoc_dmodify_assoc1 : forall (l:dlist) x f,
    dassoc x (dmodify_assoc x l f) = f (dassoc x l).
  Proof.
    unfold dassoc; destruct l; simpl; intros.
    apply assoc_dmodify_assoc_aux1; auto.
  Qed.

  Lemma assoc_dmodify_assoc_aux2 : forall l x a f,
    distinct_key l ->
    x <> a ->
    assoc Aeq x (dmodify_assoc_aux a l f) = assoc Aeq x l.
  Proof.
    induction l; simpl; intros.
    destruct f; simpl; auto.
    assert (UU:= Aeq_spec x a);destruct (Aeq x a); intuition.
    destruct a.
    assert (UU:= Aeq_spec a0 a);destruct (Aeq a0 a); subst; simpl; intuition.
    destruct f; simpl; auto.
    assert (UU:= Aeq_spec x a);destruct (Aeq x a); intuition.
    assert (UU:= Aeq_spec x a);destruct (Aeq x a); intuition.
    assert (UU':= Aeq_spec x a);destruct (Aeq x a); intuition.
   inversion_clear H;auto.
  Qed.

  Lemma assoc_dmodify_assoc2 : forall (l:dlist) x a f,
    x <> a ->
    dassoc x (dmodify_assoc a l f) = dassoc x l.
  Proof.
    unfold dassoc; destruct l; simpl; intros.
    apply assoc_dmodify_assoc_aux2; auto.
  Qed.

  Definition dnil : dlist := mk_dlist nil distinct_key_nil.

  Lemma assoc_dnil : forall x, assoc Aeq x dnil = None.
  Proof.
    unfold dnil; simpl; auto.
  Qed.

  Lemma in_in_dom : forall a b l, In (a,b)l -> in_dom a l.
  Proof.
    induction l; simpl; intuition;
    subst; constructor; auto.
  Qed.

  Lemma in_dassoc_prop1 : forall x b (l:dlist),
    In (x,b) l -> dassoc x l = Some b.
  Proof.
    destruct l as [l Hl]; unfold dassoc.
    induction l; simpl; intros.
    elim H.
    destruct H; subst.
    assert (UU:= Aeq_spec x x);destruct (Aeq x x); intuition.
    destruct a.
    assert (UU:= Aeq_spec x a);destruct (Aeq x a); subst.
    inversion_clear Hl.
    elim H0; apply in_in_dom with b; auto.
    simpl in IHl.
    rewrite IHl; auto.
    inversion_clear Hl; auto.
  Qed.

  Lemma in_assoc_prop : forall x b l,
    assoc Aeq x l = Some b -> In (x,b) l.
  Proof.
    induction l; simpl; intros.
    discriminate.
    destruct a.
    assert (UU:=Aeq_spec x a);destruct (Aeq x a).
    injection H; intros; subst; auto.
    auto.
  Qed.

  Lemma in_dassoc_prop2 : forall x b (l:dlist),
    dassoc x l = Some b -> In (x,b) l.
  Proof.
    destruct l as [l Hl]; simpl; intros.
    apply in_assoc_prop; auto.
  Qed.

End assoc_distinct.

Implicit Arguments dmodify_assoc.
Implicit Arguments dassoc.

Section for_all.

  Variable A : Type.
  Variable test : A -> bool.

  Definition for_all (l:list A) : bool :=
    fold_right
    (fun a => andb (test a)) true l.

  Lemma for_all_true : forall l,
    for_all l = true -> forall a, In a l -> test a = true.
  Proof.
    induction l; simpl; intros.
    elim H0.
    destruct (andb_prop _ _ H).
    destruct H0; subst; auto.
  Qed.

  Lemma for_all_correct : forall l,
    if for_all l
      then forall a, In a l -> test a = true
      else ~ forall a, In a l -> test a = true.
  Proof.
    induction l; simpl; intros.
    elim H.
    case_eq (test a); simpl; intros.
    destruct (for_all l); intuition.
    subst; auto.
    intuition.
    rewrite H0 in H; auto; discriminate.
  Qed.

  Lemma true_for_all : forall l,
    (forall a, In a l -> test a = true) -> for_all l = true.
  Proof.
    unfold for_all.
    induction l; auto.
    intros.
    replace (fold_right (fun a0 : A => andb (test a0)) true (a::l)) with
    (test a && fold_right (fun a0 : A => andb (test a0)) true l); auto.
    apply andb_true_intro; split. apply H; apply in_eq.
    apply IHl. intros. apply H. apply in_cons; auto.
  Qed.

End for_all.

  Definition dlist_for_all (A B:Type) (test:A->B->bool) (l:dlist A B) : bool :=
    for_all (A*B) (fun p => test (fst p) (snd p)) l.

  Lemma dlist_for_all_correct : forall A B (Aeq : A -> A -> bool),
    (forall x y, if Aeq x y then x = y else x <> y) ->
    forall test l,
    if dlist_for_all A B test l
    then forall a b, dassoc Aeq a l = Some b -> test a b = true
    else ~ forall a b, dassoc Aeq a l = Some b -> test a b = true.
  Proof.
    intros; unfold dlist_for_all.
    generalize (for_all_correct _ (fun p : A * B => test (fst p) (snd p)) l);
      destruct (for_all _ (fun p : A * B => test (fst p) (snd p)) l); simpl; intros.
    apply (H0 (a,b)).
    eapply in_assoc_prop; eauto.
    intro; elim H0; clear H0; intros.
    destruct a; simpl.
    apply H1.
    apply in_dassoc_prop1; auto.
  Qed.

Definition compare (A B:Type) (Aeq : A -> A -> bool)
  (test:option B->option B->bool) (l1 l2:dlist A B) : bool :=
  dlist_for_all A B (fun k a1 => test (Some a1) (dassoc Aeq k l2)) l1
  &&
  dlist_for_all A B (fun k a2 => test (dassoc Aeq k l1)  (Some a2)) l2.

  Lemma compare_correct : forall A B (Aeq : A -> A -> bool),
    (forall x y, if Aeq x y then x = y else x <> y) ->
    forall f l1 l2,
    f None None = true ->
    if compare A B Aeq f l1 l2
      then forall k, f (dassoc Aeq k l1) (dassoc Aeq k l2) = true
      else ~ forall k, f (dassoc Aeq k l1) (dassoc Aeq k l2) = true.
  Proof.
    unfold compare; intros.
    generalize (dlist_for_all_correct A B Aeq H (fun (k : A) (a1 : B) => f (Some a1) (dassoc Aeq k l2)) l1);
      destruct (dlist_for_all A B (fun (k : A) (a1 : B) => f (Some a1) (dassoc Aeq k l2)) l1); simpl; intros.
    generalize (dlist_for_all_correct A B Aeq H (fun (k : A) (a2 : B) => f (dassoc Aeq k l1) (Some a2)) l2);
      destruct (dlist_for_all A B (fun (k : A) (a2 : B) => f (dassoc Aeq k l1) (Some a2)) l2); simpl; intros.
    generalize (H1 k); clear H1; generalize (H2 k); clear H2; intros.
    destruct (dassoc Aeq k l1); auto.
    destruct (dassoc Aeq k l2); auto.
    intro; elim H2; clear H2; intros.
    rewrite <- H2; auto.
    intro; elim H1; clear H1; intros.
    rewrite <- H1; auto.
  Qed.


(*
D3. The Addition Theorem of Lemke and Kleitman
==============================================
*)

From graph_pebbling Require Import
  A_primitives
  B_pebbling
  C3_divisor_lattice
  D1_zero_sum_sequence
  D2_pebbling_construction.

Section Lemke_Kleitman.

Variable d : nat.

Definition well_placed p l :=
  l ≠ [] ∧ p ∣ summation l ∧ summation (gcd d <$> l) ≤ p.

Lemma gcd_pebbling_step p k (ls : list (list nat)) :
  p ≠ 0 -> k ≠ 0 -> Forall (well_placed p) ls -> length ls = k ->
  ∃ l, l ⊆+ concat ls ∧ well_placed (k * p) l.
Proof.
intros Hp Hk H1_ls H2_ls; pose (f l := summation l / p).
edestruct zero_sum_sublist with (l:=f <$> ls) as (l & H1 & H2 & H3).
- apply non_empty_length; rewrite fmap_length, H2_ls; done.
- apply non_empty_length in H1; revert H3; rewrite fmap_length, H2_ls; intros.
  apply sublist_fmap_inv in H2 as (ls' & H2 & ->); rewrite fmap_length in H1.
  exists (concat ls'); repeat split.
  + apply sublist_submseteq, sublist_concat; done.
  + (* The result is non-empty. *)
    apply non_empty_length, non_empty_inv in H1 as [l H1].
    assert (Hl : well_placed p l).
    * eapply list.Forall_forall; [done|].
      eapply elem_of_submseteq; [|apply sublist_submseteq]; done.
    * destruct Hl as (Hl & _ & _); apply non_empty_inv in Hl as [i Hi].
      eapply non_empty_elem, elem_of_concat; done.
  + (* The result is a multiple of k*p. *)
    destruct H3 as [m H3]; exists m; unfold f in *.
    eapply submseteq_Forall in H1_ls; [|apply sublist_submseteq; done].
    rewrite (assoc Nat.mul), <-H3; revert Hp H1_ls; clear; intros Hp.
    induction ls' as [|l ls]; cbn; inversion_clear 1; [done|].
    rewrite summation_app, right_distr, <-IHls; [|done].
    destruct H as (_ & [m ->] & _); rewrite Nat.div_mul; done.
  + (* The result GCD sum is at most k*p. *)
    rewrite fmap_concat_comm, <-summation_concat.
    etrans; [apply summation_forall_le with (k:=p)|]; [|rewrite fmap_length].
    * apply list.Forall_forall; intros i Hi.
      apply elem_of_list_fmap in Hi as (l & -> & Hl).
      eapply list.Forall_forall in H1_ls as (_ & _ & H). done.
      eapply elem_of_submseteq; [|apply sublist_submseteq]; done.
    * apply sublist_length in H2; nia.
Qed.

Theorem Lemke_Kleitman_addition_theorem (l : list nat) :
  length l = d -> d > 0 ->
  ∃ l', l' ≠ [] ∧ l' ⊆+ l ∧ d ∣ summation l' ∧ summation (gcd d <$> l') ≤ d.
Proof.
intros Hl Hd; assert (non_zero : Premise (d > 0)) by done.
edestruct @pebbling_construction with (pebbles:=l) as (l' & Hl').
3: rewrite Hl; apply vertex_pebbling_bound_divisor_lattice.
- (* Each number can be placed on a vertex. *)
  intros i Hi.
  assert (H : gcd d i ∣ d) by apply Nat.gcd_divide; exists (dexist (gcd d i) H).
  instantiate (1 := λ v p, well_placed (`v) p); cbn; split; [done|cbn].
  split; rewrite Nat.add_0_r; [apply Nat.gcd_divide|done].
- (* Each step can be constructed. *)
  cbn; intros [p Hp] [q Hq]; cbn; apply bool_decide_unpack in Hp, Hq.
  intros ls [_ [k ->]] H1_ls H2_ls; assert (p ≠ 0) by (destruct Hp; lia).
  rewrite Nat.div_mul in H2_ls; [|done].
  apply gcd_pebbling_step; [done|destruct Hq; nia|done|done].
- cbn in Hl'; destruct Hl' as [H1 (H2 & H3 & H4)]; eexists; done.
Qed.

End Lemke_Kleitman.

Corollary Erdos_Lemke_conjecture (l : list nat) d n :
  length l = d -> d > 0 -> n > 0 -> d ∣ n -> (∀ a, a ∈ l -> a ∣ n) ->
  ∃ l', l' ≠ [] ∧ l' ⊆+ l ∧ d ∣ summation l' ∧ summation l' ≤ n.
Proof.
intros ? ? ? [m Hm] Hl; destruct (Lemke_Kleitman_addition_theorem d l)
as (l' & ? & ? & ? & ?); [done|done|]; exists l'; repeat split; try done.
replace l' with (gcd n <$> l').
- etrans; [apply summation_le with (g:=const m .* gcd d)|].
  + intros a ?; cbn; assert (Ha : a ∈ l) by (eapply elem_of_submseteq; done).
    apply Hl in Ha; rewrite <-Nat.gcd_mul_mono_l, <-Hm; apply Nat.divide_pos_le.
    * destruct (gcd _ _) eqn:E; [|lia]; apply Nat.gcd_eq_0_l in E; lia.
    * apply Nat.gcd_greatest, Nat.divide_mul_r; apply Nat.gcd_divide.
  + rewrite summation_mul_const, Hm; apply Nat.mul_le_mono; done.
- erewrite list_fmap_ext; [apply list_fmap_id|]; intros i a Ha; cbn.
  rewrite Nat.gcd_comm; apply Nat.divide_gcd_iff; [lia|].
  eapply Hl, elem_of_submseteq; [|done].
  eapply elem_of_list_lookup_2; done.
Qed.


Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Relations.Relation_Operators.
Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Arith.Even.
Require Import Coq.Arith.Div2.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Omega.

Definition image_defined {A B} (R: A -> B -> Prop): Prop :=
  forall a, exists b, R a b.

Definition partial_functional {A B} (R: A -> B -> Prop): Prop :=
  forall a b1 b2, R a b1 -> R a b2 -> b1 = b2.

Definition injective {A B} (R: A -> B -> Prop): Prop :=
  forall a1 a2 b, R a1 b -> R a2 b -> a1 = a2.

Definition surjective {A B} (R: A -> B -> Prop): Prop :=
  forall b, exists a, R a b.

Definition function_injective {A B} (f: A -> B): Prop :=
  forall a1 a2, f a1 = f a2 -> a1 = a2.

Definition function_surjective {A B} (f: A -> B): Prop :=
  forall b, exists a, f a = b.

Record injection (A B: Type): Type := {
  inj_R:> A -> B -> Prop;
  im_inj: image_defined inj_R;
  pf_inj: partial_functional inj_R;
  in_inj: injective inj_R
}.

Record surjection (A B: Type): Type := {
  sur_R:> A -> B -> Prop;
  im_surj: image_defined sur_R;
  pf_surj: partial_functional sur_R;
  su_surj: surjective sur_R
}.

Record bijection (A B: Type): Type := {
  bij_R:> A -> B -> Prop;
  im_bij: image_defined bij_R;
  pf_bij: partial_functional bij_R;
  in_bij: injective bij_R;
  su_bij: surjective bij_R
}.

Definition FBuild_injection (A B: Type) (f: A -> B) (H: function_injective f): injection A B.
  apply (Build_injection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
Defined.

Definition FBuild_surjection (A B: Type) (f: A -> B) (H: function_surjective f): surjection A B.
  apply (Build_surjection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
Defined.

Definition FBuild_bijection (A B: Type) (f: A -> B) (H: function_injective f) (H0: function_surjective f): bijection A B.
  apply (Build_bijection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
  + hnf; intros.
    apply H0.
Defined.

Definition injection_trans {A B C} (R1: injection A B) (R2: injection B C): injection A C.
  intros.
  apply (Build_injection _ _ (fun a c => exists b, R1 a b /\ R2 b c)).
  + hnf; intros.
    destruct (im_inj _ _ R1 a) as [b ?].
    destruct (im_inj _ _ R2 b) as [c ?].
    exists c; eauto.
  + hnf; intros a c1 c2 [b1 [? ?]] [b2 [? ?]].
    pose proof pf_inj _ _ R1 a b1 b2 H H1.
    subst b2.
    pose proof pf_inj _ _ R2 b1 c1 c2 H0 H2.
    auto.
  + hnf; intros a1 a2 c [b1 [? ?]] [b2 [? ?]].
    pose proof in_inj _ _ R2 b1 b2 c H0 H2.
    subst b2.
    pose proof in_inj _ _ R1 a1 a2 b1 H H1.
    auto.
Defined.

Definition bijection_sym {A B} (R: bijection A B): bijection B A.
  apply (Build_bijection _ _ (fun a b => R b a)).
  + hnf.
    apply (su_bij _ _ R).
  + hnf; intros.
    apply (in_bij _ _ R b1 b2 a); auto.
  + hnf; intros.
    apply (pf_bij _ _ R b a1 a2); auto.
  + hnf.
    apply (im_bij _ _ R).
Defined.

Definition bijection_refl {A}: bijection A A.
  apply (Build_bijection _ _ eq).
  + hnf; intros.
    eauto.
  + hnf; intros.
    congruence.
  + hnf; intros.
    congruence.
  + hnf; intros.
    eauto.
Defined.

Definition sum_injection {A1 B1 A2 B2} (R1: injection A1 B1) (R2: injection A2 B2): injection (sum A1 A2) (sum B1 B2).
Proof.
  intros.
  apply (Build_injection _ _ (fun a b =>
          match a, b with
          | inl a, inl b => R1 a b
          | inr a, inr b => R2 a b
          | _, _ => False
          end)).
  + hnf; intros.
    destruct a as [a | a].
    - destruct (im_inj _ _ R1 a) as [b ?].
      exists (inl b); auto.
    - destruct (im_inj _ _ R2 a) as [b ?].
      exists (inr b); auto.
  + hnf; intros.
    destruct a as [a | a], b1 as [b1 | b1], b2 as [b2 | b2]; try solve [inversion H | inversion H0].
    - f_equal; apply (pf_inj _ _ R1 a); auto.
    - f_equal; apply (pf_inj _ _ R2 a); auto.
  + hnf; intros.
    destruct a1 as [a1 | a1], a2 as [a2 | a2], b as [b | b]; try solve [inversion H | inversion H0].
    - f_equal; apply (in_inj _ _ R1 _ _ b); auto.
    - f_equal; apply (in_inj _ _ R2 _ _ b); auto.
Defined.

Definition prod_injection {A1 B1 A2 B2} (R1: injection A1 B1) (R2: injection A2 B2): injection (prod A1 A2) (prod B1 B2).
Proof.
  intros.
  apply (Build_injection _ _ (fun a b => R1 (fst a) (fst b) /\ R2 (snd a) (snd b))).
  + hnf; intros.
    destruct (im_inj _ _ R1 (fst a)) as [b1 ?].
    destruct (im_inj _ _ R2 (snd a)) as [b2 ?].
    exists (b1, b2); auto.
  + hnf; intros.
    destruct b1, b2, H, H0.
    pose proof pf_inj _ _ R1 (fst a) _ _ H H0.
    pose proof pf_inj _ _ R2 (snd a) _ _ H1 H2.
    simpl in *; subst; auto.
  + hnf; intros.
    destruct a1, a2, H, H0.
    pose proof in_inj _ _ R1 _ _ _ H H0.
    pose proof in_inj _ _ R2 _ _ _ H1 H2.
    simpl in *; subst; auto.
Defined.

Definition sigT_injection (I: Type) (A: I -> Type) (B: Type) (R: forall i: I, injection (A i) B): injection (sigT A) (I * B).
  apply (Build_injection _ _ (fun a b => projT1 a = fst b /\ (R (projT1 a)) (projT2 a) (snd b))).
  + hnf; intros.
    destruct a as [i a0].
    destruct (im_inj _ _ (R i) a0) as [b0 ?].
    exists (i, b0).
    auto.
  + hnf; intros.
    destruct b1 as [i1 b1]; simpl in H.
    destruct b2 as [i2 b2]; simpl in H0.
    destruct H, H0; subst.
    pose proof pf_inj _ _ (R (projT1 a)) _ _ _ H1 H2.
    subst; auto.
  + hnf; intros.
    destruct b, H, H0; simpl in *; subst.
    destruct a1, a2; simpl in *; subst.
    pose proof in_inj _ _ (R x) _ _ _ H1 H2.
    subst; auto.
Qed.

Definition bijection_injection {A B} (R: bijection A B): injection A B :=
  Build_injection _ _ R (im_bij _ _ R) (pf_bij _ _ R) (in_bij _ _ R).

Definition nat2_nat_bijection: bijection (sum nat nat) nat.
  apply (Build_bijection _ _ (fun n m => match n with | inl n => m = n + n | inr n => m = n + n +1 end)).
  + hnf; intros.
    destruct a; eauto.
  + hnf; intros.
    destruct a; inversion H; inversion H0; auto.
  + hnf; intros.
    destruct a1, a2; inversion H; inversion H0; destruct (lt_eq_lt_dec n n0) as [[? | ?] | ?]; try omega; subst; auto.
  + hnf; intros.
    destruct (Even.even_odd_dec b) as [H | H].
    - rewrite (proj1 (Div2.even_odd_double _)), NPeano.double_twice in H.
      exists (inl (Div2.div2 b)).
      rewrite H at 1. omega.
    - rewrite (proj2 (Div2.even_odd_double _)), NPeano.double_twice in H.
      exists (inr (Div2.div2 b)).
      rewrite H at 1. omega.
Defined.

Definition natnat_nat_bijection: bijection (prod nat nat) nat.
  apply (Build_bijection _ _
          (fun n m => m = match n with | (n1, n2) =>
                            (fix sum (x: nat): nat := match x with | O => O | S x => S x + sum x end)
                              (n1 + n2)
                            + n1
                          end)).
  + hnf; intros.
    destruct a; eauto.
  + hnf; intros.
    destruct a; omega.
  + hnf; intros.
    destruct a1 as [a11 a12], a2 as [a21 a22].
    assert (forall m1 m2, m1 < m2 ->
      (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) m1 + m1 <
      (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) m2).
    {
      intros.
      remember (m2 - m1 - 1) as d; assert (m2 = (S d) + m1) by omega.
      subst m2; clear.
      induction d.
      + simpl.
        omega.
      + simpl in *.
        omega.
    }
    destruct (lt_eq_lt_dec (a11 + a12) (a21 + a22)) as [[HH | HH] | HH].
    - specialize (H1 _ _ HH).
      omega.
    - rewrite HH in H.
      assert (a11 = a21) by omega.
      assert (a12 = a22) by omega.
      subst; auto.
    - specialize (H1 _ _ HH).
      omega.
  + hnf; intros.
    assert (exists s,
        (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) s <= b <
        (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) (S s)).
    {
      induction b.
      + exists 0; simpl.
        omega.
      + destruct IHb as [s ?].
        remember (b - (fix sum (x : nat) : nat :=
                         match x with
                         | 0 => 0
                         | S x0 => S x0 + sum x0
                         end) s) as d.
        destruct (lt_dec d s) as [HH | HH].
        - exists s; simpl in *; omega.
        - exists (S s); simpl in *; omega.
    }
    destruct H as [s ?].
    remember (b - (fix sum (x : nat) : nat :=
                match x with
                | 0 => 0
                | S x0 => S x0 + sum x0
                end) s) as a1.
    exists (a1, s - a1).
    replace (a1 + (s - a1)) with s by omega.
    omega.
Defined.


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

Coq < Section Exercise_Eighteen.

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

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

Unnamed_thm < intros.
1 subgoal

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

Unnamed_thm < elim H.
1 subgoal

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

Unnamed_thm < intro.
1 subgoal

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

Unnamed_thm < intro.
1 subgoal

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

Unnamed_thm < destruct H1.
1 subgoal

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

Unnamed_thm < right.
1 subgoal

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

Unnamed_thm < firstorder.
No more subgoals.

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

Unnamed_thm is defined

Coq <

*)

Section Exercise_Eighteen.
Goal forall a d b f c e:Prop, (((~a \/ d) -> (b -> f)) /\ ((b \/ c) -> (a -> e)) /\ (a \/ b) /\ (~a)) -> (e \/ f).
intros.
elim H.
intro.
intro.
right.
firstorder.
Qed.


Require Export refine.
Require Export parser.

Require Export Station.
Require Export Vehicle.

(** The CyCab example *)

Definition FVehicle: IA := parse
 "IA [s1,s2,s3,s4,s5,s6] (s1) [fstart,start,emrg,far,halt] [pos,reset] [move,stop]
  [s1->(start)s2, s2->(move)s3, s2->(emrg)s5, s3->(pos)s4, s3->(emrg)s5, s4->(far)s2,
  s4->(halt)s1, s4->(emrg)s5, s5->(reset)s1, s1->(fstart)s6, s6->(move)s6, s6->(emrg)s5,
  s6->(stop)s1]".

Eval compute in IAutomaton.b_compatible FVehicle Station.

Definition FVehicle_Station: IA :=IAutomaton.composition FVehicle Station.
Eval compute in :> FVehicle_Station.

(*********** security of FVehicle*Station ******************************************)

(*************************** \Gamma(fstart)=m ****************************)
(* SIR-GNNI at m: true *)
Definition FVehicle_Station_hid_m: IA :=
 IAutomaton.hiding FVehicle_Station (ASet.GenActs [&"emrg",&"reset"]).

Definition FVehicle_Station_res_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction FVehicle_Station (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> FVehicle_Station_hid_m.
Eval compute in :> FVehicle_Station_res_m.
Eval compute in SIRGNNI_refinement FVehicle_Station_res_m FVehicle_Station_hid_m.

(* SME-NI at m: true *)
Definition FVehicle_Station_rep_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement FVehicle_Station (&"tau") (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> FVehicle_Station_rep_m.
Eval compute in SMENI_refinement FVehicle_Station_rep_m FVehicle_Station_hid_m.

(* SIR-GNNI at l: true *)
Definition FVehicle_Station_hid_l: IA :=
  IAutomaton.hiding FVehicle_Station
  (ASet.GenActs [&"emrg",&"start",&"fstart",&"reset"]).

Definition FVehicle_Station_res_l: IA :=
  IAutomaton.hiding
  ( IAutomaton.restriction FVehicle_Station (ASet.GenActs [&"emrg",&"start",&"fstart"]) )
  (ASet.GenActs [&"reset"]).

Eval compute in :>FVehicle_Station_hid_l.
Eval compute in :>FVehicle_Station_res_l.
Eval compute in SIRGNNI_refinement FVehicle_Station_res_l FVehicle_Station_hid_l.

(* SME-NI at l: true *)
Definition FVehicle_Station_rep_l: IA :=
  IAutomaton.hiding
  ( IAutomaton.replacement FVehicle_Station (&"tau") (ASet.GenActs [&"emrg",&"start",&"fstart"]) )
  (ASet.GenActs [&"reset"]).

Eval compute in :>FVehicle_Station_rep_l.
Eval compute in SMENI_refinement FVehicle_Station_rep_l FVehicle_Station_hid_l.


(**************************************************************************************************
* Preservation and Progress for duotyped System-F with duotyping                                    *
* Based on original code by: Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1
* Modifications by Bruno C. d. S. Oliveira, Shaobo Cui and Baber Rehman, January 2020, Coq v8.7.0   *
***************************************************************************************************)

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

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

(** Representation of types *)

Inductive Mode := Sub | Sup.

Definition flip (m : Mode) : Mode :=
  match m with
  | Sub => Sup
  | Sup => Sub
  end.

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

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_tabs : Mode -> typ -> trm -> trm
  | trm_tapp : trm -> typ -> trm.

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

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

Definition open_tt T U := open_tt_rec 0 U T.

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

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

Definition open_te t U := open_te_rec 0 U t.

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

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

Definition open_ee t u := open_ee_rec 0 u t.

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

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

Inductive bind : Set :=
  | bind_tRel : Mode -> typ -> bind
  | bind_typ : typ -> bind.

Notation "X !: m <>: T" := (X ~ bind_tRel m T)
  (at level 23, left associativity) : env_scope.

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

Definition env := LibEnv.env bind.

Definition mode_to_sub m := match m with
  | Sub => typ_top
  | Sup => typ_btm end.

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

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

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

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

(** Binding map term variables to types, and keeps type variables in the environment.
 [x ~: T] is a typing assumption *)

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

Inductive wft : env -> typ -> Prop :=
  | wft_top : forall E,
      wft E typ_top
  | wft_var : forall m T1 E X,
      binds X (bind_tRel m T1) E ->
      wft E (typ_fvar X)
  | wft_int : forall E,
      wft E typ_int
  | wft_btm :forall E,
      wft E typ_btm
  | wft_arrow : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_arrow T1 T2)
  | wft_all : forall L E T m Tn,
      wft E Tn ->
      (forall X, X \notin L ->
        wft (E & X !: m <>: Tn) (T open_tt_var X)) ->
      wft E (typ_all m Tn T).

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

Definition BindPosVariance m1 m2 :=
  match m1 with
    | Sup => m2
    | Sub => flip m2 end.

Definition SelectBound m2 (S1:typ) (S2:typ) :=
  match m2 with
    | Sup => S1
    | Sub => S2 end.

Inductive R : env -> Mode -> typ -> typ -> Prop :=
| SInt : forall E m, okt E -> R E m typ_int typ_int
| STB1 : forall E A m, okt E ->wft E A ->R E m A (mode_to_sub m)
| STB2 : forall E A m, okt E -> wft E A ->R E m (mode_to_sub (flip m)) A
| SFun : forall E A B C D m, R E (flip m) A C -> R E m B D -> R E m (typ_arrow A B) (typ_arrow C D)
| SVarRefl : forall E X m, okt E -> wft E (typ_fvar X) -> R E m (typ_fvar X) (typ_fvar X)
| SVarBnd : forall E X m T F, binds X (bind_tRel m T) E -> wft E T -> R E m T F -> R E m (typ_fvar X) F
| SVarBndFl :  forall E X m T F, binds X (bind_tRel m T) E -> wft E T -> R E m T F -> R E (flip m) F (typ_fvar X)
(* | SVarTrns : forall E X m T1 T2 , R E m T1 (typ_fvar X) -> R E m (typ_fvar X) T2 -> R E m T1 T2 *)
| SAll : forall E L m1 m2 T1 T2 T3 T4, (*wft E T1 -> wft E T2 ->*)
  R E (BindPosVariance m1 m2) T1 T2 ->
(forall X, X \notin L ->
  R (E&(X !: m1 <>: (SelectBound m2 T1 T2))) m2 (T3 open_tt_var X) (T4 open_tt_var X))->
  R E m2 (typ_all m1 T1 T3) (typ_all m1 T2 T4).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x (bind_typ T) E ->
      typing E (trm_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x, x \notin L ->
        typing (E & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_abs V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (trm_app e1 e2) T2
  | typing_tabs : forall L m Tk E e T,
      (forall X, X \notin L ->
        typing (E & X!: m <>: Tk) (e open_te_var X) (T open_tt_var X)) ->
      typing E (trm_tabs m Tk e) (typ_all m Tk T)
  | typing_tapp : forall m E Tb T1 T2 e,
    typing E e (typ_all m Tb T1) ->
    R E m T2 Tb ->
    typing E (trm_tapp e T2) (open_tt T1 T2)
  | typing_sub : forall S E e T,
      typing E e S ->
      R E Sub S T ->
      wft E T ->
      typing E e T.

(** Values *)

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

(** One-step reduction *)

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

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

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

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

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

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

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

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

Fixpoint fv_te (e : trm) {struct e} : vars :=
  match e with
  | trm_abs V e1  => (fv_tt V) \u (fv_te e1)
  | trm_app e1 e2 => (fv_te e1) \u (fv_te e2)
  | trm_tabs m T e1   =>  (fv_tt T) \u (fv_te e1)
  | trm_tapp e1 V => (fv_tt V) \u (fv_te e1)
  | _ => \{}
  end.

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

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

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

Fixpoint subst_tt (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top         => typ_top
  | typ_int         => typ_int
  | typ_btm         => typ_btm
  | typ_bvar J      => typ_bvar J
  | typ_fvar X      => If X = Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all m T1 T2  => typ_all m (subst_tt Z U T1) (subst_tt Z U T2)
  end.

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

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

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

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

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

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

(** Constructors as hints. *)

Hint Constructors type term wft ok okt value red.

Hint Resolve
  STB1 STB2 SInt SFun SVarRefl
  typing_var typing_app typing_sub typing_tapp.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Lemma open_tt_rec_type_core : forall T j V U i, i <> j ->
  (open_tt_rec j V T) = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof.
  induction T; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

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

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

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

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

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

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

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

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

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

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

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

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

Lemma open_te_rec_type_core : forall e j Q i P, i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
   e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H0; f_equal*;
  match goal with H: ?i <> ?j |- ?t = open_tt_rec ?i _ ?t =>
   apply* (@open_tt_rec_type_core t j) end.
Qed.

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

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

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

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

Lemma subst_te_open_te : forall e T X U, type U ->
  subst_te X U (open_te e T) =
  open_te (subst_te X U e) (subst_tt X U T).
Proof.
  intros. unfold open_te. generalize 0.
  induction e; intros; simpls; f_equal*;
  autos* subst_tt_open_tt_rec.
Qed.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(** Substitutions preserve local closure. *)

Lemma subst_tt_type : forall T Z P,
  type T -> type P -> type (subst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply type_all with (L:=L \u \{Z}). apply* IHtype.
  intros. rewrite* subst_tt_open_tt_var.
Qed.

Lemma subst_te_term : forall e Z P,
  term e -> type P -> term (subst_te Z P e).
Proof.
  lets: subst_tt_type. induction 1; intros; simpl; auto.
  apply_fresh* term_abs as x. rewrite* subst_te_open_ee_var.
  apply term_tabs with (L:=L \u \{Z}). auto.
  intros. rewrite* subst_te_open_te_var.
Qed.

Lemma subst_ee_term : forall e1 Z e2,
  term e1 -> term e2 -> term (subst_ee Z e2 e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
  apply term_tabs with (L:=L \u \{Z}). auto. intros. rewrite* subst_ee_open_te_var.
Qed.

Hint Resolve subst_tt_type subst_te_term subst_ee_term.

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

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

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

(** Through weakening *)

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

(** Through strengthening *)

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

(** Through type substitution *)

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

(** Through type reduction *)

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

(** Through narrowing *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(** Inversion lemma *)

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

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

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

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

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

Hint Immediate okt_push_typ_type okt_push_sub_type.
(** Through strengthening *)

Lemma okt_strengthen : forall x T (E F:env),
  okt (E & x ~: T & F) ->
  okt (E & F).
Proof.
 introv O. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_typ_inv O).
  rewrite concat_assoc in *.
   lets: okt_push_inv O. destruct H; subst.
     destruct H. destruct H. subst.
     lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_tvr. applys* wft_strengthen. destruct* H0.
    destruct H. subst. lets (?&?): (okt_push_typ_inv O).
    applys~ okt_typ. applys* wft_strengthen. destruct* H0.
Qed.

Lemma okt_strengthen_l : forall E F,
  okt (E&F) ->
  okt E.
Proof. introv OKC. induction F using env_ind.
  rewrite concat_empty_r in *. auto.
  rewrite concat_assoc in *.
   lets: okt_push_inv OKC. destruct H; try destruct H; subst.
    destruct H. subst.
     lets (?&?): (okt_push_tvr_inv OKC). apply IHF. apply H.
      lets (?&?): (okt_push_typ_inv OKC). apply* IHF.
Qed.

Lemma okt_subst_tb : forall Q m Z P (E F:env),
  okt (E & Z!: m <>: Q & F) ->
  wft E P ->
  okt (E & map (subst_tb Z P) F).
Proof.
 introv O W. induction F using env_ind.
  rewrite map_empty. rewrite concat_empty_r in *.
   lets*: (okt_push_tvr_inv O).
  rewrite map_push. rewrite concat_assoc in *.
   lets : okt_push_inv O. destruct H; try destruct H; subst.
   destruct H. subst. lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_tvr. destruct* H0. autos*.
      lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. apply* wft_subst_tb.
Qed.

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

(** Automation *)

Hint Resolve okt_narrow okt_subst_tb wft_weaken.
Hint Immediate okt_strengthen.

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

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

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

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

(** The subtyping relation is restricted to well-formed objects. *)
Lemma sub_regular : forall E m T1 T2,
  R E m T1 T2 -> okt E /\ wft E T1 /\ wft E T2.
Proof. introv Rel.
induction Rel; autos*.
  - destruct m; autos*.
  - destruct m; autos*.
  - split. destruct IHRel; auto. split; apply_fresh* wft_all as Y.
    destruct (H0 Y); auto. destruct H2. destruct m2; simpl in H2.
    apply_empty* (@wft_narrow m1 T2); autos. autos.
    destruct (H0 Y); auto. destruct H2. destruct m2; simpl in H3.
    autos. apply_empty* (@wft_narrow m1 T1); autos. Qed.

Lemma sub_wft : forall E m T1 T2,
  R E m T1 T2 -> wft E T1 /\ wft E T2.
Proof. intros. apply sub_regular in H. destruct H; auto. Qed.

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

Lemma typing_regular : forall E e T,
  typing E e T -> okt E /\ term e /\ wft E T.
Proof.
  induction 1; splits*.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_typ_inv.
   apply_fresh* term_abs as y.
     pick_fresh y. specializes H0 y. destructs~ H0.
      forwards*: okt_push_typ_inv.
     specializes H0 y. destructs~ H0.
   pick_fresh y. specializes H0 y. destructs~ H0.
    apply* wft_arrow.
      forwards*: okt_push_typ_inv.
      apply_empty* wft_strengthen.
  destructs IHtyping1. inversion* H3.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_tvr_inv.
  apply term_tabs with (L:=L).
   pick_fresh X. destruct H0 with (X:=X).
  autos. apply okt_push_tvr_inv in H1. destruct H1. destruct H3.
  apply wft_type in H3. auto.
   intros.
      forwards~ K: (H0 X). destructs K.
       forwards*: okt_push_tvr_inv.
   apply_fresh* wft_all as Y.
     pick_fresh y. forwards~ K: (H0 y). destructs K.
      forwards*: okt_push_tvr_inv.
     forwards~ K: (H0 Y). destructs K.
      forwards*: okt_push_tvr_inv.
  apply term_tapp; autos*. eapply wft_type. apply sub_wft in H0.
  destruct H0. apply H0.
  destruct IHtyping. destruct H2. inversion H3.  subst.
   applys* wft_open T2. apply sub_wft in H0. destruct* H0.
Qed.

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

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

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

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

(** Automation *)

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

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

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

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

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

(* ********************************************************************** *)
(** Reflexivity (1) *)
Lemma refl : forall E m A,
  okt E ->
  wft E A ->
  R E m A A.
  introv OK WFT. lets W:(wft_type WFT). gen E. gen m.
  induction W; intros; inversion WFT; eauto.
  - destruct m. apply* STB1. apply* STB2.
  - destruct m. apply* STB2. apply* STB1.
  - subst. pick_fresh X. apply SAll with (L:=L\u L0 \u dom E).
    auto. intros v Hv. apply notin_union_r in Hv. destruct Hv.
    apply notin_union_r in H2. destruct H2.
    apply H0 with (E:=E & v!:m<>:(SelectBound m0 T1 T1)); auto.
    destruct m0; auto.
    destruct m0; auto.
Defined.

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

Lemma sub_weakening : forall m E F G S T,
   R (E & G) m S T ->
   okt (E & F & G) ->
   R (E & F & G) m S T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok; auto.
  (* case: fvar trans *)
  apply SVarBnd with (T:=T). apply* binds_weaken.
  autos. autos.
  apply SVarBndFl with (T:=T). apply* binds_weaken.
  autos. autos.
  (* case: all *)
  apply SAll with (L:=L \u (dom E) \u (dom F) \u (dom G)). auto. intros.
  assert (E & F & G & X !: m1 <>: (SelectBound m2 T1 T2) = E&F&(G & X !: m1<>:(SelectBound m2 T1 T2))).
  rewrite concat_assoc. reflexivity. rewrite H2. apply H0; auto.
  rewrite concat_assoc. auto. rewrite concat_assoc. apply* okt_tvr.
  destruct m2; simpl. auto. auto.
Qed.

(* ********************************************************************** *)
(** Symmetry*)

Lemma m_flip_inv : forall m, m = flip (flip m).
Proof. intros. destruct* m. Qed.

Lemma sym1 : forall E A B m, R E m A B -> R E (flip m) B A.
  intros. induction H.
  - autos.
  - destruct m; apply* STB2.
  - destruct m; apply* STB1.
  - apply* SFun.
  - apply* SVarRefl.
  - apply* SVarBndFl.
  - apply SVarBnd with (T:=T); try rewrite <- m_flip_inv; auto.
  - apply* SAll. destruct m1; simpl. simpl in IHR. auto.
    simpl in IHR. auto. intros. apply H1 in H2. destruct m2; simpl;
    simpl in H2; auto.
Defined.

Corollary sym2 : forall E A B m, R E m A B <-> R E (flip m) B A.
destruct m; split; apply sym1.
Defined.

Corollary sym : forall E A B, R E Sub A B <-> R E Sup B A.
  intros. split; apply sym1.
Defined.

(** In parentheses are given the label of the corresponding
  lemma in the description of the POPLMark Challenge. *)
Lemma TopBtmMustEq1 : forall m T1 T2 E,
okt E -> wft E T2 -> R E m T1 (mode_to_sub (flip m)) -> R E m T1 T2.
Proof. introv OK WF H. remember (mode_to_sub (flip m)) as T'.
  induction H; try destruct m; inversion* HeqT'.
  - subst. eapply SVarBnd. apply H. auto. auto.
  - subst. eapply SVarBnd. apply H. auto. auto.
  - destruct m2; inversion H3.  Qed.

Lemma TopBtmMustEq2 : forall m T1 T2 E,
okt E -> wft E T2 -> R E m (mode_to_sub m) T1  -> R E m T2 T1.
Proof. introv OK WF H. remember (mode_to_sub m) as T'.
  induction H; try destruct m; inversion* HeqT'.
  - subst. eapply SVarBndFl. apply H. auto. apply TopBtmMustEq1 with (T2:=T2) in H1; auto.
  - subst. eapply SVarBndFl. apply H. auto. apply TopBtmMustEq1 with (T2:=T2) in H1; auto.
  - destruct m2; inversion H3.  Qed.

Hint Resolve TopBtmMustEq1 TopBtmMustEq2.

(* ********************************************************************** *)
(** Narrowing and Transitivity (3) *)

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

Hint Unfold transitivity_on.

Hint Resolve wft_narrow.

Lemma sub_narrowing_aux : forall m1 m2 Q F E Z P S T,
  transitivity_on Q ->
  R (E & Z !:m1 <>: Q & F) m2 S T ->
  R E m1 P Q ->
  R (E & Z !:m1 <>: P & F) m2 S T.
Proof.
  introv TransQ SsubT PsubQ.
  inductions SsubT; introv.
  apply* SInt. apply* STB1. apply* STB2. apply* SFun. apply* SVarRefl.
  tests EQ: (X = Z).
    lets M: (@okt_narrow m1 Q).
    apply SVarBnd with (T:=P).
      asserts~ N: (ok (E & Z !:m1 <>: P & F)).
       lets: ok_middle_inv_r N.
        assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
       subst;  apply* binds_middle_eq.
       replace E with (E&empty) in PsubQ; try apply concat_empty_r.
        apply sub_weakening with (F:=Z!:m1<>:P&F) in PsubQ.
        rewrite concat_empty_r in PsubQ. rewrite concat_assoc in PsubQ.
         apply sub_wft in PsubQ. destruct* PsubQ. rewrite concat_empty_r.
         rewrite concat_assoc. apply* M. rewrite concat_empty_r in PsubQ.
        apply sub_wft in PsubQ. destruct* PsubQ.
      apply TransQ.
      assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
        subst.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. inversion H1. subst. autos*.
    apply SVarBnd with (T:=T); auto. binds_cases H; auto.
  apply* wft_narrow. autos*.
    tests EQ: (X = Z).
    lets M: (@okt_narrow m1 Q).
    apply SVarBndFl with (T:=P).
      asserts~ N: (ok (E & Z !:m1 <>: P & F)).
       lets: ok_middle_inv_r N.
        assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
       subst;  apply* binds_middle_eq.
       replace E with (E&empty) in PsubQ; try apply concat_empty_r.
        apply sub_weakening with (F:=Z!:m1<>:P&F) in PsubQ.
        rewrite concat_empty_r in PsubQ. rewrite concat_assoc in PsubQ.
         apply sub_wft in PsubQ. destruct* PsubQ. rewrite concat_empty_r.
         rewrite concat_assoc. apply* M. rewrite concat_empty_r in PsubQ.
        apply sub_wft in PsubQ. destruct* PsubQ.
      apply TransQ.
      assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
        subst.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. inversion H1. subst. autos*.
    apply SVarBndFl with (T:=T); auto. binds_cases H; auto.
  apply* wft_narrow. autos*.
  apply SAll with (L:=L). apply IHSsubT with (Q0:=Q); autos*.
  intros.
  apply H0 with (E0:=E) (Z0:=Z) (m3:=m1) (Q0:=Q) (F0:= (F & X !: m0 <>: SelectBound m2 T1 T2)) in H1; auto.
  rewrite concat_assoc in H1. auto. rewrite concat_assoc. auto.
Qed.

Lemma Var_Trans : forall E m T1 T2 X,
R E m T1 (typ_fvar X) -> R E m (typ_fvar X) T2 ->
  R E m T1 T2.
Proof. introv H1 H2. gen T2. inductions H1.
- destruct m; inversion x.
- introv Hy. apply* STB2.
- autos.
- introv Hy. eapply SVarBnd. apply H.
  autos. apply IHR with (X0:=X). autos. auto.
- introv Hy. apply sym2 in Hy. inductions Hy.
  + destruct m; inversion x.
  + apply* STB1.
  + eapply SVarBndFl. apply H. auto. auto.
  + eapply SVarBndFl. apply H3. auto. apply sym2.
    apply IHHy with (X0:=X); autos.
  + apply binds_get in H3. apply binds_get in H.
    rewrite H3 in H. inversion H. destruct m; inversion H5.
Qed.

Lemma sub_trans : forall Q,
  transitivity_on Q.
Proof.
  intro Q. introv SsubQ QsubT. asserts* W: (type Q).
  gen E S T. set_eq Q' EQ: Q. gen Q' EQ.
  induction W; intros Q' EQ E S SsubQ;
    induction SsubQ; try discriminate; inversions EQ;
      intros Ty QsubTy; inversions keep QsubTy;
        eauto 4.
    - destruct m; inversion H2. eapply SVarBnd.
    apply H. auto. apply TopBtmMustEq1; auto.
    - destruct m0; simpls.
      + eapply SVarBnd. apply H. auto.
        apply TopBtmMustEq1; auto.
      + apply sym2. eapply SVarBnd. simpl. apply H2. auto.
        apply TopBtmMustEq1; auto. eapply wft_var. apply H.
    - eapply SVarBnd. apply H. auto. auto.
    - destruct m; inversion H2.
    - eapply SVarBnd. apply H. auto. apply IHSsubQ; auto.
    - destruct m; inversion H2. eapply SVarBnd.
    apply H. auto. apply TopBtmMustEq1; auto.
   - destruct m0; simpls.
      + apply sym2. eapply SVarBnd. simpl. apply H2. auto.
        apply TopBtmMustEq1; auto. eapply wft_var. apply H.
      + eapply SVarBnd. apply H. auto.
        apply TopBtmMustEq1; auto.
    - destruct m; inversion H2.
    - eapply SVarBnd. apply H. auto. auto.
    - eapply SVarBnd. apply H. auto. apply IHSsubQ.
      auto. eapply SVarBnd. apply H3. auto. auto.
    - eapply SVarBnd. apply H. auto. apply IHSsubQ. auto. auto.
    - destruct m; inversion H1.
    - eapply SVarBndFl. apply H. auto. auto.
    - apply binds_get in H. apply binds_get in H2. rewrite H2 in H. inversion H.
      destruct m; inversion H4.
    - apply sym1 in H5. assert (m = m0). { destruct m; destruct m0; auto. }
      subst. eapply SVarBndFl. apply H2. auto. eapply Var_Trans.
      apply sym2. apply H5. eapply SVarBnd. apply H. auto. auto.
    - destruct m; inversion H.
    - apply SFun. apply sym1. apply IHW1 with (Q':=T1).
      auto. apply sym2. auto. apply sym2. auto.
      apply IHW2 with (Q':=T2). auto. auto. auto.
    - assert (forall T', R E m0 T T' -> R E m0 (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H. auto. auto. }
       clear H. clear IHSsubQ2. clear IHSsubQ1. clear QsubTy.
       inductions H1.
      + destruct m; inversion x.
      + subst. apply sym1. apply TopBtmMustEq1. auto. auto. eapply H2.
       auto.
      + subst. apply sym1. apply H2. apply SFun.
        apply IHW1 with (Q':=T1). auto. auto.  apply sym2. auto.
        apply sym2. apply IHW2 with (Q':=T2). auto. auto.
        apply sym1. auto.
      + eapply IHR. auto. apply W2. auto. auto. apply W1.
        auto. auto. auto. intros. apply H3. eapply SVarBnd.  apply H. auto.
        auto.
    - destruct m; inversion H2.
    - assert (forall T', R E m T T' -> R E m (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H. auto. auto. }
       clear H. clear IHSsubQ. clear H1. inductions SsubQ.
      + destruct m; inversion x.
      + apply H2. auto.
      + apply H2. apply SFun. apply sym1.
       apply IHW1 with (Q':=T1). auto. apply sym2. auto. apply sym2. auto.
       apply IHW2 with (Q':=T2). auto. auto. auto.
      + eapply IHSsubQ. auto. apply W2. auto. apply W1. auto.
        auto. auto. auto. auto. intros.  apply H2. eapply SVarBnd.
        apply H. auto. auto.
    - eapply SVarBnd. apply H. auto. eapply SVarBndFl.
      apply H2. auto. apply sym2. apply IHSsubQ; auto. apply sym1.
      auto.
    - destruct m; inversion H4.
    - eapply SVarBnd. apply H1. auto. eapply SVarBndFl. apply H4.
      auto. apply sym2. apply IHSsubQ; auto. apply sym1. auto.
    - assert (forall T', R E m T T' -> R E m (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H1. auto. auto. } clear H1.
      clear H3. inductions SsubQ.
      + destruct m; inversion x.
      + apply H4. auto.
      + apply H4. apply IHSsubQ; auto.
      + apply H4. apply IHSsubQ; auto.
    - apply STB1. auto. apply wft_all with (L:=L0). auto.
      intros. destruct m2; simpls.
      + apply_empty wft_narrow. assert (wft (E & X !: m0 <>: T1) (T4 open_tt_var X)).
        { apply H1 in H5. autos. } apply H6.
       apply ok_from_okt. replace (E & X !: m0 <>: T0) with (E & X !: m0 <>: T0 & empty).
        apply okt_narrow with (V:=T1). rewrite concat_empty_r. apply H1 in H5. auto.
        auto. rewrite concat_empty_r. auto.
      + apply H1 in H5. autos.
    - destruct m2; inversion H3.
    - assert (forall T', R E m T T' -> R E m (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H3. auto. auto. } clear H3.
      clear IHSsubQ. clear H2. inductions H5.
      + destruct m; inversion x.
      + apply sym1. apply H6. apply STB2. auto. apply wft_all with (L:= L \u L0).
        auto. intros. assert (R (E & X0 !: m0 <>: SelectBound (flip m) T0 T1)
       (flip m) (T4 open_tt_var X0) (T2 open_tt_var X0)).
      { apply H1. auto. } destruct m; simpls.
        * auto.
        * replace (E & X0 !: m0 <>: T0) with (E & X0 !: m0 <>: T0 & empty).
          apply wft_narrow with (V:=T1). rewrite concat_empty_r.
          autos. apply ok_from_okt. apply okt_narrow with (V:=T1).
          rewrite concat_empty_r. auto. auto. rewrite concat_empty_r. auto.
      + eapply IHR. auto. apply H. auto. apply W.
        auto. auto. auto. auto. auto. auto. auto. intros. apply H6.
        eapply SVarBnd. apply H3. auto. auto.
      + apply sym1. apply H6. apply SAll with (L:=L \u L0 \u L1).
        * destruct m0; simpls.
          { apply IHW with (Q':=T1). auto. auto. apply sym2. auto. }
          { apply sym2. apply IHW with (Q':=T1). auto. auto. apply sym1. auto. }
        * simpls. clear H2. clear IHR. intros. apply sym2.
          eapply H0 with (X := X0); autos. destruct m2; simpls.
        { apply H1. autos. }
        { apply_empty (@sub_narrowing_aux m0 Sub T1). unfold transitivity_on.
          intros. destruct m. apply IHW with (Q':=T1).
          auto. auto. auto. apply sym2. apply IHW with (Q':=T1).
          auto. apply sym2. auto. apply sym2. auto. apply H1. auto.
          destruct m0; auto.  }
        destruct m2; simpls.
        { apply_empty (@sub_narrowing_aux m0 Sup T1). unfold transitivity_on.
          intros. destruct m. apply sym2. apply IHW with (Q':=T1).
          auto. apply sym2. auto. apply sym2. auto. apply IHW with (Q':=T1).
          auto. auto. auto. apply sym2. apply H3. auto.
          destruct m0; auto.  }
        { apply sym2. apply H3. auto. }
    - apply SAll with (L:=L \u L0 \u L1).
         * destruct m0; simpls.
          { apply sym1. apply IHW with (Q':=T1). auto. apply sym2. auto. apply sym2. auto. }
          { apply IHW with (Q':=T1). auto. auto. auto. }
        * destruct m2; simpls; intros.
          { apply H0 with (X:=X) (Q':=T2 open_tt_var X). auto.
            auto. replace (E & X !: m0 <>: T5) with (E & X !: m0 <>: T5 & empty).
          apply (@sub_narrowing_aux m0 Sub T1). unfold transitivity_on.
          intros. destruct m.  apply IHW with (Q':=T1). auto.
          auto. auto. auto. apply sym2.  apply IHW with (Q':=T1). auto.
          apply sym2. auto. apply sym2. auto. rewrite concat_empty_r.
          auto. destruct m0; auto. simpl in H9. apply sym2. auto.
          simpl in H9. apply sym2. auto. rewrite concat_empty_r. auto.
          apply H10. auto.   }
          { apply H0 with (X:=X) (Q':=T2 open_tt_var X). auto.
            auto. auto.
          replace (E & X !: m0 <>: T0) with (E & X !: m0 <>: T0 & empty).
           apply (@sub_narrowing_aux m0 Sup T1). unfold transitivity_on.
          intros. destruct m. apply sym2.  apply IHW with (Q':=T1). auto.
          apply sym2. auto. apply sym2. auto. apply IHW with (Q':=T1). auto.
          auto. auto. rewrite concat_empty_r.
          auto. destruct m0; auto.  rewrite concat_empty_r. auto.
            }
Qed.

Lemma sub_narrowing : forall Q E m m' F Z P S T,
  R E m' P Q ->
  R (E & Z !: m' <>: Q & F) m S T ->
  R (E & Z !: m' <>: P & F) m S T.
Proof.
  intros.
  apply* sub_narrowing_aux.
  apply* sub_trans.
Qed.

Lemma sub_transitivity : forall Q E S m T,
  R E m S Q -> R E m Q T -> R E m S T.
Proof. intros.
assert (transitivity_on Q).
{ apply sub_trans. }
apply H1; autos. Qed.

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

Lemma okt_notin : forall E F X v,
okt(E&X~v&F) -> X # E.
Proof. induction F using env_ind; introv OK.
- rewrite concat_empty_r in OK. destruct v. apply okt_push_tvr_inv in OK.
destruct* OK.  apply okt_push_typ_inv in OK. destruct* OK.
- rewrite concat_assoc in OK. destruct v. apply okt_push_tvr_inv in OK.
destruct* OK.  apply okt_push_typ_inv in OK. destruct* OK. Qed.

Lemma sub_through_subst_tt : forall m1 m2 Q E F Z S T P,
  R (E & Z !: m1 <>: Q & F) m2 S T ->
  R E m1 P Q ->
  R (E & map (subst_tb Z P) F) m2 (subst_tt Z P S) (subst_tt Z P T).
Proof.
  introv SsubT PsubQ.
  inductions SsubT; introv; simpl subst_tt.
  apply* SInt.
  destruct m; apply* STB1.
  destruct m; apply* STB2.
  autos*.
  case_var.
    apply* refl.
    apply* SVarRefl.
    inversions H0. binds_cases H3.
      apply* wft_var.
      apply wft_var with (m:=m0) (T1:=subst_tt Z P T1). unsimpl_map_bind*.
      case_var.
      apply binds_middle_eq_inv in H. inversion H. subst.
     apply sub_transitivity with (Q:=Q). apply_empty* sub_weakening.
    rewrite* <- (@subst_tt_fresh Z P Q).
    apply (@notin_fv_wf E).
    apply sub_wft in PsubQ. destruct* PsubQ.
    apply sub_regular in SsubT. destruct SsubT. eapply okt_notin. apply H1.
    apply ok_from_okt. apply sub_regular in SsubT. destruct* SsubT.
    apply SVarBnd with (T:=(subst_tt Z P T)). rewrite* (@map_subst_tb_id E Z P).
    binds_cases H; unsimpl_map_bind*.
     apply sub_regular in PsubQ. destruct* PsubQ.
    apply* IHSsubT.
    case_var.
    apply binds_middle_eq_inv in H; auto. inversion H. subst.
    assert ( R (E & map (subst_tb Z P) F) m1 (subst_tt Z P Q) (subst_tt Z P F0)).
    {  autos*. } apply sym1. apply sub_transitivity with (Q:=(subst_tt Z P Q)); auto.
    rewrite*  (@subst_tt_fresh Z P Q). apply_empty sub_weakening; auto.
    apply (@notin_fv_wf E); auto. apply sub_regular in SsubT. destruct SsubT.
    apply okt_notin with (E:=E) (v:=(bind_tRel m1 Q)) (F:=F); auto.
    apply SVarBndFl with (T:=(subst_tt Z P T)). rewrite* (@map_subst_tb_id E Z P).
    binds_cases H; unsimpl_map_bind*.  apply* wft_subst_tb.
    apply* IHSsubT.
  apply SAll with (L:=L \u \{Z}). apply* IHSsubT.
  lets M:PsubQ. apply sub_wft in PsubQ. destruct* PsubQ.
  destruct m2; simpl; simpl in H0.
   unsimpl (subst_tb Z P (bind_tRel m0 T2)).
   intros. rewrite <- concat_assoc. rewrite <- map_push.
  rewrite* subst_tt_open_tt_var. rewrite* subst_tt_open_tt_var.
   apply H0 with (m2:=m1) (Q0:=Q); autos. rewrite concat_assoc. auto.
 unsimpl (subst_tb Z P (bind_tRel m0 T1)).
   intros. rewrite <- concat_assoc. rewrite <- map_push.
  rewrite* subst_tt_open_tt_var. rewrite* subst_tt_open_tt_var.
   apply H0 with (m2:=m1) (Q0:=Q); autos. rewrite concat_assoc. auto.
Qed.

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

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

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as x. forwards~ K: (H x).
   apply_ih_bind (H0 x); eauto.
  apply* typing_app.
  apply_fresh* typing_tabs as X. forwards~ K : (H X).
   apply_ih_bind (H0 X); eauto.
  apply* typing_tapp. apply* sub_weakening.
  apply* typing_sub. apply* sub_weakening.
Qed.
(* ********************************************************************** *)
(** Strengthening (6) *)

Lemma sub_strengthening : forall m x U E F S T,
  R (E & x ~: U & F) m S T ->
  R (E & F) m S T.
Proof.
  intros m x U E F S T SsubT.
  inductions SsubT; introv; autos* wft_strengthen.
  (* case: fvar trans *)
  apply SVarBnd with (T:=T); autos*. binds_cases H; autos*.
  apply SVarBndFl with (T:=T); autos*. binds_cases H; autos*.
  (* case: all *)
  apply SAll with (L:= L); autos*. intros. apply_ih_bind* H0.
Qed.

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

Lemma typing_through_subst_ee : forall U E F x T e u,
  typing (E & x ~: U & F) e T ->
  typing E u U ->
  typing (E & F) (subst_ee x u e) T.
Proof.
  introv TypT TypU. inductions TypT; introv; simpl.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih_bind* H0.
  lets M:TypU. apply typing_regular in M. destruct M. auto.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    rewrite* subst_ee_open_te_var.
    apply_ih_bind* H0.
  apply* typing_tapp. apply* sub_strengthening.
  apply* typing_sub. apply* sub_strengthening. apply* wft_strengthen.
Qed.

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

Lemma typing_through_subst_te : forall E F Z m Ty e T P,
  typing (E & Z!: m <>: Ty & F) e T ->
  R E m P Ty ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Typ WFT.
  inductions Typ; simpls subst_tt; simpls subst_te; autos*.
  subst. apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
  binds_cases H0; unsimpl_map_bind*.
  (* case abs *)
  apply_fresh* typing_abs as y.
    unsimpl (subst_tb Z P (bind_typ V)).
   rewrite* subst_te_open_ee_var.
   apply_ih_map_bind* H0.
  (* case tabs *)
  apply_fresh* typing_tabs as Y.
   unsimpl (subst_tb Z P (bind_tRel m0 Tk)).
    rewrite* subst_te_open_te_var.
    rewrite* subst_tt_open_tt_var.
    apply_ih_map_bind* H0.
    rewrite* subst_tt_open_tt. apply* typing_tapp.
    apply* sub_through_subst_tt.
  apply* typing_sub. apply* sub_through_subst_tt.
Qed.

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

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

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  (forall U1 U2, R E Sub T (typ_arrow U1 U2) ->
     R E Sub U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ R E Sup U2 S2).
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 R; inversions EQ.
  inversions* R. split.
  rewrite <- sym2 in H6. auto.
  exists T1. exists L. split; autos.
  rewrite sym2. apply H8.
  apply IHTyp. autos. eapply sub_transitivity.
  apply H. apply R.
Qed.

Lemma typing_inv_tabs : forall E e T m0 T0,
  typing E (trm_tabs m0 T0 e) T ->
  forall U m T', R E Sub T (typ_all m T' U) ->
  exists S, exists L, forall X, X \notin L ->
     typing (E & X!:m <>: T0) (e open_te_var X) (S open_tt_var X)
     /\ R (E & X!:m <>: T') Sub (S open_tt_var X) (U open_tt_var X)
     /\ m = m0
     /\ R E (BindPosVariance Sub m) T0 T'.
Proof.
  introv Ty Sub. remember (trm_tabs m0 T0 e) as trm.
  remember (typ_all m T' U) as ty.
  induction Ty; inversion Heqtrm; subst; clear H0.
  - exists T. inversion Sub. subst. exists (L \u L0).
    introv NI. apply notin_union_r in NI. destruct NI. split.
    apply* H. split; auto.
  - apply* IHTy. eapply sub_transitivity. apply H. auto.
Qed.
(* ********************************************************************** *)
(** Preservation Result (20) *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  - inversions Red; try solve [ apply* typing_app ].
  destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply refl with (E:=E). apply typing_regular in Typ1. destruct Typ1.
    destruct H0. auto. auto.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_ee_intro X).
     apply_empty (@typing_through_subst_ee V).
       apply* (@typing_sub S2). apply* sym2.
      apply_empty sub_weakening. auto. auto.
       inversion Typ1. subst. apply Typ2. subst. eapply typing_sub. apply Typ2. auto.
       auto.
  (* case: tapp *)
  -inversions Red; try solve [ apply* typing_tapp ].
   destruct (typing_inv_tabs Typ (U:=T1) (m:=m) (T':=Tb)).
    apply* refl.
   apply typing_regular in Typ. destruct Typ.
    destruct H3.  inversion H5; subst. destruct H0.
    pick_fresh X. forwards~ K : ( H0 X). destruct K.
   rewrite* (@subst_te_intro X). rewrite* (@subst_tt_intro X).
   replace E with (E & map (subst_tb X T2) empty).
   replace (E & X!: m <>: T) with (E & X!: m <>: T & empty) in H6.
    eapply typing_sub.
   apply (typing_through_subst_te H6).
    eapply sub_transitivity. apply H. destruct H7.
    destruct H8. apply sym2. auto.
   apply* (@sub_through_subst_tt m Sub Tb E empty X).
    destruct H7. rewrite concat_empty_r. auto.
   apply* wft_subst_tb.
   apply* concat_empty_r.
   rewrite map_empty. apply* concat_empty_r.
  (* case sub *)
  - apply* typing_sub.
Qed.

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

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

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_arrow U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ.
  gen_eq T: (typ_arrow U1 U2). intro st.
   assert (R empty Sub T (typ_arrow U1 U2)).
{ rewrite st.
    apply refl with (E:=empty); auto. subst. apply typing_regular in Typ.
    destruct Typ. destruct H0. auto. }
  clear st. gen_eq E: (@empty typ).  gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. assert (R E0 Sub S (typ_arrow U1 U2)). {
    eapply sub_transitivity. apply H. apply EQT. }
   eapply IHTyp. apply Val. apply H1. reflexivity. Qed.

Lemma tall_inv : forall E m m1 m2 T1 T2 M N,
R E m (typ_all m1 T1 M) (typ_all m2 T2 N) -> m1=m2 /\
R E (BindPosVariance m2 m) T1 T2.
Proof. introv TA. inductions TA.
- destruct m; inversion x.
- destruct m; inversion x.
- split; auto. Qed.

Lemma canonical_form_tabs : forall t T m U,
  value t -> typing empty t (typ_all m T U) ->
  exists T' e1, t = trm_tabs m T' e1 /\ R empty (BindPosVariance m Sub) T' T.
Proof.
  introv Val Typ.
  gen_eq Ty: (typ_all m T U). intro st.
  assert (R empty Sub Ty (typ_all m T U)). { rewrite* st.
  apply refl with (E:=empty); auto. subst. apply typing_regular in Typ. destruct Typ.
   destruct H0. auto. }
  clear st. gen_eq E: (@empty typ).
  induction Typ; introv EQE;
   try solve [ inversion Val | inversion EQE | eauto | inversion H ].
  apply tall_inv in H.
  exists Tk. exists e. split. destruct H. subst. auto.
  destruct H. auto.
  apply* IHTyp. eapply sub_transitivity.
  apply H0. auto. Qed.

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

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty typ). lets Typ': Typ. remember empty as Env.
  induction Typ; intros EQ; subst.
  left*.
  (* case: var *)
  false* binds_empty_inv.
  (* case: abs *)
  left*.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (open_ee e3 e2).
  left*.
  right. destruct* IHTyp as [Val | [e1 Red]].
      destruct (canonical_form_tabs Val Typ).
        subst. destruct H0. destruct H0. subst. exists* (open_te x0 T2).
  autos*.
Qed.