Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Reverse.

(* Lemma sub_tvar_trans_var: forall X A E B,
    binds X (bind_sub A) E ->
    sub E X B ->
    (typ_fvar X) <> B ->
    sub E A B \/ exists (Y:atom) U', B = Y /\ binds Y (bind_sub_lb U') E .
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros...
  -
    destruct H1...
  -
    constructor... constructor...
    apply WF_from_binds_typ with (x:=X)...
  -
    apply  binds_uniq with (A:=A) in H...
    subst...
    get_well_form...
  -
    right. exists X0, U...
Qed. *)

(* Lemma chain_property: forall E A B (X Y:atom),
  binds X (bind_sub A) E ->
  binds Y (bind_sub_lb B) E ->
  sub E X Y ->
  (sub E X B -> sub E A Y \/ X = Y).
   (* /\ *)
  (* (sub E A Y -> sub E X B \/ X = Y). *)
Proof with auto.
  (* intros E. intros.
  generalize dependent A.
  generalize dependent B.
  dependent induction H1...
  - intros. clear IHsub.
    assert (A = U) by admit. subst...
  - intros. clear IHsub.
    assert (B = U) by admit. subst...
  admit. *)

  induction E.
  - admit.
  - intros. dependent destruction H1.
    + right...
    + assert (A=U) by admit. subst.

    (* Search sub fv_tt. *)
      left...
    + assert (B=U) by admit. subst.
      inversion H0;subst.
      * analyze_binds H.
        dependent destruction H2.
        { left. apply sa_trans_tvar_lb with (U:=X)...

        }

        admit.
      * inversion H;subst.
        { analyze_binds H1. admit. }
        { assert (sub E X U).
          { add_nil.   destruct a.
            apply sub_strengthening with (X:=a) (U:=b)...
            { get_well_form. assert (wf_env E) by (inversion H2;subst;auto).
              apply WF_from_binds_typ_lb in H4...
              apply WF_imply_dom in H4.
              assert (a <> X). { apply uniq_from_wf_env in H2.
                inversion H2;subst. apply binds_In in H5.
                intros C. subst. exfalso... }
              inversion H3;solve_notin...
            }
            { get_well_form. inversion H2... }
          }
          destruct IHE with (A:=A) (B:=U) (X:=X) (Y:=Y)...
          { apply sa_trans_tvar_lb with (U:=U)... }
          * left. rewrite_env (nil ++[ a ] ++ E).
            apply Sub_weakening... get_well_form...
        }

  generalize dependent A.
  generalize dependent B.
  dependent induction H1;intros...
  - admit.
  - specialize (IHsub )

  intros E. *)

Lemma choose_flip: forall m A B ,
    choose m A B = choose (flip m) B A .
Proof with auto.
  intros.
  destruct m...
Qed.

Lemma subst_tt_wf_env_label_rec: forall E1 X E2 U,
    wf_env (map (subst_tb X (typ_label X (open_tt U X))) E1 ++ (X, bind_sub typ_top) :: E2) ->
    X \notin fv_tt U \u fl_env E1 ->
    WF E2 (typ_mu U) ->
    wf_env (map (subst_tb X (typ_mu U)) E1 ++ E2).
Proof with auto.
  intros.
  apply wf_env_drop_label in H.
  rewrite drop_label_reverse_env in H...
  apply wf_env_map_free2 with (B:=bind_sub typ_top)...
Qed.

Lemma drop_wf_env_label_rec: forall E1 X E2 U,
    wf_env (map (subst_tb X (typ_label X (open_tt U X))) E1 ++ (X, bind_sub typ_top) :: E2) ->
    X \notin fv_tt U \u fl_env E1 ->
    WF E2 (typ_mu U) ->
    wf_env ( E1 ++ (X, bind_sub typ_top) :: E2).
Proof with auto.
  intros.
  apply wf_env_drop_label in H.
  rewrite drop_label_reverse_env in H...
Qed.

Lemma binds_map_free_env2: forall E1 E2 X Y U S,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub typ_top) :: E2) ->
    binds X (bind_sub U) (E1 ++ (Y, bind_sub typ_top) :: E2) ->
    binds X (bind_sub (subst_tt Y S U)) (map (subst_tb Y S) E1 ++  E2).
Proof with auto.
  intros.
  analyze_binds H1...
  -
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    unfold binds in *.
    apply In_lemmaR.
    rewrite <- maps_subst_tb_free with (X:=Y) (U:=S)...
    apply binds_map_free...
    apply notin_from_wf_env in H0...
Qed.

Lemma binds_subst_extensial: forall E S T X0 X U,
    binds X0 (bind_sub U) (map (subst_tb X S) E) ->
    exists A,
      binds X0 (bind_sub A) (map (subst_tb X T) E).
Proof with auto.
  induction E;intros...
  simpl in *.
  analyze_binds H.
  simpl in *.
  destruct a.
  analyze_binds H.
  -
    destruct b;simpl in *; inversion BindsTacVal.
    exists (subst_tt X T t)...
  -
    apply IHE with (T:=T) in BindsTac...
    destruct_hypos.
    exists x...
Qed.

Lemma binds_subst_extensial_lb: forall E S T X0 X U,
    binds X0 (bind_sub_lb U) (map (subst_tb X S) E) ->
    exists A,
      binds X0 (bind_sub_lb A) (map (subst_tb X T) E).
Proof with auto.
  induction E;intros...
  simpl in *.
  analyze_binds H.
  simpl in *.
  destruct a.
  analyze_binds H.
  -
    destruct b;simpl in *; inversion BindsTacVal.
    exists (subst_tt X T t)...
  -
    apply IHE with (T:=T) in BindsTac...
    destruct_hypos.
    exists x...
Qed.

Lemma binds_subst_extensial_no_subst: forall E S  X0 X U,
    binds X0 (bind_sub U) (map (subst_tb X S) E) ->
    exists A,
      binds X0 (bind_sub A) E.
Proof with auto.
  induction E;intros...
  simpl in *.
  analyze_binds H.
  simpl in *.
  destruct a.
  analyze_binds H.
  -
    destruct b;simpl in *; inversion BindsTacVal.
    exists t...
  -
    apply IHE in BindsTac...
    destruct_hypos.
    exists x...
Qed.

Lemma binds_subst_extensial_no_subst_lb: forall E S  X0 X U,
    binds X0 (bind_sub_lb U) (map (subst_tb X S) E) ->
    exists A,
      binds X0 (bind_sub_lb A) E.
Proof with auto.
  induction E;intros...
  simpl in *.
  analyze_binds H.
  simpl in *.
  destruct a.
  analyze_binds H.
  -
    destruct b;simpl in *; inversion BindsTacVal.
    exists t...
  -
    apply IHE in BindsTac...
    destruct_hypos.
    exists x...
Qed.

Lemma subst_tb_wf_reverse: forall S X T E Q E2,
  WF (map (subst_tb X T) E ++ X ~ bind_sub Q ++E2) (subst_tt X T S) ->
  WF (X ~ bind_sub Q ++E2) T ->
  WF (E ++ X ~ bind_sub Q ++ E2) S.
Proof with eauto.
  intros.
  dependent induction H;simpl in *;try solve [dependent destruction H;eauto]...
  -
    destruct S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
  -
    destruct S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
  -
    destruct S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
    rewrite <- x.
    analyze_binds H...
    apply binds_subst_extensial_no_subst in BindsTac...
    destruct_hypos...
  -
    destruct S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
    rewrite <- x.
    analyze_binds H...
    apply binds_subst_extensial_no_subst_lb in BindsTac...
    destruct_hypos...
  -
    destruct S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
    dependent destruction x.
    constructor...
  -
    induction S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
    dependent destruction x...
    clear IHS1 IHS2.
    apply WF_all with (L:=L \u {{X}});intros...
    rewrite_env ((X0 ~ bind_sub S1 ++ E) ++ (X, bind_sub Q) :: E2).
    apply H1 with (X0:=X0) (T0:=T)...
    rewrite subst_tt_open_tt_var...
    get_type...
  -
    induction S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
    dependent destruction x...
    clear IHS1 IHS2.
    apply WF_all_lb with (L:=L \u {{X}});intros...
    rewrite_env ((X0 ~ bind_sub_lb S1 ++ E) ++ (X, bind_sub Q) :: E2).
    apply H1 with (X0:=X0) (T0:=T)...
    rewrite subst_tt_open_tt_var...
    get_type...
  -
    destruct S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
    dependent destruction x...
    apply WF_rec with (L:=L \u {{X}});intros...
    +
      rewrite_env ((X0 ~ bind_sub typ_top ++ E) ++ (X, bind_sub Q) :: E2).
      apply H0 with (X0:=X0) (T0:=T)...
      rewrite subst_tt_open_tt_var...
      get_type...
    +
      rewrite_env ((X0 ~ bind_sub typ_top ++ E) ++ (X, bind_sub Q) :: E2).
      apply H2 with (X0:=X0) (T0:=T)...
      rewrite subst_tt_open_tt_twice...
      get_type...
  -
    destruct S;simpl in *;try solve [inversion x]...
    destruct (a==X);try solve [inversion x]...
    constructor...
    apply IHWF with (T0:=T)...
    inversion x...
Qed.

Lemma subst_tb_wf_env_reverse: forall E E2 X T,
    wf_env (map (subst_tb X T) E ++ (X~ bind_sub typ_top) ++ E2) ->
    WF ((X~ bind_sub typ_top) ++ E2) T ->
    wf_env (E ++ (X~ bind_sub typ_top) ++ E2).
Proof with auto.
  induction E;intros...
  destruct a.
  destruct b.
  -
    simpl in *.
    dependent destruction H...
    constructor...
    apply IHE with (T:=T)...
    apply subst_tb_wf_reverse in H0...
  -
    simpl in *.
    dependent destruction H...
    constructor...
    apply IHE with (T:=T)...
    apply subst_tb_wf_reverse in H0...
  -
    simpl in *.
    dependent destruction H...
    constructor...
    apply IHE with (T:=T)...
    apply subst_tb_wf_reverse in H0...
Qed.

Lemma WF_narrowing_env: forall E1 E E2 A S T X,
    WF (E1 ++ map (subst_tb X S) E ++ E2) A ->
    WF (E1 ++ map (subst_tb X T) E ++ E2) A.
Proof with auto.
  intros.
  dependent induction H;try solve [analyze_binds H;eauto]...
  -
    analyze_binds H; try solve [apply WF_var with (U:=U);auto].
    apply binds_subst_extensial with (T:=T) in BindsTac0.
    destruct_hypos.
    apply WF_var with (U:=x)...
  -
    analyze_binds H; try solve [apply WF_var_lb with (U:=U);auto].
    apply binds_subst_extensial_lb with (T:=T) in BindsTac0.
    destruct_hypos.
    apply WF_var_lb with (U:=x)...
  -
    apply WF_all with (L:=L )...
    apply IHWF with (S0:=S)...
    intros.
    rewrite_env ((X0 ~ bind_sub T1 ++ E1) ++ map (subst_tb X T) E ++ E2).
    eapply H1 with (S0:=S)...
  -
    apply WF_all_lb with (L:=L )...
    apply IHWF with (S0:=S)...
    intros.
    rewrite_env ((X0 ~ bind_sub_lb T1 ++ E1) ++ map (subst_tb X T) E ++ E2).
    eapply H1 with (S0:=S)...
  -
    apply WF_rec with (L:=L );intros...
    rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ map (subst_tb X T) E ++ E2).
    eapply H0 with (S0:=S)...
    rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ map (subst_tb X T) E ++ E2).
    eapply H2 with (S0:=S)...
Qed.

(* this lemma is not used *)
Lemma binds_subst_extensial_equiv: forall  E2  E S T X0 X U,
    binds X0 (bind_sub U) (map (subst_tb X S) E ++ (X, bind_sub typ_top):: E2) ->
    equiv ( (X, bind_sub typ_top)::E2) S T ->
    wf_env (map (subst_tb X T) E ++ (X, bind_sub typ_top)::E2) ->
    wf_env (map (subst_tb X S) E ++ (X, bind_sub typ_top)::E2) ->
    WF (map (subst_tb X T) E ++(X, bind_sub typ_top):: E2) U ->
    exists A,
      equiv (map (subst_tb X T) E ++ (X, bind_sub typ_top)::E2) U A /\ binds X0 (bind_sub A) (map (subst_tb X T) E ++ (X, bind_sub typ_top)::E2).
Proof with auto.
  induction E;intros...
  -
    simpl in *.
    exists U...
    split...
    unfold equiv;
      split;apply Reflexivity...
  -
    simpl in *.
    destruct a.
    apply binds_cons_uniq_iff in H.
    destruct H.
    +
      destruct_hypos;subst.
      destruct b;simpl in *.
      *
        dependent destruction H4.
        exists (subst_tt X T t).
        split...
        unfold equiv;split.
        --
          rewrite_env (nil ++ (a~ bind_sub (subst_tt X T t)) ++ map (subst_tb X T) E ++ (X, bind_sub typ_top) ::E2).
          apply Sub_weakening...
          apply equiv_sub_subst...
          apply Reflexivity...
          ++
            dependent destruction H1.
            apply subst_tb_wf_reverse with (T:=T)...
            unfold equiv in *;destruct_hypos;get_well_form...
          ++
            dependent destruction H1.
            apply subst_tb_wf_env_reverse in H1...
            unfold equiv in *;destruct_hypos;get_well_form...
          ++
            unfold equiv in *;destruct_hypos;split;
            get_well_form;apply Reflexivity...
        --
          rewrite_env (nil ++ (a~ bind_sub (subst_tt X T t)) ++ map (subst_tb X T) E ++ (X, bind_sub typ_top) ::E2).
          apply Sub_weakening...
          apply equiv_sub_subst...
          apply Reflexivity...
          ++
            dependent destruction H1.
            apply subst_tb_wf_reverse with (T:=T)...
            unfold equiv in *;destruct_hypos;get_well_form...
          ++
            dependent destruction H1.
            apply subst_tb_wf_env_reverse in H1...
            unfold equiv in *;destruct_hypos;get_well_form...
          ++
            unfold equiv in *;destruct_hypos;split...
          ++
            unfold equiv in *;destruct_hypos;split;
              get_well_form;apply Reflexivity...
          ++
            unfold equiv in *;destruct_hypos;split...
      *
        inversion H4.
      * inversion H4.
    +
      destruct_hypos.
      destruct IHE with (S:=S) (T:=T) (X:=X) (X0:=X0) (U:=U)...
      dependent destruction H1...
      dependent destruction H2...
      apply WF_from_binds_typ in H...
      rewrite_env (nil ++ map (subst_tb X T) E ++ (X, bind_sub typ_top) :: E2).
      apply WF_narrowing_env with (S:=S)...
      dependent destruction H2...
      destruct H5...
      exists x...
      split...
      unfold equiv in *;destruct_hypos.
      split;rewrite_env (nil ++ (a~ subst_tb X T b) ++ map (subst_tb X T) E ++ (X, bind_sub typ_top) :: E2);apply Sub_weakening...
    +
      apply uniq_from_wf_env...
Qed.

Lemma notin_fl_env: forall E X Y U,
    binds X (bind_sub U) E ->
    Y \notin fl_env E ->
    Y \notin fl_tt U.
Proof with eauto.
  induction E;intros...
  simpl in *.
  destruct a.
  destruct b...
  -
    analyze_binds H.
    inversion BindsTacVal...
    apply IHE with (X:=X)...
  -
    analyze_binds H.
    apply IHE with (X:=X)...
  -
    analyze_binds H.
    apply IHE with (X:=X)...
Qed.

Lemma binds_uniq: forall E X A B,
    wf_env E ->
    binds X (bind_sub A) E ->
    binds X (bind_sub B) E ->
    A = B.
Proof with auto.
  induction E;intros...
  analyze_binds H0.
  destruct a.
  analyze_binds_uniq H0.
  -
    apply uniq_from_wf_env...
  -
    analyze_binds_uniq H1...
    inversion BindsTacVal...
  -
    analyze_binds_uniq H1...
    apply IHE with (X:=X)...
    dependent destruction H...
Qed.

Lemma sub_tvar_trans_var: forall X A E B,
    binds X (bind_sub A) E ->
    sub E X B ->
    (typ_fvar X) <> B ->
    sub E A B \/ exists (Y:atom) U', B = Y /\ binds Y (bind_sub_lb U') E .
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros...
  -
    destruct H1...
  -
    constructor... constructor...
    apply WF_from_binds_typ with (x:=X)...
  -
    apply  binds_uniq with (A:=A) in H...
    subst...
    get_well_form...
  -
    right. exists X0, U...
Qed.

(*
Lemma sub_tvar_trans_var': forall X A E B,
    binds X (bind_sub A) E ->
    sub E X B ->
    (typ_fvar X) <> B ->
    sub E A B \/ exists (Y:atom) U', B = Y /\ binds Y (bind_sub_lb U') E /\ sub E A Y.
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros...
  -
    destruct H1...
  -
    constructor... constructor...
    apply WF_from_binds_typ with (x:=X)...
  -
    apply  binds_uniq with (A:=A) in H...
    subst...
    get_well_form...
  -
    right. exists X0, U...
    repeat split...
    apply sa_trans_tvar_lb with (U:=U)...
Qed. *)

Lemma sub_tvar_trans_var'': forall X A E B,
    binds X (bind_sub A) E ->
    sub E X B ->
    (typ_fvar X) = B \/
    sub E A B \/ exists (Y:atom) U', B = Y /\ binds Y (bind_sub_lb U') E /\ sub E X Y.
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros...
  (* -
    destruct H1... *)
  - right. left.
    constructor...
     (* constructor... *)
    apply WF_from_binds_typ with (x:=X)...
  -
    apply  binds_uniq with (A:=A) in H...
    subst...
    get_well_form...
  -
    destruct (IHsub X) with (A:=A)...
    + subst.
    right. right. exists X0, X...
    repeat split... apply sa_trans_tvar_lb with (U:=X)...
    + destruct H2...
    * subst.
      right. right. exists X0, U...
      repeat split... apply sa_trans_tvar_lb with (U:=U)...
    * destruct_hypos. subst.
      right. right. exists X0, x...
      repeat split... apply sa_trans_tvar_lb with (U:=x)...
Qed.

Lemma sub_tvar_trans_var': forall X A E B,
    binds X (bind_sub A) E ->
    sub E X B ->
    (typ_fvar X) = B \/
    sub E A B \/ exists (Y:atom) U', B = Y /\ binds Y (bind_sub_lb U') E /\ sub E X Y.
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros...
  (* -
    destruct H1... *)
  - right. left.
    constructor...
     (* constructor... *)
    apply WF_from_binds_typ with (x:=X)...
  -
    apply  binds_uniq with (A:=A) in H...
    subst...
    get_well_form...
  -
    destruct (IHsub X) with (A:=A)...
    + subst.
    right. right. exists X0, X...
    repeat split... apply sa_trans_tvar_lb with (U:=X)...
    + destruct H2...
    * subst.
      right. right. exists X0, U...
      repeat split... apply sa_trans_tvar_lb with (U:=U)...
    * destruct_hypos. subst.
      right. right. exists X0, x...
      repeat split... apply sa_trans_tvar_lb with (U:=x)...
Qed.

Lemma open_tt_var_rev: forall A B (X:atom),
    X \notin fv_tt A \u fv_tt B ->
    open_tt A X = open_tt B X ->
    A = B.
Proof with auto.
  unfold open_tt.
  generalize 0.
  intros n A B.
  generalize dependent n.
  generalize dependent B.
  induction A;induction B;intros;simpl in *;try solve [inversion H0|destruct (n0==n);subst;inversion H0]...
  -
    destruct (n1==n);destruct (n1==n0);subst...
    inversion H0.
    inversion H0.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite <- H2 in H.
    solve_notin_self X.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite  H2 in H.
    solve_notin_self X.
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA in H2...
    subst...
  -
    inversion H0.
    apply IHA in H3...
    subst...
Qed.

Lemma EqDec_eq : forall (A B: typ),
    {A = B} + {A <> B}.
Proof with auto.
  intros.
  decide equality.
  decide equality.
Qed.

Lemma mu_transform_0: forall C  (Y X:atom) A ,
    type (typ_mu C) ->
    X <> Y ->
    (subst_tt X (typ_mu C) (open_tt A (typ_label Y (open_tt A Y)))) =
 (open_tt (subst_tt X (typ_mu C) A)
       (typ_label Y (open_tt (subst_tt X (typ_mu C) A) Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal.
  simpl...
  f_equal.
  rewrite subst_tt_open_tt_var...
Qed.

Lemma mu_transform_1: forall (X Y:atom) A C,
    X <> Y ->
    type (open_tt C X) ->
    (open_tt (subst_tt X (typ_label X (open_tt C X)) A)
                 (typ_label Y (open_tt (subst_tt X (typ_label X (open_tt C X)) A) Y))) =
    (subst_tt X (typ_label X (open_tt C X)) (open_tt A (typ_label Y (open_tt A Y)))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  destruct (Y==X)...
  destruct H...
Qed.

(* Lemma sub_narrowing_env: forall E1 X E2 C D A B,
  sub (map (subst_tb X C) E1 ++ X ~ bind_sub typ_top ++ E2) A B ->
  equiv E2 C D ->
  sub (map (subst_tb X D) E1 ++ X ~ bind_sub typ_top ++ E2) A B .
Proof with auto.
  intros. dependent induction H...
  +
    constructor. admit.
  +
    constructor.
    admit.
    inversion H0;subst.
    admit.
    admit.
  +
    constructor.
    admit. admit.
  +
    analyze_binds_uniq H.
    { apply uniq_from_wf_env. get_well_form... }
    * destruct (binds_subst_extensial_no_subst _ _ _ _ _ BindsTac).
      eapply sa_trans_tvar with (U:=subst_tt X D x).
      { admit. }
      { apply IHsub. with (C0:=C)... }

    (* eapply WF_var. apply H4. *)
    admit
    Search wf_env. get_well_form...

  intros E1. induction E1;intros.
  - apply H.
  - destruct a as [Y b]. simpl. *)

(* Check equiv_sub_subst_not_var. *)

Lemma wf_env_subst_map: forall E1 E2 X S T,
  wf_env (map (subst_tb X S) E1 ++ E2) ->
  WF E2 T ->
  wf_env (map (subst_tb X T) E1 ++ E2).
Admitted.

Lemma fl_env_not_int_subst_tb:
  forall E1 E2 X D,
  X \notin fl_env E1 \u fl_env E2 \u fl_tt D ->
  X \notin fl_env (map (subst_tb X D) E1 ++ E2).
Proof with auto.
  intros.
  induction E1;intros...
Admitted.

Print wf_env.

Inductive equiv_env: env -> env -> Prop :=
| equiv_env_nil: equiv_env nil nil
| equiv_env_cons: forall X E1 E2 S T,
    X \notin dom E2 ->
    equiv_env E1 E2 ->
    equiv E2 S T ->
    equiv_env (X ~ bind_sub S ++ E1) (X ~ bind_sub T ++ E2)
| equiv_env_cons_lb: forall X E1 E2 S T,
    X \notin dom E2 ->
    equiv_env E1 E2 ->
    equiv E2 S T ->
    equiv_env (X ~ bind_sub_lb S ++ E1) (X ~ bind_sub_lb T ++ E2)
| equiv_env_cons_typ: forall X E1 E2 S T,
    X \notin dom E2 ->
    equiv_env E1 E2 ->
    equiv E2 S T ->
    equiv_env (X ~ bind_typ S ++ E1) (X ~ bind_typ T ++ E2)
.

Lemma equiv_weakening: forall E1 E2 E A B,
equiv (E1 ++ E2) A B ->
wf_env (E1 ++ E ++ E2) ->
  equiv (E1 ++ E ++ E2) A B.
Proof with auto.
  intros. destruct H.
  split.
  - apply Sub_weakening...
  - apply Sub_weakening...
Qed.

Ltac add_nil :=
    match goal with
    | [ |- WF ?E _ ] => rewrite_alist (nil ++ E)
    | [ |- sub ?E _ _ ] => rewrite_alist (nil ++ E)
    | [ |- equiv ?E _ _ ] => rewrite_alist (nil ++ E)
    end.

Lemma equiv_env_binds : forall E1 E2 X (U:typ),
    equiv_env E1 E2 ->
    binds X (bind_sub U) E1 ->
    exists U', binds X (bind_sub U') E2 /\ equiv E2 U U'.
Proof with auto.
  intros.
  induction H.
  + inversion H0.
  + analyze_binds H0.
    * inversion BindsTacVal;subst. exists T. split;auto.
      destruct H2. split.
      { add_nil. apply Sub_weakening... get_well_form.
        constructor... }
      { add_nil. apply Sub_weakening... get_well_form.
        constructor... }
    * destruct IHequiv_env;auto.
      destruct_hypos.
      exists x. split;auto.
      destruct H3. split.
      { add_nil. apply Sub_weakening... get_well_form...
        constructor... destruct H2. get_well_form... }
      { add_nil. apply Sub_weakening... get_well_form.
        constructor... destruct H2. get_well_form... }
  + analyze_binds H0.
    apply IHequiv_env in BindsTac.
    destruct_hypos.
    exists x. split;auto.
    add_nil. apply equiv_weakening...
    { destruct H3. destruct H2. get_well_form.
      constructor... }
  + analyze_binds H0.
    apply IHequiv_env in BindsTac.
    destruct_hypos.
    exists x. split;auto.
    add_nil. apply equiv_weakening...
    { destruct H3. destruct H2. get_well_form.
      constructor... }
Qed.

Lemma equiv_env_binds_lb : forall E1 E2 X (U:typ),
    equiv_env E1 E2 ->
    binds X (bind_sub_lb U) E1 ->
    exists U', binds X (bind_sub_lb U') E2 /\ equiv E2 U U'.
Proof with auto.
  intros.
  induction H.
  + inversion H0.
  + analyze_binds H0.
    apply IHequiv_env in BindsTac.
    destruct_hypos.
    exists x. split;auto.
    add_nil. apply equiv_weakening...
    { destruct H3. destruct H2. get_well_form.
      constructor... }
  + analyze_binds H0.
    * inversion BindsTacVal;subst. exists T. split;auto.
      destruct H2. split.
      { add_nil. apply Sub_weakening... get_well_form.
        constructor... }
      { add_nil. apply Sub_weakening... get_well_form.
        constructor... }
    * destruct IHequiv_env;auto.
      destruct_hypos.
      exists x. split;auto.
      destruct H3. split.
      { add_nil. apply Sub_weakening... get_well_form...
        constructor... destruct H2. get_well_form... }
      { add_nil. apply Sub_weakening... get_well_form.
        constructor... destruct H2. get_well_form... }
  + analyze_binds H0.
    apply IHequiv_env in BindsTac.
    destruct_hypos.
    exists x. split;auto.
    add_nil. apply equiv_weakening...
    { destruct H3. destruct H2. get_well_form.
      constructor... }
Qed.

Lemma equiv_env_wf_env : forall E1 E2,
    equiv_env E1 E2 ->
    wf_env E1 ->
    wf_env E2.
Proof with auto.
  intros.
  induction H...
  - inversion H0;subst. constructor...
    destruct H2. get_well_form...
  - inversion H0;subst. constructor...
    destruct H2. get_well_form...
  - inversion H0;subst. constructor...
    destruct H2. get_well_form...
Qed.

Lemma equiv_env_WF_var : forall E1 E2 (X:atom),
    equiv_env E1 E2 ->
    WF E1 X ->
    WF E2 X.
Proof with auto.
  intros.
  inversion H0;subst.
  + apply equiv_env_binds with (E2:=E2) in H3...
    destruct_hypos. apply WF_var with (U:=x)...
  + apply equiv_env_binds_lb with (E2:=E2) in H3...
    destruct_hypos. apply WF_var_lb with (U:=x)...
Qed.

Lemma equiv_env_to_wf_env: forall E1 E2,
    equiv_env E1 E2 ->
    wf_env E2.
Proof with auto.
  intros. induction H...
  + constructor... destruct H1. get_well_form...
  + constructor... destruct H1. get_well_form...
  + constructor... destruct H1. get_well_form...
Qed.

Lemma equiv_env_WF : forall E1 E2 (X:typ),
    equiv_env E1 E2 ->
    WF E1 X ->
    WF E2 X.
Proof with auto.
  intros. revert H. revert E2. dependent induction H0;intros...
  + apply equiv_env_binds with (E2:=E2) in H...
    destruct_hypos. apply WF_var with (U:=x)...
  + apply equiv_env_binds_lb with (E2:=E2) in H...
    destruct_hypos. apply WF_var_lb with (U:=x)...
  + apply WF_all with (L:=L \u dom E2)...
    intros. specialize_x_and_L X L.
    apply H1... constructor...
    apply equiv_reflexivity...
    apply equiv_env_to_wf_env in H2...
  + apply WF_all_lb with (L:=L \u dom E2)...
    intros. specialize_x_and_L X L.
    apply H1... constructor...
    apply equiv_reflexivity...
    apply equiv_env_to_wf_env in H2...
  + apply WF_rec with (L:=L \u dom E2)...
    * intros. specialize_x_and_L X L.
      apply H0... constructor...
      apply equiv_reflexivity...
      apply equiv_env_to_wf_env in H3...
    * intros. specialize_x_and_L X L.
      apply H2... constructor...
      apply equiv_reflexivity...
      apply equiv_env_to_wf_env in H3...
Qed.

Lemma equiv_env_sub : forall A B (* C D *) E1 E2,
    equiv_env E1 E2 ->
    sub E1 A B ->
    (* equiv E2 A C -> equiv E2 B D -> *)
    sub E2 A B.
Proof with auto.
  intros.
  generalize dependent E2.
  (* revert C D. *)
  induction H0;intros...
  -
    constructor. apply equiv_env_wf_env with (E1:=E)...
  -
    constructor... apply equiv_env_wf_env with (E1:=E)...
    inversion H0;subst.
    + apply equiv_env_binds with (E2:=E2) in H4...
      destruct_hypos. apply WF_var with (U:=x)...
    + apply equiv_env_binds_lb with (E2:=E2) in H4...
      destruct_hypos. apply WF_var_lb with (U:=x)...
  -
    constructor... apply equiv_env_wf_env with (E1:=E)...
    apply equiv_env_WF with (E1:=E)...
  -
    pose proof equiv_env_binds _ _ H1 H.
    destruct_hypos.
    (* unfold equiv in H2, H3. destruct_hypos. *)
    apply sa_trans_tvar with (U:=x)...
    (* destruct H7. *)
    eapply sub_transitivity with (Q:=U)...
    destruct H3...
  -
    pose proof equiv_env_binds_lb _ _ H1 H.
    (* unfold equiv in H2, H3.  *)
    destruct_hypos.
    apply sa_trans_tvar_lb with (U:=x)...
    eapply sub_transitivity with (Q:=U)...
    destruct H3...
  -
    apply sa_all with (L:=L \u dom E2).
    + apply IHsub1...
    + apply IHsub2...
    + intros. specialize_x_and_L X L.
      apply H0... constructor...
      apply equiv_reflexivity...
      { apply equiv_env_to_wf_env in H1... }
      { get_well_form... apply equiv_env_WF with (E1:=E)... }
  -
    apply sa_all_lb with (L:=L \u dom E2).
    + apply IHsub1...
    + apply IHsub2...
    + intros. specialize_x_and_L X L.
      apply H0... constructor...
      apply equiv_reflexivity...
      { apply equiv_env_to_wf_env in H1... }
      { get_well_form... apply equiv_env_WF with (E1:=E)... }
  -
    apply sa_rec with (L:=L \u dom E2).
    + intros. specialize_x_and_L X L.
      eapply equiv_env_WF. 2:{ eassumption. }
      constructor... apply equiv_reflexivity...
      apply equiv_env_to_wf_env in H3...
    + intros. specialize_x_and_L X L.
      eapply equiv_env_WF. 2:{ eassumption. }
      constructor... apply equiv_reflexivity...
      apply equiv_env_to_wf_env in H3...
    + intros. specialize_x_and_L X L.
      apply H2... constructor...
      apply equiv_reflexivity...
      { apply equiv_env_to_wf_env in H3... }
Qed.

Lemma equiv_env_refl: forall E,
  wf_env E ->
    equiv_env E E.
Proof with auto.
  induction E.
  - constructor.
  - intros. inversion H;subst.
    specialize (IHE H2).
    + constructor... apply equiv_reflexivity...
    + constructor... apply equiv_reflexivity...
    + constructor... apply equiv_reflexivity...
Qed.

Lemma equiv_env_subst_tb: forall E1 E2 X D S,
  wf_env (E1 ++ (X ~ bind_sub typ_top) ++ E2) ->
  equiv E2 S D ->
  equiv_env (map (subst_tb X D) E1 ++E2) (map (subst_tb X S) E1 ++ E2).
Proof with auto.
  intros.
  induction E1.
  + apply equiv_env_refl... apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    destruct H0. get_well_form...
  + destruct a. simpl in H. destruct H0.
    destruct b;inversion H;subst;simpl.
    * constructor...
      split.
      - apply equiv_sub_subst_not_var.
        { apply Reflexivity... }
        { split... } { split... }
        { apply equiv_reflexivity;get_well_form... }
      - apply equiv_sub_subst_not_var.
        { apply Reflexivity... }
        { split... }
        { apply equiv_reflexivity;get_well_form... }
        { split... }
    * constructor... split.
      - apply equiv_sub_subst_not_var.
        { apply Reflexivity... }
        { split... } { split... }
        { apply equiv_reflexivity;get_well_form... }
      - apply equiv_sub_subst_not_var.
        { apply Reflexivity... }
        { split... }
        { apply equiv_reflexivity;get_well_form... }
        { split... }
    * constructor... split.
      - apply equiv_sub_subst_not_var.
        { apply Reflexivity... }
        { split... } { split... }
        { apply equiv_reflexivity;get_well_form... }
      - apply equiv_sub_subst_not_var.
        { apply Reflexivity... }
        { split... }
        { apply equiv_reflexivity;get_well_form... }
        { split... }
Qed.
(*

Lemma equiv_sub_subst_map: forall (A B : typ) (X : atom)
(E E1 E2 : list (atom * binding)) ( D S : typ),
    X \notin fv_tt D \u fl_env E1 \u fl_env E2 \u fl_tt A \u fl_tt B \u dom E1 \u dom E2 \u fv_tt S \u fl_tt D \u fl_tt S ->
  sub (E ++ map (subst_tb X D) E1 ++ E2) A B ->
  equiv E2 S D ->
  sub (E ++ map (subst_tb X S) E1 ++ E2) A B.
Proof with auto.
  intros.
  dependent induction H0...
  - admit.
  - admit.
  - admit.
  -
    apply sa_trans_tvar with (U:=U).
    2:{
        apply IHsub with (D0:=D)... solve_notin. admit.
    }

Lemma equiv_sub_subst_map: forall (A B : typ) (X : atom)
(E1 E2 : list (atom * binding)) (C D S : typ),
    X \notin fv_tt C \u fv_tt D \u fl_env E1 \u fl_env E2 \u fl_tt A \u fl_tt B \u dom E1 \u dom E2 \u fv_tt S \u fl_tt C \u fl_tt D \u fl_tt S ->
  sub (map (subst_tb X D) E1 ++ E2) (subst_tt X C A) (subst_tt X D B)->
  equiv E2 C D ->
  equiv E2 C S ->
  equiv E2 S D ->
  sub (map (subst_tb X S) E1 ++ E2) (subst_tt X C A) (subst_tt X D B).

Lemma equiv_sub_subst_map: forall (A B : typ) (X : atom)
(E1 E2 : list (atom * binding)) (C D S : typ),
    X \notin fv_tt C \u fv_tt D \u fl_env E1 \u fl_env E2 \u fl_tt A \u fl_tt B \u dom E1 \u dom E2 \u fv_tt S \u fl_tt C \u fl_tt D \u fl_tt S ->
  sub (map (subst_tb X D) E1 ++ E2) (subst_tt X C A) (subst_tt X D B)->
  equiv E2 C D ->
  equiv E2 C S ->
  equiv E2 S D ->
  sub (map (subst_tb X S) E1 ++ E2) (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros. unfold equiv in *. destruct_hypos.
  assert (Hwfe: wf_env (map (subst_tb X S) E1 ++ E2)).
  { get_well_form.
    apply wf_env_subst_map with (S:=D)...
  }
  dependent induction H0.
  - rewrite <- x0. rewrite <- x. constructor...
  - rewrite <- x0. rewrite <- x.
    get_well_form.
    constructor...
    admit.
  - rewrite <- x. constructor...
    admit.
  -
    (* X0 <: U <: B [->D] *)
    destruct A;inversion x. simpl in *.
    destruct (a == X);inversion H9.
    + subst.
      apply sa_trans_tvar with (U:=subst_tt X C U)...
      *  admit.
      * apply IHsub...
        { solve_notin. apply notin_fl_env with (Y:=X) in H1...
          apply fl_env_not_int_subst_tb... }
        { rewrite <- subst_tt_fresh... get_well_form.
          apply WF_imply_dom in H20...
          rewrite dom_app in H20. rewrite dom_map in H20.
          intros c. apply H20 in c. admit. }
 *)

(*

     }
  constructor...
    admit.

  unfold equiv in *. destruct_hypos.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  revert A B X E2.
  induction E1;intros...
  destruct a as [X0 b].
  Search sub.

  induction A;intros.
  -
    simpl in H. dependent destruction H.
    + dependent destruction B;try solve [inversion x].
      * constructor... get_well_form. eapply wf_env_subst_map; eassumption.
      * simpl in *. destruct (a == X);inversion x.
        constructor... get_well_form. eapply wf_env_subst_map; eassumption.
    + dependent destruction B;try solve [inversion x].

Check subst_reverse_equiv.

      }

  induction B;intros;try solve
    [constructor;get_well_form;eapply wf_env_subst_map;eassumption
    ]...
  { constructor.

  get_well_form...

  }

  ...
  - induction A;try solve [inversion x0
      |simpl in *;destruct (a==X);inversion x0]...
      2:{ simpl in *. destruct (a == X);inversion x0.
      2:{ inversion x0. } inversion x0. }
    dependent destruction Hwf2;try solve [inversion x
      |simpl in *;destruct (X0==X);inversion x]...
 *)

Check sub_narrowing.

Lemma sub_generalize_intensive : forall E1 E2 A B C D X m S,
    (* sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B -> *)
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) B ->
    X \notin fv_tt C \u fv_tt D \u fl_env E1 \u fl_env E2 \u fl_tt A \u fl_tt B \u dom E1 \u dom E2 \u fv_tt S \u fl_tt C \u fl_tt D \u fl_tt S ->
    sub (map (subst_tb X (typ_label X (open_tt S X))) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X (typ_label X (open_tt C X)) A) (subst_tt X (typ_label X  (open_tt D X)) B) ->
    sub E2 (typ_mu (choose m C S))  (typ_mu (choose m S C)) ->
    sub E2 (typ_mu (choose m S D))  (typ_mu (choose m D S)) ->
    sub (map (subst_tb X (typ_mu S)) E1 ++ E2) (subst_tt X (typ_mu C) A) (subst_tt X (typ_mu D) B).

(* Lemma sub_generalize_intensive : forall E1 E2 A B C D X m S G,
(* sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B -> *)
WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
WF (E1 ++ X ~ bind_sub typ_top ++ E2) B ->
X \notin fv_tt C \u fv_tt D \u fl_env E1 \u fl_env E2 \u fl_tt A \u fl_tt B \u dom E1 \u dom E2 \u fv_tt S \u fl_tt C \u fl_tt D \u fl_tt S ->
sub G (subst_tt X (typ_label X (open_tt C X)) A) (subst_tt X (typ_label X  (open_tt D X)) B) ->
sub E2 (typ_mu (choose m C S))  (typ_mu (choose m S C)) ->
sub E2 (typ_mu (choose m S D))  (typ_mu (choose m D S)) ->
equiv_env  G (map (subst_tb X (typ_label X (open_tt S X))) E1 ++ X ~ bind_sub typ_top ++ E2) ->
sub  (map (subst_tb X (typ_mu S)) E1 ++ E2)
  (subst_tt X (typ_mu C) A) (subst_tt X (typ_mu D) B). *)
Proof with auto.
  intros E1 E2 A B C D X m S Hwf1 Hwf2 Hx Hsub H1 H2.
  assert (Hwfe: wf_env (map (subst_tb X (typ_mu S)) E1 ++ E2)).
  { destruct m; get_well_form...
    + apply wf_env_subst_tb with (Q:=typ_top)...
      apply subst_tb_wf_env_reverse with (T:=(typ_label X (open_tt S X)))...
      (* { apply equiv_env_to_wf_env in Heqenv... } *)
      constructor.
      inversion H4;subst.
      pick_fresh Y. add_nil.
      apply WF_replacing_var with (X:=Y)...
    + apply wf_env_subst_tb with (Q:=typ_top)...
      apply subst_tb_wf_env_reverse with (T:=(typ_label X (open_tt S X)))...
      (* { apply equiv_env_to_wf_env in Heqenv... } *)
      constructor.
      inversion H3;subst.
      pick_fresh Y. add_nil.
      apply WF_replacing_var with (X:=Y)...
  }
  generalize dependent m.
  (* generalize dependent E1.
  generalize dependent E2. *)
  dependent induction Hsub;intros...
  -
    (* nat <: nat *)
    dependent destruction Hwf1;try solve [inversion x0
      |simpl in *;destruct (X0==X);inversion x0]...
    dependent destruction Hwf2;try solve [inversion x
      |simpl in *;destruct (X0==X);inversion x]...
    (* eapply equiv_env_sub. apply Heqenv. auto. *)
  -
    (* X <: X *)
    (* eapply equiv_env_sub. apply Heqenv. *)
    dependent destruction Hwf1;try solve [inversion x0].
    + simpl in *. destruct (X1 == X);inversion x0;subst...
      dependent destruction Hwf2;try solve [inversion x].
      * simpl in *. destruct (X0 == X);inversion x;subst...
        apply sa_fvar... apply WF_var with (U:=subst_tt X (typ_mu S) U)...
        admit.
      * simpl in *. destruct (X0 == X);inversion x;subst...
        pose proof binds_ub_lb_invalid _ _ _ H2 H1.
        destruct H5... apply uniq_from_wf_env.
        admit.
    + simpl in *. destruct (X1 == X);inversion x0;subst...
      dependent destruction Hwf2;try solve [inversion x].
      * simpl in *. destruct (X0 == X);inversion x;subst...
        pose proof binds_ub_lb_invalid _ _ _ H1 H2.
        destruct H5... apply uniq_from_wf_env.
        admit.
      * simpl in *. destruct (X0 == X);inversion x;subst...
        apply sa_fvar... apply WF_var_lb with (U:=subst_tt X (typ_mu S) U)...
        admit.
  -
    (* A <: Top *)
    (* eapply equiv_env_sub. apply Heqenv. *)
    dependent destruction Hwf2;try solve [inversion x
      |simpl in *;destruct (X0==X);inversion x]...
    simpl. apply sa_top... admit.
  -
    (* X0 <: U <: [X |-> <X, D>] B *)
    (* eapply equiv_env_sub. apply Heqenv. *)
    dependent destruction Hwf1;try solve [inversion x
    |simpl in *;destruct (X0==X);inversion x]...
    2:{
      simpl in x. destruct (X1 == X);try solve [inversion x].
      inversion x.
      rewrite H4 in H.
      (* contradiction lb/ub*)
      admit.
    }
    simpl in x. destruct (X1 == X);try solve [inversion x].
    inversion x;subst. simpl.
    destruct (X1 ==X);try contradiction.
    (* pose proof equiv_env_binds. _ _ Heqenv. H0. *)
    (* assert (exists E1' E2',
    E = (map (subst_tb X (typ_label X (open_tt S X))) E1' ++
    X ~ bind_sub typ_top ++ E2')
    ) by admit.
    destruct H3 as [E']. destruct_hypos. subst. *)
    (* apply equiv_env_sub with (E1:= E')... { } *)
    apply sa_trans_tvar with (U:= subst_tt X (typ_mu S) U0)...
    +
      apply binds_map_free_sub with (Q:=typ_top)...
      (* wf_env *) admit.
    +

      apply IHHsub with (m:=m)...
      *
      (* pose proof equiv_env_binds _ _ Heqenv H.
        destruct_hypos.
        apply binds_map_free_env with (S:=typ_label X (open_tt S X)) in H0...
        2:{ admit. }
        pose proof binds_unique _ _ _ _ _ H3 H0.
        assert (uniq
        (map (subst_tb X (typ_label X (open_tt S X))) E1 ++
         X ~ bind_sub typ_top ++ E2)) by admit.
         apply H5 in H6. inversion H6... *)
         admit.
      *
        solve_notin. (* X notin fl_tt U0, can workaround? *)
        admit.
      *
        apply binds_map_free_sub with (S:=(typ_label X (open_tt S X))) in H0... 2:{ admit. }
        assert (binds X1 (bind_sub (subst_tt X (typ_label X (open_tt S X)) U0))
        (map (subst_tb X (typ_label X (open_tt S X))) E1 ++
         X ~ bind_sub typ_top ++ E2))...
        assert (wf_env (map (subst_tb X (typ_label X (open_tt S X))) E1 ++
        X ~ bind_sub typ_top ++ E2)). { admit. }
        pose proof binds_uniq _ _ _ H4 H H3...
      * get_well_form. apply Reflexivity...
        destruct m...
  -
    (* [X |-> <X, C>] A <: U <: X  *)
    (* eapply equiv_env_sub. apply Heqenv.
    dependent destruction Hwf2;try solve [inversion x
    |simpl in *;destruct (X0==X);inversion x]...
    {
      simpl in x. destruct (X1 == X);try solve [inversion x].
      inversion x;subst.
      (* contradiction lb/ub*)
      admit.
    }
    simpl in x. destruct (X1 == X);try solve [inversion x].
    inversion x;subst. simpl.
    destruct (X1 ==X);try contradiction.
    apply sa_trans_tvar_lb with (U:= subst_tt X (typ_mu S) U0)...
    +
      apply binds_map_free_sub2 with (Q:=typ_top)...
      admit. (* wf_env easy *)
    +
      apply IHHsub with (m:=m)(S0:=S) (E3:=E2) (E4:=E1)...
      * apply WF_from_binds_typ_lb with (x:=X1)...
        admit. (* wf_env *)
      * apply binds_map_free_env_lb with (S:=typ_label X (open_tt S X)) in H0...
        2:{ (* wf_env *) admit. }
        pose proof binds_unique _ _ _ _ _ H H0.
        assert (uniq
        (map (subst_tb X (typ_label X (open_tt S X))) E1 ++
        X ~ bind_sub typ_top ++ E2)) by admit.
        apply H3 in H4. inversion H4...
      * solve_notin. (* X notin fl_tt U0, can workaround? *)
      admit.
      * apply equiv_env_refl...
      * get_well_form. apply Reflexivity...
        destruct m... *)
    admit.
  -
    (* A1 -> A2 <: B1 -> B2 *)
    (* eapply equiv_env_sub. apply Heqenv. *)
    dependent destruction Hwf1;try solve [inversion x0
    |simpl in *;destruct (X0==X);inversion x0]...
    dependent destruction Hwf2;try solve [inversion x
      |simpl in *;destruct (X0==X);inversion x]...
    simpl in x0. inversion x0.
    simpl in x. inversion x.
    simpl.
    apply sa_arrow.
    +
      apply IHHsub1 with (m:=flip m)(S0:=S) (E3:=E2) (E4:=E1)...
      * solve_notin. admit. admit.
      (* * apply equiv_env_refl... *)
      * destruct m;simpl in *...
      * destruct m;simpl in *...
    +
      apply IHHsub2 with (m:=m)(S0:=S) (E3:=E2) (E4:=E1)...
      * solve_notin. admit. admit.
      (* * apply equiv_env_refl... *)
  -
    (* ALL S1. T1 <: ALL S2. T2  *)
    (* eapply equiv_env_sub. apply Heqenv. *)
    dependent destruction Hwf1;try solve [inversion x0
    |simpl in *;destruct (X0==X);inversion x0]...
    dependent destruction Hwf2;try solve [inversion x
      |simpl in *;destruct (X0==X);inversion x]...
    simpl in x0. inversion x0.
    simpl in x. inversion x.
    assert (type4rec T0) by admit.
    assert (type4rec T4) by admit.
    assert (Heqv: equiv (E1 ++ (X ~ bind_sub typ_top) ++ E2) T0 T4).
    {
      rewrite <- drop_label_reverse_env with (E:=E1) (X:=X) (U:=open_tt S X)...
      replace T0 with (subst_label X S1).
      2:{ rewrite H6. rewrite drop_label_reverse_type... admit. }
      replace T4 with (subst_label X S2).
      2:{ rewrite H8. rewrite drop_label_reverse_type... admit. }
      split.
      + apply open_twice_to_one...
      + apply open_twice_to_one...
    }
    clear IHHsub1.  clear IHHsub2.
    destruct Heqv as [Heqv1 Heqv2].
    pose proof @subst_reverse_equiv T0 H5 T4 H10 X C D E1 E2 S.
    destruct H11...
    { solve_notin. admit. admit. }
    { rewrite <- H6. rewrite <- H8. unfold equiv... }
    { split... }
    { admit. }
    { admit. }
    { admit. }
    { admit. }
    + (* C = D *)
      assert (equiv E2 (typ_mu C) (typ_mu D)).
      {
        unfold equiv in *.
        destruct_hypos.
        split.
        apply  equiv_sub_unfolding with (Y:=X)...
        apply  equiv_sub_unfolding with (Y:=X)...
      }
      assert (equiv E2 (typ_mu C) (typ_mu S)).
      {
        unfold equiv in *.
        destruct_hypos.
        destruct m;simpl in *.
        split...
        apply sub_transitivity with (Q:=typ_mu D)...
        split...
        apply sub_transitivity with (Q:=typ_mu D)...
      }
      assert (equiv E2 (typ_mu S) (typ_mu D)).
      {
        unfold equiv in *.
        destruct_hypos.
        destruct m;simpl in *.
        split...
        apply sub_transitivity with (Q:=typ_mu C)...
        split...
        apply sub_transitivity with (Q:=typ_mu C)...
      }

    (* eapply sub_transitivity with (Q:= subst_tt X (typ_mu S) (typ_all T4 T5)).
    2:{
      apply equiv_sub_subst_not_var...
      apply Reflexivity... admit.
      get_well_form...
      unfold equiv in *. destruct_hypos.
      get_well_form. apply equiv_reflexivity...
    }  *)
    simpl.
    apply sa_all with (L:=L \u L0 \u L1 \u {{X}});intros...
    --
      apply equiv_sub_subst_not_var...
      (* apply equiv_reflexivity;unfold equiv in *;destruct_hypos;
      get_well_form;try split...  *)
    --
      apply equiv_sub_subst_not_var;
      unfold equiv in *;destruct_hypos;try split...
      (* apply Reflexivity;unfold equiv in *;destruct_hypos;
      get_well_form;try split...
      apply Reflexivity;unfold equiv in *;destruct_hypos;
      get_well_form;try split... *)
    --
    (* Check su?b_narrowing. *)
    add_nil.
    apply sub_narrowing with (Q:= subst_tt X (typ_mu S) T4).
      {
        (* apply equiv_sub_subst_not_var... *)
      admit.

      }

      rewrite_env (map (subst_tb X (typ_mu S)) (X0 ~ bind_sub T4 ++ E1) ++ E2).

      rewrite subst_tt_open_tt_var...
      2:{ unfold equiv in *;get_well_form;destruct_hypos;get_type... }
      rewrite subst_tt_open_tt_var...
      2:{ unfold equiv in *;get_well_form;destruct_hypos;get_type... }
     specialize_x_and_L X0 L.
    (* specialize (@H0 S X S C (open_tt T5 X0) (open_tt T3 X0) E2
      ((X0 ~ bind_sub T4) ++ E1)
    ). *)

    (* apply sub_transitivity with (Q:=subst_tt X (typ_mu S) (open_tt T5 X0)).
    2:{ apply equiv_sub_subst_not_var... apply Reflexivity. admit. admit. apply equiv_reflexivity. admit. admit. } *)

    apply H0 with (m:=m)...
    4:{  }

      (* apply H0 with (m:=m) (X1:=X0)(S0:=D)(E3:=E2)(E4:=(X0 ~ bind_sub T4) ++ E1) ... *)
      * specialize_x_and_L X0 L0. rewrite app_assoc.
        add_nil. apply WF_narrowing with (V := T0)...
      * specialize_x_and_L X0 L1. rewrite app_assoc.
        add_nil. apply WF_narrowing with (V := T4)...
      * solve_notin. admit. admit. admit.
      (* TODO: need equivalent context! *)
      * rewrite H8. simpl. rewrite subst_tt_open_tt...
        simpl. destruct (X0 == X)... subst. exfalso. apply H15...
        admit.
      * rewrite H7. rewrite subst_tt_open_tt...
        simpl. destruct (X0 == X)... subst. exfalso. apply H15...
        admit.
      * rewrite H9. rewrite subst_tt_open_tt...
        simpl. destruct (X0 == X)... subst. exfalso. apply H15...
        admit.
      * admit.
        * admit.
        (* * solve_notin. admit. *)

    + (* X notin *) simpl.
    assert (subst_tt X (typ_mu C) T0 = subst_tt X (typ_mu S) T0) as HS1.
    {
      rewrite <- subst_tt_fresh...
      rewrite <- subst_tt_fresh...
    }
    assert (subst_tt X (typ_mu D) T4 = subst_tt X (typ_mu S) T4) as HS2.
    {
      rewrite <- subst_tt_fresh...
      rewrite <- subst_tt_fresh...
    }
    rewrite HS1.
    rewrite HS2.
    assert (equiv E2 (typ_mu S) (typ_mu S)).
    {
      unfold equiv;split;apply Reflexivity;get_well_form;auto;
        destruct m;simpl in *...
    }
    apply sa_all with (L:=L \u L0 \u L1 \u {{X}});intros...
    --
      apply equiv_sub_subst_not_var...
    --
      apply equiv_sub_subst_not_var...
    --
      assert (type (typ_mu D)).
      destruct m;simpl in *;get_type...
      assert (type (typ_mu C)).
      destruct m;simpl in *;get_type...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env  ( map (subst_tb X (typ_mu S)) (X0 ~ bind_sub T4 ++ E1) ++ E2).
      apply H0 with (m:=m) (X0:=X0)...
      * specialize_x_and_L X0 L0. rewrite app_assoc.
        add_nil. apply WF_narrowing with (V := T0)...
      * specialize_x_and_L X0 L1. rewrite app_assoc.
        add_nil. apply WF_narrowing with (V := T4)...
      * simpl. rewrite H8.
        rewrite <- !subst_tt_fresh with (T:=T4)...
      * rewrite H7. rewrite subst_tt_open_tt...
        simpl. destruct (X0 == X)... subst. exfalso. apply H13...
        admit.
      * rewrite H9. rewrite subst_tt_open_tt...
        simpl. destruct (X0 == X)... subst. exfalso. apply H13...
        admit.
      * admit.
      * admit.

  -
  (* ALL X0 :> S1. T1 <: ALL X0 :> S2. T2  *)
    admit.

  -
  (* Rec X0. T1 <: Rec X0. T2  *)
    admit.

  -
  (* Label X0. T1 <: Label X0. T2  *)
  admit.

Admitted. *)

Lemma sub_generalize_intensive : forall E1 E2 A B C D X m S,
    sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B ->
    X \notin fv_tt C \u fv_tt D \u fl_env E1 \u fl_env E2 \u fl_tt A \u fl_tt B \u dom E1 \u dom E2 \u fv_tt S \u fl_tt C \u fl_tt D \u fl_tt S ->
    sub (map (subst_tb X (typ_label X (open_tt S X))) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X (typ_label X (open_tt C X)) A) (subst_tt X (typ_label X  (open_tt D X)) B) ->
    sub E2 (typ_mu (choose m C S))  (typ_mu (choose m S C)) ->
    sub E2 (typ_mu (choose m S D))  (typ_mu (choose m D S)) ->
    sub (map (subst_tb X (typ_mu S)) E1 ++ E2) (subst_tt X (typ_mu C) A) (subst_tt X (typ_mu D) B).
Proof with auto.
  intros.
  generalize dependent m.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction H;intros...
  -
    simpl.
    constructor...
    apply subst_tt_wf_env_label_rec...
    get_well_form...
    destruct m;simpl in *;get_well_form...
  -
    simpl in *.
    destruct (X0==X);subst...
    +
      assert (wf_env (empty ++ map (subst_tb X (typ_mu S)) E1 ++ E2)).
      apply subst_tt_wf_env_label_rec...
      get_well_form...
      destruct m;simpl in *;get_well_form...
      rewrite_env (nil ++ map (subst_tb X (typ_mu S)) E1 ++ E2).
      apply Sub_weakening...
      destruct m;simpl in *...
      *
        apply sub_transitivity with (Q:=typ_mu S)...
      *
        assert (sub E2 (typ_mu D) (typ_mu C)).
        {
          apply sub_transitivity with (Q:=typ_mu S)...
        }
        dependent destruction H6.
        dependent destruction H2.
        apply sub_strengthening_env in H2...
        --
          pick fresh Y.
          apply equiv_sub_unfolding with (Y:=Y)...
          apply sub_replacing_var with (X:=X)...
          constructor...
          get_well_form...
          specialize_x_and_L Y L.
          apply sub_nominal_inversion in H8...
        --
          constructor...
          get_well_form...
        --
          pick fresh Y.
          apply WF_replacing_var with (X:=Y)...
        --
          pick fresh Y.
          apply WF_replacing_var with (X:=Y)...
    +
      constructor...
      apply subst_tt_wf_env_label_rec...
      get_well_form...
      destruct m;simpl in *;get_well_form...
      assert (typ_fvar X0 = subst_tt X (typ_mu S) (typ_fvar X0)).
      simpl...
      destruct (X0==X);subst...
      destruct n...
      rewrite H5.
      apply subst_tb_wf with (Q:=bind_sub typ_top)...
      destruct m;simpl in *;get_well_form...
  -
    simpl.
    constructor...
    apply subst_tt_wf_env_label_rec...
    get_well_form...
    destruct m;simpl in *;get_well_form...
    rewrite_env (nil ++ map (subst_tb X (typ_mu S)) E1 ++ E2).
    apply  WF_narrowing_env with (S:=typ_mu C).
    apply subst_tb_wf with (Q:=bind_sub typ_top)...
    destruct m;simpl in *;get_well_form...
  -
    simpl in *.
    destruct (X0==X);subst...
    +
      analyze_binds_uniq H.
      apply uniq_from_wf_env...
      get_well_form...
      inversion BindsTacVal;subst.
      dependent destruction H0.
      * (* top *)
        simpl...
        constructor...
        apply subst_tt_wf_env_label_rec...
        get_well_form...
        destruct m;simpl in *;get_well_form...
        rewrite_env (nil ++ map (subst_tb X (typ_mu S)) E1 ++ E2).
        apply  WF_narrowing_env with (S:=typ_mu C).
        apply WF_weakening...
        destruct m;simpl in *;get_well_form...
      * (* top + lbvar *)
        simpl... destruct (X0 == X). { subst. apply binds_mid_eq in H... inversion H. }
        eapply sa_trans_tvar_lb with (U:=subst_tt X (typ_mu S) U)...
        { apply binds_map_free_sub2 with (S:=(typ_mu S)) in H...
          get_well_form... }
        eapply sub_transitivity with (Q:=subst_tt X (typ_mu S) typ_top).
        { constructor...
          apply subst_tt_wf_env_label_rec...
          get_well_form...
          destruct m;simpl in *;get_well_form...
          rewrite_env (nil ++ map (subst_tb X (typ_mu S)) E1 ++ E2).
          apply  WF_narrowing_env with (S:=typ_mu C).
          apply WF_weakening...
          destruct m;simpl in *;get_well_form... }
        { apply sub_through_subst_tt with (Q:=typ_top)...
          constructor;get_well_form... destruct m... }
    +
      destruct ( EqDec_eq T  (typ_fvar X0)).
      *
        induction T;try solve [inversion e].
        rewrite e in *.
        simpl...
        destruct (X0==X);subst...
        destruct n...
        constructor...
        apply subst_tt_wf_env_label_rec...
        get_well_form...
        destruct m;simpl in *;get_well_form...
        apply WF_var with (U:=subst_tt X (typ_mu S) U)...
        apply binds_map_free_env2...
        get_well_form...
      *
        apply sub_tvar_trans_var' with (A:=subst_tt X (typ_label X (open_tt S X)) U) in H2...
        destruct H2.
        { induction T;simpl;try solve [inversion H2];simpl in H2...
            destruct (a==X);subst... inversion H2. exfalso... }
             (* contradiction.
            intros v;inversion v. } *)

        2:{ apply binds_map_free_env...
            get_well_form... }

        destruct H2.
        -- (* normal case: A = X0 <: U <: T = B*)
          apply sa_trans_tvar with (U:=subst_tt X (typ_mu S) U)...
          ++
            apply binds_map_free_env2...
            get_well_form...
          ++
            apply IHsub with (m:=m)...
            **
              solve_notin.
              apply notin_fl_env with (X:=X0) (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
              solve_notin.
            **
              destruct m;simpl in *;apply Reflexivity;get_well_form...
        -- (* lower bound case: A = X0 <: U <: T <: X1 = B *)
          destruct H2 as [Y [U']]. destruct_hypos.
          induction T;simpl;try solve [inversion H2]...
          simpl in H2.
          destruct (a==X);subst...
          { inversion H2. }
          inversion H2. subst a.

          inversion H0;subst.
          { admit.  }
          { admit. }
          {  }

          apply sa_trans_tvar with (U:=subst_tt X (typ_mu S) U)...
          ++
            apply binds_map_free_env2...
            get_well_form...
          ++
            replace (typ_fvar a) with (subst_tt X (typ_mu D) a).
            2:{ simpl. destruct (a==X)... contradiction.  }
            apply IHsub with (m:=m)...

              (* ---------- *)
        apply sa_trans_tvar with (U:=subst_tt X (typ_mu S) U)...
        +++
          apply binds_map_free_env2...
          get_well_form...
        +++
          apply IHsub...
        --
          apply IHsub with (m:=m)...
          ++
            solve_notin.
            apply notin_fl_env with (X:=X0) (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            solve_notin.
          ++
            apply sub_tvar_trans_var'' with (A:=subst_tt X (typ_label X (open_tt S X)) U) in H2...
            **
               destruct H2 as[H2|[H2|H2]]...
               *** admit.
               *** admit.
               (* destruct H2 as [Y [U' ]]... destruct_hypos.
               rewrite H2.

               Search X0.
               eapply sa_trans_tvar_lb with (U:=U')... *)

               (* Stuck here *)

            **
              apply binds_map_free_env...
              get_well_form...
            (* **
              induction T;simpl;try solve [intros v;inversion v]...
              destruct (a==X);subst...
              intros v;inversion v. *)
          ++
            destruct m;simpl in *;apply Reflexivity;get_well_form...
  -
    simpl in *.
    dependent destruction H2.
    constructor...
    +
      apply IHsub1 with (m:=flip m)...
      destruct m;simpl in *...
      destruct m;simpl in *...
    +
      apply IHsub2 with (m:=m)...
  -
    simpl in *.
    dependent destruction H4.
    assert (equiv (map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2)
                  (subst_tt X (typ_label X (open_tt C X)) S1) (subst_tt X (typ_label X (open_tt D X)) S2)) as HE.
    {
      unfold equiv...
    }
    assert (type4rec S1) as TS1.
    {
      get_type...
      apply type_to_rec in H19...
    }
    assert (type4rec S2) as TS2.
    {
      get_type...
      apply type_to_rec in H20...
    }
    apply subst_reverse_equiv  with (B:=S2) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:=E2) (S:=S) in TS1...
    +
      destruct TS1.
      *
        assert (equiv E2 (typ_mu C) (typ_mu D)).
          {
            unfold equiv in *.
            destruct_hypos.
            split.
            apply  equiv_sub_unfolding with (Y:=X)...
            apply  equiv_sub_unfolding with (Y:=X)...
          }
          assert (equiv E2 (typ_mu C) (typ_mu S)).
          {
            unfold equiv in *.
            destruct_hypos.
            destruct m;simpl in *.
            split...
            apply sub_transitivity with (Q:=typ_mu D)...
            split...
            apply sub_transitivity with (Q:=typ_mu D)...
          }
          assert (equiv E2 (typ_mu S) (typ_mu D)).
          {
            unfold equiv in *.
            destruct_hypos.
            destruct m;simpl in *.
            split...
            apply sub_transitivity with (Q:=typ_mu C)...
            split...
            apply sub_transitivity with (Q:=typ_mu C)...
          }
        apply sa_all with (L:=L \u L0  \u {{X}});intros...
        --
          apply equiv_sub_subst_not_var...
        --
          apply equiv_sub_subst_not_var;unfold equiv in *;destruct_hypos;try split...
        --
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          rewrite_env  (nil ++ X0 ~ bind_sub (subst_tt X (typ_mu D) S2) ++ map (subst_tb X (typ_mu S)) E1 ++ E2).
          apply sub_narrowing with (Q:=subst_tt X (typ_mu S) S2)...
          ++
            apply equiv_sub_subst_refl_no_var...
            get_well_form...
            get_well_form...
            unfold equiv in *;destruct_hypos;split;apply sub_transitivity with (Q:=typ_mu C)...
            unfold equiv in *;destruct_hypos;split;apply sub_transitivity with (Q:=typ_mu C)...
            unfold equiv in *;destruct_hypos;split;apply Reflexivity;get_well_form...
          ++
            rewrite_env (map (subst_tb X (typ_mu S)) (X0 ~ bind_sub S2 ++ E1) ++ E2).
            apply H2 with (m:=m)...
            solve_notin.
            rewrite <- subst_tt_open_tt_var...
            rewrite <- subst_tt_open_tt_var...
            rewrite_env (nil ++ X0 ~ bind_sub  (subst_tt X (typ_label X (open_tt S X)) S2) ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++
                             (X, bind_sub typ_top) :: E2).
            apply sub_narrowing with (Q:= subst_tt X (typ_label X (open_tt D X)) S2)...
            apply equiv_sub_subst_refl...
            **
              get_well_form...
            **
              get_well_form...
            **
              apply equiv_unfolding...
            **
              apply equiv_unfolding...
              apply equiv_reflexivity;get_well_form...
              destruct m;simpl in *...
            **
              apply equiv_unfolding...
            **
              apply H4...
            **
              unfold equiv in *;destruct_hypos;get_type...
            **
              unfold equiv in *;destruct_hypos;get_type...
          ++
            unfold equiv in *;get_well_form;destruct_hypos;get_type...
          ++
            unfold equiv in *;get_well_form;destruct_hypos;get_type...
      *
        assert (subst_tt X (typ_mu C) S1 = subst_tt X (typ_mu S) S1) as HS1.
        {
          rewrite <- subst_tt_fresh...
          rewrite <- subst_tt_fresh...
          }
        assert (subst_tt X (typ_mu D) S2 = subst_tt X (typ_mu S) S2) as HS2.
        {
          rewrite <- subst_tt_fresh...
          rewrite <- subst_tt_fresh...
        }
        rewrite HS1.
        rewrite HS2.
        assert (equiv E2 (typ_mu S) (typ_mu S)).
        {
          unfold equiv;split;apply Reflexivity;get_well_form;auto;
            destruct m;simpl in *...
        }
        apply sa_all with (L:=L \u L0  \u {{X}});intros...
        --
          apply equiv_sub_subst_not_var...
        --
          apply equiv_sub_subst_not_var...
        --
          assert (type (typ_mu D)).
          destruct m;simpl in *;get_type...
          assert (type (typ_mu C)).
          destruct m;simpl in *;get_type...
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          rewrite_env  ( map (subst_tb X (typ_mu S)) (X0 ~ bind_sub S2 ++ E1) ++ E2).
          apply H2 with (m:=m)...
          solve_notin.
          rewrite <- subst_tt_open_tt_var...
          rewrite <- subst_tt_open_tt_var...
          rewrite_env (X0 ~ bind_sub (subst_tt X (typ_label X (open_tt S X)) S2) ++
                          map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
          assert (subst_tt X (typ_label X (open_tt S X)) S2 = subst_tt X (typ_label X (open_tt D X)) S2) as HS.
          {
            rewrite <- subst_tt_fresh...
            rewrite <- subst_tt_fresh...
          }
          rewrite HS...
          ++
            dependent destruction H10.
            constructor...
            pick fresh Y.
            rewrite subst_tt_intro with (X:=Y)...
            apply subst_tt_type...
          ++
            dependent destruction H11.
            constructor...
            pick fresh Y.
            rewrite subst_tt_intro with (X:=Y)...
            apply subst_tt_type...
    +
      unfold equiv;split...
    +
      assert (WF E2 (typ_mu C)).
      destruct m;simpl in *;get_well_form...
      dependent destruction H7...
      pick fresh Y.
      apply WF_replacing_var with (X:=Y)...
    +
      assert (WF E2 (typ_mu D)).
      destruct m;simpl in *;get_well_form...
      dependent destruction H7...
      pick fresh Y.
      apply WF_replacing_var with (X:=Y)...
    +
      assert (WF E2 (typ_mu S)).
      destruct m;simpl in *;get_well_form...
      dependent destruction H7...
      pick fresh Y.
      apply WF_replacing_var with (X:=Y)...
    +
      get_well_form...
  -
    simpl in *.
    dependent destruction H4.
    apply sa_rec with (L:=L \u L0 \u {{X}} \u fv_tt C \u fv_tt D   \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ map (subst_tb X (typ_mu S)) (X0~bind_sub typ_top ++ E1) ++ E2).
      apply WF_narrowing_env with (S:=typ_mu C)...
      apply subst_tb_wf with (Q:=bind_sub typ_top)...
      apply H...
      destruct m;simpl;get_well_form...
      destruct m;simpl;get_type...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ map (subst_tb X (typ_mu S)) (X0~bind_sub typ_top ++ E1) ++ E2).
      apply WF_narrowing_env with (S:=typ_mu D)...
      apply subst_tb_wf with (Q:=bind_sub typ_top)...
      apply H0...
      destruct m;simpl;get_well_form...
      destruct m;simpl;get_type...
    +
      assert (type (typ_mu C) /\ type (typ_mu D)).
      split;destruct m;simpl in *;get_type...
      destruct_hypos.
      rename X0 into Y.
      rewrite_env (map (subst_tb X (typ_mu S)) (Y~bind_sub typ_top ++ E1) ++ E2).
      rewrite <- mu_transform_0...
      rewrite <- mu_transform_0...
      apply H2 with (X1:=X) (X0:=Y) (m:=m)...
      *
        solve_notin.
      *
        rewrite <- mu_transform_1...
        rewrite <- mu_transform_1...
        apply H6...
        dependent destruction H11.
        pick fresh Z.
        rewrite subst_tt_intro with (X:=Z)...
        apply subst_tt_type...
        dependent destruction H10.
        pick fresh Z.
        rewrite subst_tt_intro with (X:=Z)...
        apply subst_tt_type...
  -
    simpl in *.
    dependent destruction H1.
    constructor...
    apply IHsub with (m:=m)...
Qed.

Lemma unfolding_lemma: forall E A B,
    sub E (typ_mu A) (typ_mu B) ->
    sub E (open_tt A (typ_mu A)) (open_tt B (typ_mu B)).
Proof with auto.
  intros.
  assert (Ht:=H).
  dependent destruction H.
  pick fresh X.
  rewrite subst_tt_intro with (X:=X)...
  remember (subst_tt X (typ_mu A) (open_tt A X)) .
  rewrite subst_tt_intro with (X:=X)...
  subst.
  rewrite_env (map (subst_tb X (typ_mu B)) nil ++ E).
  apply sub_generalize_intensive with (m:=Pos)...
  -
    specialize_x_and_L X L.
    apply sub_nominal_inversion in H1...
  -
    solve_notin.
  -
    simpl.
    rewrite <- subst_tt_intro...
    rewrite <- subst_tt_intro...
    apply H1...
  -
    get_well_form.
    apply Reflexivity...
Qed.


(* * Inhabited types *)

(* Author: Maximilian Wuttke *)

From Undecidability.Shared.Libs.PSL Require Prelim.
From Coq.Vectors Require Import Vector Fin.
From Undecidability.Shared.Libs.PSL Require Import FiniteTypes.FinTypes.

Class inhabitedC (X : Type) :=
    {
      default : X;
    }.

#[export]
Instance inhabited_unit : inhabitedC unit.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_True : inhabitedC True.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_inl (A B : Type) (inh_a : inhabitedC A) : inhabitedC (A + B).
Proof. constructor. left. apply default. Defined.

#[export]
Instance inhabited_inr (A B : Type) (inh_B : inhabitedC B) : inhabitedC (A + B).
Proof. constructor. right. apply default. Defined.

#[export]
Instance inhabited_option (A : Type) : inhabitedC (option A).
Proof. constructor. right. Defined.

#[export]
Instance inhabited_bool : inhabitedC bool.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_list (A : Type) : inhabitedC (list A).
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_vector (A : Type) (n : nat) (inh_A : inhabitedC A) : inhabitedC (Vector.t A n).
Proof. constructor. eapply VectorDef.const. apply default. Defined.

#[export]
Instance inhabited_fin (n : nat) : inhabitedC (Fin.t (S n)).
Proof. repeat constructor. Defined.

#[export]
Instance inhabited_nat : inhabitedC nat.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_prod (A B : Type) : inhabitedC A -> inhabitedC B -> inhabitedC (A*B).
Proof. intros ia ib. do 2 constructor; apply default. Defined.

#[export]
Instance inhabited_arrow (A B : Type) : inhabitedC B -> inhabitedC (A -> B).
Proof. intros. constructor. intros _. apply default. Defined.

#[export]
Instance inhabited_arrow_empty (B : Type) : inhabitedC (Empty_set -> B).
Proof. intros. constructor. apply Empty_set_rect. Defined.

#[export]
Instance inhabited_arrow_sum (A B C : Type) : inhabitedC (A->C) -> inhabitedC (B->C) -> inhabitedC (A+B->C).
Proof. intros iac ibc. constructor. intros [?|?]. now apply iac. now apply ibc. Defined.

#[export]
Instance inhabited_arrow_prod (A B C : Type) : inhabitedC (A->B) -> inhabitedC (A->C) -> inhabitedC (A->B*C).
Proof. intros iab iac. constructor. intros a. constructor. now apply iab. now apply iac. Defined.

(* Derive inhabitedC instances, if an instance of this type is a hypothesis *)
#[export] Hint Extern 10 => match goal with
                | [ H : ?X |- inhabitedC ?X ] => now econstructor
                end : typeclass_instances.
(*
Section Test.
  Variable lie : False.
  Compute default : False.
  Variable somebool : bool.
  (* This should prefer the instance, not the variable. *)
  Compute default : bool.
End Test.
*)


(*
 * Strong Normalization for Nested Relational Calculus.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Require Import Arith.
Require Import List.

Add Rec LoadPath "Listkit" as Listkit.

Require Import Listkit.Foreach.

Create HintDb Term.

(** Definitions *)
Inductive Ty : Set :=
  TyBase
| TyPair : Ty -> Ty -> Ty
| TyArr : Ty -> Ty -> Ty
(* | TyAny : Ty *)
| TyList : Ty -> Ty.

(** Terms *)
Inductive Term : Set :=
  TmConst
| TmVar (x : nat) : Term
| TmPair : Term -> Term -> Term
| TmProj : bool -> Term -> Term
| TmAbs : Term -> Term
| TmApp : Term -> Term -> Term
| TmNull : Term
| TmSingle : Term -> Term
| TmUnion : Term -> Term -> Term
| TmBind : Term -> Term -> Term
| TmIf : Term -> Term -> Term -> Term
| TmTable : Ty -> Term.

Notation "L @ M" := (TmApp L M) (at level 500).
Notation "〈 L , M 〉" := (TmPair L M) (at level 400).

(** Typing derivations *)
Inductive Typing env : Term -> Ty -> Set :=
| TBase : Typing env TmConst TyBase
| TVar : forall (x:nat) ty,
    value ty = nth_error env x ->
    Typing env (TmVar x) ty
| TPair : forall l m s t, Typing env l s -> Typing env m t ->
    Typing env (TmPair l m) (TyPair s t)
| TApp : forall l m a b,
    Typing env l (TyArr a b) -> Typing env m a ->
    Typing env (TmApp l m) b
| TAbs : forall n s t,
    Typing (s :: env) n t ->
    Typing env (TmAbs n) (TyArr s t)
| TProj1 : forall m s t,
    Typing env m (TyPair s t) ->
    Typing env (TmProj false m) s
| TProj2 : forall m s t,
    Typing env m (TyPair s t) ->
    Typing env (TmProj true m) t
| TSingle : forall m t,
    Typing env m t ->
    Typing env (TmSingle m) (TyList t)
| TUnion : forall m n t,
    Typing env m (TyList t) ->
    Typing env n (TyList t) ->
    Typing env (TmUnion m n) (TyList t)
| TNull : forall t,
    Typing env TmNull (TyList t)
| TBind : forall m s n t,
    Typing env m (TyList s) ->
    Typing (s::env) n (TyList t) ->
    Typing env (TmBind m n) (TyList t)
| TTable : forall r, Typing env (TmTable r) (TyList r)
.

#[export]
Hint Constructors Typing.

(** [env_typing] relates a value environment to its typing. It asserts
    the types (in a [nil] environment) of each of a series of values. *)
Definition env_typing Vs Ts :=
  ((length Vs = length Ts) *
  foreach2_ty _ _ Vs Ts (fun x y => (Typing nil x y)))%type.

(** [env_typing_env] also relates a value environment to its typing. It asserts
    the types (in a given environment) of each of a series of values. *)
Definition env_typing_env env Vs Ts :=
  ((length Vs = length Ts) *
  foreach2_ty _ _ Vs Ts (fun x y => (Typing env x y)))%type.

#[export]
Hint Unfold env_typing.

(** [env_typing_env] environments can be extended, one term-type pair at a time. *)
Lemma env_typing_intro:
  forall env V Vs T Ts,
    Typing env V T ->
    env_typing_env env Vs Ts ->
    env_typing_env env (V::Vs) (T::Ts).
Proof.
 intros.
 unfold env_typing_env in *.
 unfold foreach2_ty in *.
 simpl in *.
 intuition.
Qed.

(** [env_typing_env] environments can be destructed into their first
pair and a remaining [env_typing_env] environment. *)
Lemma env_typing_elim:
  forall env V Vs T Ts,
    env_typing_env env (V::Vs) (T::Ts) ->
    (env_typing_env env Vs Ts
    * Typing env V T).
Proof.
 intros env V Vs T Ts X.
 unfold env_typing_env in X.
 unfold foreach2_ty in X.
 unfold env_typing_env.
 simpl in *.
 intuition.
Qed.

Lemma env_typing_cons :
  forall V T Vs env,
    Typing nil V T -> env_typing Vs env -> env_typing (V::Vs) (T::env).
Proof.
 (* Could use foreach2_ty_cons, to maintain that abstraction. *)
 intros.
 simpl;  firstorder.
 unfold foreach2_ty; simpl; intuition.
Qed.

#[export]
Hint Resolve env_typing_cons : Term.

Require Import Coq.Lists.ListSet.

Require Import Listkit.Sets.

Definition set_remove := Listkit.Sets.set_remove.

(** The free variables of a Term, as a set of nats. *)
Fixpoint freevars (M:Term) : set nat :=
  match M with
  | TmConst => empty_set nat
  | TmVar x => set_add eq_nat_dec x (empty_set nat)
  | TmPair L M => set_union eq_nat_dec (freevars L) (freevars M)
  | TmProj b M => freevars M
  | TmAbs N => set_map eq_nat_dec pred
                 (set_remove _ eq_nat_dec 0 (freevars N))
  | TmApp L M => set_union eq_nat_dec (freevars L) (freevars M)
  | TmNull => empty_set nat
  | TmSingle x => freevars x
  | TmUnion a b => set_union eq_nat_dec (freevars a) (freevars b)
  | TmBind M N => set_union eq_nat_dec (freevars M)
                            (set_map eq_nat_dec pred
                                     (set_remove _ eq_nat_dec 0 (freevars N)))
  | TmIf b M N => set_union eq_nat_dec (freevars b)
                            (set_union eq_nat_dec (freevars M) (freevars N))
  | TmTable _ => empty_set nat
  end.

Definition free_in x M := set_In x (freevars M).

Definition in_env_domain (n:nat) (env:list Term) := fun x => n <= x < n+length env.
(* (* Alt definition, reuses outside_range; consider it! *)
   Definition in_env_domain (n:nat) (env:list Term) :=
   fun x => false = outside_range n (n+length env) x. *)

(* TODO: in_env_domain and outside_range are essentially logical inverses,
   but are defined in different sorts. Consolidate them! *)

Lemma in_env_domain_map :
    forall n f env, in_env_domain n (map f env) = in_env_domain n env.
 unfold in_env_domain.
 intros.
 rewrite map_length.
 auto.
Qed.

(** A term [M] is [Neutral] if, when it reduces in context, [C[M] ~> Z], the
    reduction either in C or in M:
      C[M] ~> Z  ==  C[M] ~> C[M']  or
      C[M] ~> Z  ==  C[M] ~> C'[M].
    In other words, [M] cannot react with [C] immediately.

    But we define it here by the cases that we know have that property.
    TODO: Fix that!
 *)
Inductive Neutral : Term -> Type :=
  | Neutral_App : forall L M, Neutral (TmApp L M)
  | Neutral_Proj : forall b M, Neutral (TmProj b M)
  | Neutral_Table : forall t, Neutral (TmTable t).

#[export]
Hint Constructors Neutral.

#[export]
Hint Resolve Neutral_App.
#[export]
Hint Resolve Neutral_Proj.


(* Mohamed Sami Cherif and Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* test module *)

Require Export Basics.

Require Export EnvLibA.
Require Export RelLibA.
Require Export PRelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import AbbrevA.
Require Import ModNat1A.

Module Test_Nat1 <: IdModType.

Module LM := Abbrev ModNat1.
Export LM.

Definition Id := LM.Id.
Definition IdEqDec := LM.IdEqDec.
Definition IdEq := LM.IdEq.
Definition W := LM.W.
Definition Loc_PI := LM.Loc_PI.
Definition BInit := LM.BInit.
Definition WP := LM.WP.

Open Scope string_scope.
Import ListNotations.

Definition nat_read : XFun unit nat := xf_read id.

Definition nat_write : XFun nat unit := xf_write id.

Definition nat_reset : XFun (PState nat) unit := xf_reset.

Definition nat_incr : XFun nat unit := {|
   b_mod := fun x y => (x + 1, tt)
|}.

Definition ReadN : Exp := Read NatVT id.

Definition WriteN (x: nat) : Exp := Write NatVT id x.

Definition ResetN : Exp := Reset.

Definition Incr (x: nat) : Exp :=
  Modify nat unit NatVT UnitVT nat_incr (QV (cst nat x)).

Lemma expTypingTest1 : expTypingTest (BindN ResetN ReadN) Nat.
  econstructor.
  econstructor.
  econstructor.
  constructor.
  simpl.
  auto.
  simpl.
  apply PState_ValTyp.
  constructor.
  constructor.
  constructor.
  simpl.
  auto.
  simpl.
  apply UnitVT.
Defined.

Definition Test1 (n: nat) := runTest (BindN ResetN ReadN) Nat
  expTypingTest1 n.

Lemma Test1L (n: nat) : Test1 n = cst nat 0.
  auto.
Qed.

(**************************************************)

(* line 1 : if true then 3 else 3) *)

Definition three : Exp := Val (cst nat 3).
Definition line1 : Exp := IfThenElse TrueV three three.
Lemma expTypingline1 : ExpTyping emptyE emptyE emptyE line1 Nat.
Proof.
  repeat constructor.
Defined.

Definition line1Test (n: nat) := runTest line1 Nat expTypingline1 n.

Lemma Test2 (n: nat) : line1Test n = cst nat 3.
  auto.
Defined.

Lemma Test3 (n: nat) : exists x:nat, line1Test n = cst nat x.
  eexists.
  compute.
  reflexivity.
Defined.

Eval compute in (line1Test 0).

(***********************************************)
(* binds1 : ... *)

Definition binds1 : Exp := BindS "x" (Val (cst nat 0)) (Return RR (Var "x")).

Definition expTypingTest (e: Exp) (t: VTyp): Type :=
  ExpTyping emptyE emptyE emptyE e t.

Lemma binds1typing: expTypingTest binds1 Nat.
  econstructor.
  instantiate (1:= Nat).
  constructor.
  constructor.
  reflexivity.
  repeat constructor.
  repeat constructor.
Defined.

Definition binds1Test (n: nat) := runTest binds1 Nat binds1typing n.

Lemma binds1Test_proof : binds1Test 0 = cst nat 0.
  auto.
Qed.

(*********************************************************)
(* line 2 : apply add3 to 0*)

Definition zero: Exp := Val (cst nat 0).

Definition xf_add3 : XFun nat nat := {|
   b_mod := fun st x => (st, x+3)
|}.

Definition add3': Exp := Modify nat nat NatVT NatVT xf_add3 (Var "x").
Definition add3: QFun := QF (FC emptyE [("x",Nat)] add3' zero "add3" 0).

Definition line2: Exp := Apply add3 (PS [zero]).

Lemma expTypingline2 : ExpTyping emptyE emptyE emptyE line2 Nat.
Proof.
  repeat econstructor.
Defined.

Definition line2Test (n: nat) := runTest line2 Nat
  expTypingline2 n.

Lemma line2Test_lemma1 :
  EClosure emptyE emptyE (Conf Exp 0 line2) (Conf Exp 0 three).
  unfold line2, three.
  unfold add3.
  unfold add3'.
  unfold xf_add3.
  unfold cst.
  econstructor.
  econstructor.
  econstructor.
  instantiate (1:= [(existT ValueI nat (Cst nat 0))]).
  auto.
  reflexivity.
  simpl.
  reflexivity.
  econstructor.
  econstructor.
  reflexivity.
  reflexivity.
  simpl.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  reflexivity.
  reflexivity.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
Defined.

Lemma line2Test_lemma2 :
  EClosure emptyE emptyE (Conf Exp 0 line2) (Conf Exp 0 three).
  econstructor.
  econstructor.
  econstructor.
  instantiate (1:= [(existT ValueI nat (Cst nat 0))]).
  auto.
  auto.
  auto.
  repeat econstructor.
Defined.

Lemma line2ExpTyping : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
  (k1: MatchEnvsT FunTyping fenv ftenv),
  ExpTyping ftenv tenv fenv line2 Nat.
Proof.
  intros.
  econstructor.
  reflexivity.
  assumption.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  reflexivity.
  econstructor.
  econstructor.
  econstructor.
  constructor.
  reflexivity.
  constructor.
  constructor.
Defined.

(**************************************************)

Definition line3: Exp := BindN line1 line2.
Lemma expTypingline3 : ExpTyping emptyE emptyE emptyE line3 Nat.
Proof.
econstructor.
eapply expTypingline1.
apply expTypingline2.
Defined.

Definition line3Test (n: nat) := runTest line3 Nat
  expTypingline3 n.

End Test_Nat1.


Require Import ZArith.
Require Import String.
Require Import Ascii.
Require Import List.

Open Scope string_scope.

Inductive json : Set :=
  | Bool : bool -> json
  (* TODO: numbers *)
  | Null : json
(*  | J_String : string -> json *)
  | Array : list json -> json
(*  | Object : list (string * json) -> json *)
  .

Fixpoint intercalate (sep : string) (xs : list string) : string :=
  match xs with
  | nil => ""
  | x :: nil => x
  | x :: xs => x ++ sep ++ intercalate sep xs
  end%string.

Definition escape_string str := ("""" ++ str ++ """").

Fixpoint encode (v : json) : string :=
  match v with
  | Bool true => "true"
  | Bool false => "false"
  | Null => "null"
(*  | J_String str => escape_string str *)
  | Array items => "[" ++ intercalate "," (map encode items) ++ "]"
(*  | Object kvs => "{" ++ intercalate ","
        ((fix encode_kvs (kvs : list (string * json)) :=
            match kvs with
            | nil => nil
            | (k, v) :: kvs => (escape_string k ++ ":" ++ encode v) :: encode_kvs kvs
            end) kvs) ++ "}" *)
  end.

Parameter hole : Type.

Section Parser.

  Notation "[]" := EmptyString.
  Notation "x :: xs" := (String x xs) (at level 60, right associativity).

  Definition is_space (c : ascii) : bool :=
    match c with
    | " " => true
    | "009" => true
    | "010" => true
    | _ => false
    end%char.

  Inductive Stack :=
    | S_Top : Stack
    | S_Array : list json -> Stack -> Stack.

  Fixpoint parse_json (s : string) (stack : Stack) : option json :=
    let fix parse_end_no_ws obj stack str {struct str} :=
          match stack, str with
          | S_Array objs next, "," :: rest =>
              parse_json rest (S_Array (obj :: objs) next)
          | S_Array objs next, "]" :: rest =>
              parse_end_no_ws (Array (rev (obj :: objs))) next rest
          | S_Top, "" => Some obj
          | _, _ => None
          end
    in
    let fix parse_end obj str :=
          match str with
          | [] => parse_end_no_ws obj stack str
          | c :: rest =>
              if is_space c
                then parse_end obj rest
                else parse_end_no_ws obj stack (c :: rest)
          end
    in
    match s with
    | [] => None
    | c :: rest =>
        if is_space c then parse_json rest stack else
        match s with
        | "t" :: "r" :: "u" :: "e" :: rest => parse_end (Bool true) rest
        | "t" :: rest => parse_end (Bool true) rest
        | "f" :: "a" :: "l" :: "s" :: "e" :: rest => parse_end (Bool false) rest
        | "n" :: "u" :: "l" :: "l" :: rest => parse_end Null rest
        | "[" :: rest => parse_json rest (S_Array nil stack)
        | _ => None
        end
    end.

  Fixpoint parse_json_no_ws (s : string) (stack : Stack) : option json :=
    let fix parse_end obj stack str {struct str} :=
          match stack, str with
          | S_Array objs next, "," :: rest =>
              parse_json_no_ws rest (S_Array (obj :: objs) next)
          | S_Array objs next, "]" :: rest =>
              parse_end (Array (rev (obj :: objs))) next rest
          | S_Top, "" => Some obj
          | _, _ => None
          end
    in
    match stack, s with
    | _, "t" :: "r" :: "u" :: "e" :: rest =>
        parse_end (Bool true) stack rest
    | _, "f" :: "a" :: "l" :: "s" :: "e" :: rest =>
        parse_end (Bool false) stack rest
    | _, "n" :: "u" :: "l" :: "l" :: rest =>
        parse_end Null stack rest
    | _, "[" :: rest =>
        parse_json_no_ws rest (S_Array nil stack)
    | S_Array objs next, "]" :: rest =>
        parse_end (Array (rev objs)) next rest
    | _, _ => None
    end.

  Eval simpl in (option_map encode (parse_json_no_ws "[true,[],[false],[false,true]]" S_Top)).

  Eval simpl in (parse_json " [ true , false , [ true ]]" S_Top).

End Parser.

Inductive All {A} (P : A -> Prop) : list A -> Prop :=
  | All_nil : All P nil
  | All_cons : forall x xs, P x -> All P xs -> All P (x :: xs).

Fixpoint json_ind_2 (P : json -> Prop) x
    (Hbool : forall b, P (Bool b))
    (Hnull : P Null)
    (Harray : forall l, All P l -> P (Array l))
    : P x :=

  match x as x return P x with
  | Bool b => Hbool b
  | Null => Hnull
  | Array l => Harray l
      ((fix list_proof l : All P l :=
        match l as l return All P l with
        | nil => All_nil P
        | x :: xs => All_cons P x xs (json_ind_2 P x Hbool Hnull Harray) (list_proof xs)
        end
      ) l)
  end.

Theorem json_roundtrip : forall v, parse_json_no_ws (encode v) S_Top = Some v.
Proof.
  intro v.
  apply json_ind_2 with (x:=v).
  - intro b.
    destruct b; reflexivity.
  - reflexivity.
  - intros l Hall.
    induction Hall.
    + reflexivity.
    + unfold encode. fold @encode.
      destruct xs.
      * simpl.
        unfold parse_json_no_ws. fold @parse_json_no_ws.
        admit.
      * assert (intercalate "," (map encode (x :: j :: xs)) = encode x ++ "," ++ intercalate "," (map encode (j :: xs))) as H1.
        reflexivity.
        rewrite H1.
      unfold parse_json_no_ws.
Abort.

(*
Inductive Rep : json -> string -> Prop :=
  | R_True : Rep (Bool true) "true"
  | R_False : Rep (Bool false) "false"
  | R_Null : Rep Null "null"
  | R_Array : forall items str,
      RepItems items str -> Rep (Array items) ("[" ++ str ++ "]")

with RepItems : list json -> string -> Prop :=
  | RI_Empty : RepItems [] ""
  | RI_One : forall item str, Rep item str -> RepItems item str
  | RI_Many : forall item items str strs, Rep item str, Rep
*)