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

Lemma wf_env_map_free: forall E1 E2 X C B,
    wf_env (E1 ++ X~B++ E2) ->
    WF (X ~ B ++ E2) C ->
    wf_env ((map (subst_tb X C) E1)++ X~B++E2).
Proof with auto.
  induction E1;intros...
  destruct a.
  rewrite_env ((a, b) :: E1 ++ X~B++ E2) in H.
  simpl...
  rewrite_env  ((a, subst_tb X C b) :: (map (subst_tb X C) E1 ++ (X,B)::E2)).
  destruct b;simpl...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
Qed.

Lemma wf_env_map_free2: forall E1 E2 X C B,
    wf_env (E1 ++ X~B++ E2) ->
    WF  E2 C ->
    wf_env ((map (subst_tb X C) E1)++ E2).
Proof with auto.
  induction E1;intros;simpl...
  dependent destruction H...
  destruct a.
  rewrite_env ((a, b) :: E1 ++ X~B++ E2) in H.
  simpl...
  rewrite_env  ((a, subst_tb X C b) :: (map (subst_tb X C) E1 ++ E2)).
  destruct b;simpl...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
Qed.

Lemma binds_map_free_env: forall E1 E2 X Y U T S,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub U) (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub (subst_tt Y S U)) (map (subst_tb Y S) E1 ++ (Y, bind_sub T) :: E2).
Proof with auto.
  intros.
  unfold binds in *.
  apply binds_map_free with (Y:=Y) (P:=S) in H1...
  apply notin_from_wf_env in H0.
  rewrite_env (map (subst_tb Y S) E1 ++ map (subst_tb Y S) [(Y, bind_sub T)] ++ map (subst_tb Y S) E2) in H1.
  simpl in H1...
  assert (map (subst_tb Y S) E2 = E2).
  rewrite maps_subst_tb_free ...
  rewrite H2 in H1...
  assert (subst_tt Y S T = T).
  rewrite <- subst_tt_fresh...
  rewrite H3 in H1...
Qed.

Lemma binds_map_free_env_lb: forall E1 E2 X Y U T S,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub_lb U) (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub_lb (subst_tt Y S U)) (map (subst_tb Y S) E1 ++ (Y, bind_sub T) :: E2).
Proof with auto.
  intros.
  unfold binds in *.
  apply binds_map_free_lb with (Y:=Y) (P:=S) in H1...
  apply notin_from_wf_env in H0.
  rewrite_env (map (subst_tb Y S) E1 ++ map (subst_tb Y S) [(Y, bind_sub T)] ++ map (subst_tb Y S) E2) in H1.
  simpl in H1...
  assert (map (subst_tb Y S) E2 = E2).
  rewrite maps_subst_tb_free ...
  rewrite H2 in H1...
  assert (subst_tt Y S T = T).
  rewrite <- subst_tt_fresh...
  rewrite H3 in H1...
Qed.

Lemma equiv_subst_refl: forall E A,
    WF E A -> forall C D X,
    equiv E C D ->
    equiv E (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros E A H.
  unfold equiv.
  assert (type A).
  get_type...
  apply type_to_rec in H0.
  generalize dependent E.
  dependent induction H0;intros;simpl;try solve [destruct_hypos;get_well_form;split;auto]...
  -
    destruct_hypos.
    split.
    +
      destruct (X==X0);subst...
      get_well_form.
      constructor...
    +
      destruct (X==X0);subst...
      get_well_form.
      constructor...
  -
    dependent destruction H.
    destruct_hypos.
    split.
    +
      constructor...
      apply IHtype4rec1...
      apply IHtype4rec2...
    +
      constructor...
      apply IHtype4rec1...
      apply IHtype4rec2...
  -
    dependent destruction H3.
    destruct_hypos.
    split.
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E);intros...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite <- subst_tt_open_tt_twice...
        rewrite <- subst_tt_open_tt_twice...
        apply H0...
        split.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E);intros...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite <- subst_tt_open_tt_twice...
        rewrite <- subst_tt_open_tt_twice...
        apply H0...
        split.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
  -
    dependent destruction H2.
    destruct_hypos.
    split.
    +
      apply sa_all with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply WF_narrowing with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
    +
      apply sa_all with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply WF_narrowing with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
  -
    dependent destruction H2.
    destruct_hypos.
    split.
    +
      apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ E).
        apply WF_narrowing_lb with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
    +
      apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X C T1) ++ E).
        apply WF_narrowing_lb with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
  -
    dependent destruction H.
    destruct_hypos.
    split.
    +
      constructor...
      apply IHtype4rec...
    +
      constructor...
      apply IHtype4rec...
Qed.

Lemma WF_narrowing_env_subst: forall E1 E2 X T S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) T ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    WF (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) T.
Proof with auto.
  intros.
  assert (type T).
  get_type...
  apply type_to_rec in H1.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  induction H1;intros;try solve [dependent destruction H;auto]...
  -
    dependent destruction H.
    * analyze_binds_uniq H.
      apply uniq_from_wf_env...
      +
        apply WF_var with (U:=subst_tt X0 S U).
        apply binds_map_free_env...
      +
        apply WF_var with (U:=typ_top)...
      +
        apply WF_var with (U:=U)...
    * analyze_binds_uniq H.
      apply uniq_from_wf_env...
      +
        apply WF_var_lb with (U:=subst_tt X0 S U).
        apply binds_map_free_env_lb...
      +
        apply WF_var_lb with (U:=U)...

  -
    dependent destruction H3...
    apply WF_rec with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    +
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub typ_top ++ E2).
      apply H2...
      apply H3...
      constructor...
    +
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub typ_top ++ E2).
      apply H0...
      apply H4...
      constructor...
  -
    dependent destruction H2...
    apply WF_all with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    rewrite_env (nil ++ X0 ~ bind_sub T1 ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
    apply WF_narrowing with (V:=subst_tt X S T1).
    rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++ X ~ bind_sub typ_top ++ E2).
    apply H0...
    apply H3...
    constructor...
  -
    dependent destruction H2...
    apply WF_all_lb with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    rewrite_env (nil ++ X0 ~ bind_sub_lb T1 ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
    apply WF_narrowing_lb with (V:=subst_tt X S T1).
    rewrite_env (map (subst_tb X S) (X0 ~ bind_sub_lb T1 ++ E1) ++ X ~ bind_sub typ_top ++ E2).
    apply H0...
    apply H3...
    constructor...
Qed.

Lemma equiv_sub_subst_refl: forall A X E1 E2 C D S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    equiv (X ~ bind_sub typ_top ++ E2) C D ->
    equiv (X ~ bind_sub typ_top ++ E2) C S ->
    equiv (X ~ bind_sub typ_top ++ E2) S D ->
    sub (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  assert (type A) as Hq.
  get_type...
  apply type_to_rec in Hq.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction Hq;intros;simpl...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    destruct (X==X0);subst...
    +
      rewrite_env (nil ++ map (subst_tb X0 S) E1 ++ (X0, bind_sub typ_top) :: E2).
      apply Sub_weakening...
      apply wf_env_map_free...
      get_well_form...
    +
      constructor...
      apply wf_env_map_free...
      get_well_form...
      dependent destruction H.
      * analyze_binds H...
        apply WF_var with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
        apply WF_var with (U:= U)...
      * analyze_binds H...
        apply WF_var_lb with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free_lb...
        apply WF_var_lb with (U:= U)...
  -
    dependent destruction H.
    constructor...
    apply IHHq1...
    apply IHHq2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H9.
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2 \u L0);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply subst_tt_wf...
      rewrite_env (nil ++ map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_weakening...
      get_well_form...
      apply WF_narrowing_env_subst...
      apply H9...
      constructor...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply subst_tt_wf...
      rewrite_env (nil ++ map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_weakening...
      get_well_form...
      apply WF_narrowing_env_subst...
      apply H9...
      constructor...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0...
      apply H10...
      constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      apply IHHq...
    +
      apply IHHq...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2);
        split;apply Sub_weakening...
        apply wf_env_map_free...
        get_well_form...
        apply wf_env_map_free...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H0...
        apply H8...
        constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      apply IHHq...
    +
      apply IHHq...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2);
        split;apply Sub_weakening...
        apply wf_env_map_free...
        get_well_form...
        apply wf_env_map_free...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub_lb T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H0...
        apply H8...
        constructor...
  -
    dependent destruction H.
    constructor...
    apply IHHq...
Qed.

Lemma equiv_sub_subst_refl_no_var: forall A X E1 E2 C D S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    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 A).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  assert (type A) as Hq.
  get_type...
  apply type_to_rec in Hq.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction Hq;intros;simpl...
  -
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    get_well_form...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
  -
    destruct (X==X0);subst...
    +
      rewrite_env (nil ++ map (subst_tb X0 S) E1 ++ E2).
      apply Sub_weakening...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
    +
      constructor...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
      dependent destruction H.
      * analyze_binds H...
        apply WF_var with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
        apply WF_var with (U:= U)...
      * analyze_binds H...
        apply WF_var_lb with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free_lb...
        apply WF_var_lb with (U:= U)...
  -
    dependent destruction H.
    constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H9.
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2 \u L0);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++  E2).
      apply subst_tb_wf3...
      apply WF_narrowing with (V:=typ_top)...
      apply H9...
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++  E2).
      apply subst_tb_wf3...
      apply WF_narrowing with (V:=typ_top)...
      apply H9...
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ E2).
      apply H0...
      apply H10...
      constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top) ++ E2);
          split;apply Sub_weakening...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++  E2).
        apply H0...
        apply H8...
        constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top) ++ E2);
          split;apply Sub_weakening...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub_lb T1 ++ E1) ++  E2).
        apply H0...
        apply H8...
        constructor...
  -
    dependent destruction H.
    constructor...
Qed.

Lemma wf_env_binds_not_fv_tt: forall F Z E Q,
    wf_env (F ++ Z ~ bind_sub Q ++ E) ->
    Z \notin fv_tt Q.
Proof with auto.
  intros.
  apply wf_env_cons in H.
  dependent destruction H...
  apply WF_imply_dom in H0...
Qed.

Lemma wf_env_subst_tb : forall F Q Z P E,
  wf_env (F ++ Z ~ bind_sub Q ++ E) ->
  WF E P ->
  wf_env (map (subst_tb Z P) F ++ E).
Proof with eauto.
  induction F; intros ;simpl in *...
  -
    dependent destruction H...
  -
    destruct a.
    dependent destruction H;simpl in *.
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub Q)...
Qed.

Lemma wf_env_subst_tb_lb : forall F Q Z P E,
  wf_env (F ++ Z ~ bind_sub_lb Q ++ E) ->
  WF E P ->
  wf_env (map (subst_tb Z P) F ++ E).
Proof with eauto.
  induction F; intros ;simpl in *...
  -
    dependent destruction H...
  -
    destruct a.
    dependent destruction H;simpl in *.
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub_lb Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub_lb Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub_lb Q)...
Qed.

Lemma sub_through_subst_tt: forall Z Q T S F E P,
    sub (F ++ Z ~ bind_sub Q ++ E) T S ->
    sub E P Q ->
    sub (map (subst_tb Z P) F ++ E) (subst_tt Z P T) (subst_tt Z P S).
Proof with auto.
  intros.
  assert (WF E P) as Hq.
    get_well_form...
  dependent induction H;simpl...
  -
    constructor...
    apply wf_env_subst_tb with (Q:=Q)...
  -
    destruct (X==Z);subst...
    + apply Reflexivity...
      add_nil.
      apply WF_weakening...
      apply wf_env_subst_tb with (Q:=Q)...
    + dependent destruction H0.
      { constructor...
        apply wf_env_subst_tb with (Q:=Q)...
        apply WF_var with (U:=subst_tt Z P U)...
        apply binds_map_free_sub with (Q:=Q)... }
      { constructor...
        apply wf_env_subst_tb with (Q:=Q)...
        apply WF_var_lb with (U:=subst_tt Z P U)...
        apply binds_map_free_sub2 with (Q:=Q)... }
  -
    constructor...
    apply wf_env_subst_tb with (Q:=Q)...
    apply subst_tb_wf with (Q:=bind_sub Q)...
  -
    constructor...
    apply wf_env_subst_tb with (Q:=Q)...
    apply subst_tb_wf with (Q:=bind_sub Q)...
  -
    destruct (X==Z);subst...
    +
      apply sub_transitivity with (Q:=Q).
      *
        add_nil.
        apply Sub_weakening...
        apply wf_env_subst_tb with (Q:=Q)...
        get_well_form...
      *
        assert (Q = subst_tt Z P Q).
        rewrite <- subst_tt_fresh ...
        get_well_form.
        apply wf_env_binds_not_fv_tt in H0...
        rewrite H2.
        analyze_binds_uniq H...
        apply uniq_from_wf_env...
        get_well_form...
        inversion BindsTacVal;subst.
        apply IHsub with (Q0:=Q)...
    +
      apply sa_trans_tvar with (U:=subst_tt Z P U)...
      apply binds_map_free_sub with (Q:=Q)...
      get_well_form...
      apply IHsub with (Q0:=Q)...

  -
    destruct (X==Z);subst...
    + apply binds_mid_eq in H...
      inversion H. apply uniq_from_wf_env.
      get_well_form...
    +
      apply sa_trans_tvar_lb with (U:=subst_tt Z P U)...
      apply binds_map_free_sub2 with (Q:=Q)...
      get_well_form...
      apply IHsub with (Q0:=Q)...
  -
    constructor...
    apply IHsub1 with (Q0:=Q)...
    apply IHsub2 with (Q0:=Q)...
  -
    assert (type P). get_type...
    apply sa_all with (L:=L \u {{Z}});intros...
    + apply IHsub1 with (Q0:=Q)...
    + apply IHsub2 with (Q0:=Q)...
    (* + apply subst_tb_wf with (Q:=bind_sub Q)... *)
    + rewrite_env ( map (subst_tb Z P) (X~bind_sub S2 ++ F) ++ E).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H2 with (Q0:=Q)...
  -
    assert (type P). get_type...
    apply sa_all_lb with (L:=L \u {{Z}});intros...
    + apply IHsub1 with (Q0:=Q)...
    + apply IHsub2 with (Q0:=Q)...
    (* + apply subst_tb_wf with (Q:=bind_sub Q)... *)
    + rewrite_env ( map (subst_tb Z P) (X~bind_sub_lb S2 ++ F) ++ E).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H2 with (Q0:=Q)...
  -
    assert (type P). get_type...
    apply sa_rec with (L:=L \u {{Z}});intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb Z P) (X~bind_sub typ_top ++ F) ++ E).
      apply subst_tb_wf with (Q:=bind_sub Q)...
      apply H...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb Z P) (X~bind_sub typ_top ++ F) ++ E).
      apply subst_tb_wf with (Q:=bind_sub Q)...
      apply H0...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb Z P) (X~bind_sub typ_top ++ F) ++ E).
      apply H2 with (Q0:=Q)...
  -
    constructor...
    apply IHsub with (Q0:=Q)...
  (* -
    apply sa_rcd...
    +
      apply wf_env_subst_tb with (Q:=Q)...
    +
      apply subst_tt_rt_type with (E:=F ++ Z ~ bind_sub Q ++ E)...
      add_nil. apply WF_weakening... apply WF_weakening...
    +
      apply subst_tt_rt_type with (E:=F ++ Z ~ bind_sub Q ++ E)...
      add_nil. apply WF_weakening... apply WF_weakening...
    +
      apply label_equiv_reserve with (E:=F ++ Z ~ bind_sub Q ++ E)...
      reflexivity.
    +
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      intros. apply Tlookup_subst with (E:=(F ++ Z ~ bind_sub Q ++ E) )in H8 ...
      apply Tlookup_subst with (E:=(F ++ Z ~ bind_sub Q ++ E) )in H9...
      destruct_hypos. subst.
      apply H6 with (i:=i) (Q0:=Q)... *)
Qed.

Lemma equiv_sub_subst_not_var: forall A B X E1 E2 C D S,
    sub (E1 ++ X ~ bind_sub typ_top ++ E2) A 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.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction H;intros;simpl...
  -
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    get_well_form...
  -
    destruct (X0==X);subst...
    +
      rewrite_env (nil ++ map (subst_tb X S) E1 ++ E2).
      apply Sub_weakening...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
    +
      constructor...
      *
        apply wf_env_map_free2 with (B:=bind_sub typ_top)...
        get_well_form...
      *
        dependent destruction H0.
        { analyze_binds H0...
          apply WF_var with (U:=subst_tt X S U)...
          unfold binds in *.
          apply In_lemmaL.
          apply binds_map_free...
          apply WF_var with (U:= U)... }
        { analyze_binds H0...
          apply WF_var_lb with (U:=subst_tt X S U)...
          unfold binds in *.
          apply In_lemmaL.
          apply binds_map_free_lb...
          apply WF_var_lb with (U:= U)... }
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    apply subst_tb_wf3...
    apply WF_narrowing with (V:=typ_top)...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    apply subst_tb_wf3...
    apply WF_narrowing with (V:=typ_top)...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
      dependent destruction BindsTacVal.
      dependent destruction H0.
      * simpl...
        constructor...
        apply wf_env_map_free2 with (B:=bind_sub typ_top)...
        get_well_form...
        get_well_form.
        rewrite_env (nil ++ map (subst_tb X S) E1 ++  E2).
        apply WF_weakening...
      * simpl... destruct (X0 ==X)...
        { add_nil. apply Sub_weakening...
          apply wf_env_map_free2 with (B:=bind_sub typ_top)...
          get_well_form... get_well_form... }
        { apply sa_trans_tvar_lb with (U:=subst_tt X S U)...
          apply binds_map_free_sub2 with (S:=S) in H...
          get_well_form...
          eapply sub_transitivity with (Q:=typ_top).
            {
              constructor...
              apply wf_env_map_free2 with (B:=bind_sub typ_top)...
              get_well_form...
              get_well_form...
              rewrite_env (nil ++ map (subst_tb X S) E1 ++  E2).
              apply WF_weakening... get_well_form...
            }
            { replace typ_top with (subst_tt X S typ_top)...
              apply sub_through_subst_tt with (Q:=typ_top)...
              constructor;get_well_form... }
        }
    +
      apply sa_trans_tvar with (U:=subst_tt X S U)...
      *
        apply binds_map_free_sub with (Q:=typ_top)...
        get_well_form...
      *
        apply IHsub...
        get_well_form.
        apply Reflexivity...
        get_well_form.
        apply Reflexivity...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...

    +
      apply sa_trans_tvar_lb with (U:=subst_tt X S U)...
      *
        apply binds_map_free_sub2 with (Q:=typ_top)...
        get_well_form...
      *
        apply IHsub...
        get_well_form.
        apply Reflexivity...
        get_well_form.
        apply Reflexivity...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_all with (L:=L \u {{X}});intros...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl_no_var;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub S2 ++ E1) ++ E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_all_lb with (L:=L \u {{X}});intros...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl_no_var;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub_lb S2 ++ E1) ++ E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ E2).
      apply subst_tb_wf3...
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub S ++ E2).
      apply WF_narrowing with (V:=typ_top)...
      apply H...
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ E2).
      apply subst_tb_wf3...
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub S ++ E2).
      apply WF_narrowing with (V:=typ_top)...
      apply H0...
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++  E2).
      apply H2...
Qed.

Lemma equiv_sub_subst: forall A B X E1 E2 C D S,
    sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B ->
    equiv (X ~ bind_sub typ_top ++ E2) C D ->
    equiv (X ~ bind_sub typ_top ++ E2) C S ->
    equiv (X ~ bind_sub typ_top ++ E2) S D ->
    sub (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction H;intros;simpl...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    destruct (X0==X);subst...
    +
      rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply Sub_weakening...
      apply wf_env_map_free...
      get_well_form...
    +
      constructor...
      *
        apply wf_env_map_free...
        get_well_form...
      *
        dependent destruction H0.
        { analyze_binds H0...
          + apply WF_var with (U:=subst_tt X S U)...
            unfold binds in *.
            apply In_lemmaL.
            apply binds_map_free...
          + apply WF_var with (U:= U)... }
        { analyze_binds H0...
          + apply WF_var_lb with (U:=subst_tt X S U)...
            unfold binds in *.
            apply In_lemmaL.
            apply binds_map_free_lb...
          + apply WF_var_lb with (U:= U)... }
  -
    get_well_form...
    constructor...
    apply wf_env_map_free...
    apply subst_tt_wf...
    rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
    apply WF_weakening...
    apply WF_narrowing_env_subst...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free...
    apply subst_tt_wf...
    rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
    apply WF_weakening...
    apply WF_narrowing_env_subst...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
      inversion BindsTacVal.
      subst. clear IHsub.
      dependent induction H0.
      * simpl...
        constructor...
        apply wf_env_map_free...
        get_well_form...
        get_well_form.
        rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
        apply WF_weakening...
      *
        simpl... destruct (X0 == X)...
        { add_nil. apply Sub_weakening...
          apply wf_env_map_free;get_well_form... }
        { apply sa_trans_tvar_lb with (U:= subst_tt X S U)...
          * apply binds_map_free_sub2 with (S:=S) in H...
            2:{ get_well_form... }
            apply binds_app_iff in H. destruct H.
            apply binds_app_iff... apply binds_app_iff.
            right. apply binds_cons...
          * apply IHsub...
            apply Reflexivity;get_well_form...
            apply Reflexivity;get_well_form...
        }
    + apply sa_trans_tvar with (U:= subst_tt X S U)...
      * apply binds_map_free_sub with (S:=S) in H...
        2:{ get_well_form... }
        apply binds_app_iff in H. destruct H.
        apply binds_app_iff... apply binds_app_iff.
        right. apply binds_cons...
      * apply IHsub...
        apply Reflexivity;get_well_form...
        apply Reflexivity;get_well_form...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
    + apply sa_trans_tvar_lb with (U:= subst_tt X S U)...
      * apply binds_map_free_sub2 with (S:=S) in H...
        2:{ get_well_form... }
        apply binds_app_iff in H. destruct H.
        apply binds_app_iff... apply binds_app_iff.
        right. apply binds_cons...
      * apply IHsub...
        apply Reflexivity;get_well_form...
        apply Reflexivity;get_well_form...
  -
    constructor...
    apply IHsub1...
    apply IHsub2...
  -
    apply sa_all with (L:=L \u {{X}});intros...
    +
      apply IHsub1...
    +
      apply IHsub2...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub S2 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H2...
  -
    apply sa_all_lb with (L:=L \u {{X}});intros...
    +
      apply IHsub1...
    +
      apply IHsub2...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub_lb S2 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wf...
      rewrite_env (nil ++ (X0 ~ bind_sub typ_top ++ map (subst_tb X S) E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_weakening...
      get_well_form...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_narrowing_env_subst...
      apply H...
      specialize_x_and_L X0 L.
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wf...
      rewrite_env (nil ++ (X0 ~ bind_sub typ_top ++ map (subst_tb X S) E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_weakening...
      get_well_form...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_narrowing_env_subst...
      apply H0...
      specialize_x_and_L X0 L.
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply H2...
  -
    constructor...
    apply IHsub...
Qed.

Lemma equiv_unfolding: forall E C D X,
    equiv E (typ_mu C) (typ_mu D) ->
    X \notin fv_tt C \u fv_tt D \u dom E ->
    equiv (X~bind_sub typ_top ++ E) (typ_label X (open_tt C X)) (typ_label X (open_tt D X)).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  dependent destruction H.
  dependent destruction H2.
  split.
  constructor...
  pick fresh Y.
  apply sub_replacing_var with (X:=Y)...
  apply sub_nominal_inversion...
  constructor...
  specialize_x_and_L Y L.
  get_well_form...
  dependent destruction H1...
  constructor...
  pick fresh Y.
  apply sub_replacing_var with (X:=Y)...
  apply sub_nominal_inversion...
  constructor...
  specialize_x_and_L Y L.
  get_well_form...
  dependent destruction H1...
Qed.

Lemma equiv_reflexivity: forall E C,
    wf_env E ->
    WF E C ->
    equiv E C C.
Proof with auto.
  intros.
  unfold equiv;split;apply Reflexivity...
Qed.

Lemma equiv_sub_unfolding: forall C D Y E,
      sub (Y ~ bind_sub typ_top ++ E) (open_tt C Y) (open_tt D Y) ->
      sub (Y ~ bind_sub typ_top ++ E) (open_tt D Y) (open_tt C Y) ->
      Y \notin fv_tt C \u fv_tt D \u fl_tt C \u fl_tt D \u dom E \u fl_env E->
      sub E (typ_mu C) (typ_mu D).
Proof with auto.
  intros.
  apply sa_rec with (L:=dom E \u {{Y}} \u fv_tt C \u fv_tt D \u fl_tt C \u fl_tt D);intros.
  -
    get_well_form.
    apply WF_replacing_var with (X:=Y)...
  -
    get_well_form.
    apply WF_replacing_var with (X:=Y)...
  -
    apply sub_renaming_unfolding with (X:=Y)...
    +
      rewrite subst_tt_intro with (X:=Y)...
      remember (subst_tt Y (typ_label Y (open_tt C Y)) (open_tt C Y)).
      rewrite subst_tt_intro with (X:=Y)...
      rewrite_env (map (subst_tb Y (typ_label Y (open_tt C Y))) nil ++ Y ~ bind_sub typ_top ++ E).
      subst.
      apply equiv_sub_subst...
      unfold equiv;split...
      get_well_form.
      unfold equiv;split;apply Reflexivity...
      unfold equiv;split...
    +
      constructor...
      get_well_form...
      dependent destruction H...
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Ascii.
(* option type *)

Inductive option (A : Set) : Set :=
  | Some : forall x : A, option A
  | None : option A.

Theorem SomeComp : forall (A : Set) (a b : A), a = b -> Some A a = Some A b.
intros A a b H'; rewrite H'; auto.
Qed.
Hint Resolve SomeComp.
(* Implementation of string as list of ascii characters *)

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.
(* Equality is decidable *)

Delimit Scope local_string_scope with string.
Bind Scope local_string_scope with string.

Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
 decide equality; apply ascii_dec.
Defined.
(* Usual append function for string *)

Fixpoint append (s1 : string) : string -> string :=
  fun s2 : string =>
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (append s1' s2)
  end.
(* The number of character of a string *)

Fixpoint length (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length s')
  end.
(* Return the nth character of a string *)

Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
  match s with
  | EmptyString => None _
  | String c s' => match n with
                   | O => Some _ c
                   | S n' => get n' s'
                   end
  end.
(* Two lists that are identical through get are syntactically equal *)

Theorem get_correct :
 forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
intros s1; elim s1; simpl in |- *.
intros s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
case (Rec s).
intros H0; rewrite H0; auto.
intros n; exact (H (S n)).
intros H; injection H; intros H1 H2 n; case n; auto.
rewrite H1; auto.
Qed.
(* The first elements  of (append s1 s2) are the ones of s1 *)

Theorem append_correct1 :
 forall (s1 s2 : string) (n : nat),
 n < length s1 -> get n s1 = get n (append s1 s2).
intros s1; elim s1; simpl in |- *; auto.
intros s2 n H; inversion H.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
intros n0 H; apply Rec; auto.
apply Lt.lt_S_n; auto.
Qed.
(* The last elements  of (append s1 s2) are the ones of s2 *)

Theorem append_correct2 :
 forall (s1 s2 : string) (n : nat),
 get n s2 = get (n + length s1) (append s1 s2).
intros s1; elim s1; simpl in |- *; auto.
intros s2 n; rewrite Plus.plus_comm; simpl in |- *; auto.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
generalize (Rec s2 0); simpl in |- *; auto.
intros n0; rewrite <- Plus.plus_Snm_nSm; auto.
Qed.
(* substring n m s returns the substring of s that starts
   at position n and of length m
   if this does not make sense it returns "" *)

Fixpoint substring (n m : nat) (s : string) {struct s} : string :=
  match n with
  | O =>
      match m with
      | O => EmptyString
      | S m' =>
          match s with
          | EmptyString => s
          | String c s' => String c (substring 0 m' s')
          end
      end
  | S n' =>
      match s with
      | EmptyString => s
      | String c s' => substring n' m s'
      end
  end.
(* The substring is included in the initial string *)

Theorem substring_correct1 :
 forall (s : string) (n m p : nat),
 p < m -> get p (substring n m s) = get (p + n) s.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros p H; inversion H.
intros m' p; case p; simpl in |- *; auto.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Lt.lt_S_n; auto.
intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
Qed.
(* The substring has at most m elements *)

Theorem substring_correct2 :
 forall (s : string) (n m p : nat),
 m <= p -> get p (substring n m s) = None _.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros m' p; case p; simpl in |- *; auto.
intros H; inversion H.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Le.le_S_n; auto.
Qed.
(* Check if s1 is a prefix of s2 *)

Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
  match s1 with
  | EmptyString => true
  | String a s1' =>
      match s2 with
      | EmptyString => false
      | String b s2' =>
          match ascii_dec a b with
          | left _ => prefix s1' s2'
          | right _ => false
          end
      end
  end.
(* if s1 is a prefix of s2 we can get s1 by a substring at position O of s2 *)

Theorem prefix_correct :
 forall s1 s2 : string,
 prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
intros s1; elim s1; simpl in |- *; auto.
intros s2; case s2; simpl in |- *; split; auto.
intros a s1' Rec s2; case s2; simpl in |- *; auto.
split; intros; discriminate.
intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
rewrite e; rewrite H1; auto.
apply H2; injection H3; auto.
intros n; split; intros; try discriminate.
case n; injection H; auto.
Qed.
(* Check if starting at position n s1 occurs in s2, if
   so it returns the position *)

Fixpoint index (n : nat) (s1 s2 : string) {struct s2} :
 option nat :=
  match s2 with
  | EmptyString =>
      match n with
      | O =>
          match s1 with
          | EmptyString => Some _ 0
          | String a s1' => None nat
          end
      | S n' => None nat
      end
  | String b s2' =>
      match n with
      | O =>
          match prefix s1 s2 with
          | true => Some _ 0
          | false =>
              match index 0 s1 s2' with
              | Some n => Some _ (S n)
              | None => None nat
              end
          end
      | S n' =>
          match index n' s1 s2' with
          | Some n => Some _ (S n)
          | None => None nat
          end
      end
  end.
(* Dirty trick to evaluate locally that prefix reduces itself *)
Opaque prefix.
(* If the result of index is (Some m), s1 in s2 at position m *)

Theorem index_correct1 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some _ m -> substring m (length s1) s2 = s1.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1; auto.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
case H0; simpl in |- *; auto.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1; apply H; injection H1; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H1; apply H; injection H1; auto.
intros; discriminate.
Qed.
(* If the result of index is (Some m), s1 does not occur in s2 before m *)

Theorem index_correct2 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some _ m ->
 forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1.
intros p H0 H2; inversion H2.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
intros p H2 H3; inversion H3.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1 p; try case p; simpl in |- *; auto.
intros H2 H3; red in |- *; intros H4; case H0.
intros H5 H6; absurd (false = true); auto with bool.
intros n0 H2 H3; apply H; auto.
injection H1; auto.
apply Le.le_O_n.
apply Lt.lt_S_n; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H0 p; case p; simpl in |- *; auto.
intros H1; inversion H1; auto.
intros n0 H1 H2; apply H; auto.
injection H0; auto.
apply Le.le_S_n; auto.
apply Lt.lt_S_n; auto.
intros; discriminate.
Qed.
(* If the result of index is None, s1 does not occur in s2 after n *)

Theorem index_correct3 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = None _ ->
 s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
case m; intros; red in |- *; intros; discriminate.
intros n' m; case m; auto.
intros s1; case s1; simpl in |- *; auto.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros; discriminate.
case m; simpl in |- *; auto.
case s1; simpl in |- *; auto.
intros a s H H0 H1 H2; red in |- *; intros H3; case H.
intros H4 H5; absurd (false = true); auto with bool.
case s1; simpl in |- *; auto.
intros a s n0 H H0 H1 H2;
 change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
 apply (Rec 0); auto.
generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_O_n.
intros n'; case m; simpl in |- *; auto.
intros H H0 H1; inversion H1.
intros n0 H H0 H1; apply (Rec n'); auto.
generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_S_n; auto.
Qed.
(* Back to normal for prefix *)
Transparent prefix.
(* If we are searching for the Empty string and the answer is no
   this means that n is greater than the size of s *)

Theorem index_correct4 :
 forall (n : nat) (s : string),
 index n EmptyString s = None _ -> length s < n.
intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros; discriminate.
intros; apply Lt.lt_O_Sn.
intros a s' H n; case n; simpl in |- *; auto.
intros; discriminate.
intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
 auto.
intros; discriminate.
intros H0 H1; apply Lt.lt_n_S; auto.
Qed.
(* Same as index but with no optional type, we return O when it
   does not occur *)

Definition findex n s1 s2 :=
  match index n s1 s2 with
  | Some n => n
  | None => 0
  end.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the static semantics of statements and expressions, pg. 63.

*)

Set Implicit Arguments.
Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Test_Utilities.
Require Export Cyclone_LN_Tactics.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* Test K *)

Example K_int_test:
  K ddot cint B.
Proof.
  auto.
Qed.

Example K_B_test:
  K ((alpha_ ~ B) & ddot) (ftvar alpha_) B.
Proof.
  auto.
Qed.

Example K_star_A_test:
  K  ((alpha_ ~ A) & ddot) (ptype (ftvar alpha_)) B.
Proof.
  auto.
Qed.

Example K_B_A_test:
  K ddot tau A.
Proof.
  auto.
Qed.

Example K_cross_test:
  K ddot (cross t0 t1) A.
Proof.
  auto.
Qed.

Example K_arrow_test:
 K ddot (arrow t0 t1) A.
Proof.
  auto.
Qed.

Example K_ptype_test:
  K ddot (ptype tau) B.
Proof.
  auto.
Qed.

Example K_utype_test:
  forall d beta,
    d = (beta ~ k) ->
  K ddot (utype k tau) A.
Proof.
  auto.
  (* apply_fresh_from* K_utype with fv_of_goal. *)
Qed.

Example K_utype_test_fresh:
  K ((beta_ ~ B) & ddot) (utype k (ftvar beta_)) A.
Proof.
  auto.
  (* apply_fresh_from* K_utype with fv_of_goal. *)
Qed.

Example K_etype_test:
  K ddot (etype witnesschanges k tau) A.
Proof.
  auto.
  (* apply_fresh_from* K_etype with fv_of_goal. *)
Qed.

(* Test AK *)

Example AK_K_AK_test:
  AK ddot tau k.
Proof.
 auto.
Qed.

Example AK_A_test:
  AK ((alpha_ ~ B) & ddot) (ftvar alpha_) A.
Proof.
  auto.
Qed.

(* Test assgn *)

Example ASGN_cint_test:
  ASGN nil cint.
Proof.
  auto.
Qed.

Example ASGN_B_test:
  ASGN ((alpha_ ~ B) & ddot) (ftvar alpha_).
Proof.
  auto.
Qed.

Example ASGN_ptype_test:
  ASGN nil (ptype tau).
Proof.
  constructor.
Qed.

Example ASGN_cross_test:
  ASGN nil (cross t0 t1).
Proof.
  unfold t0, t1.
  auto.
Qed.

Example ASGN_arrow_test:
  ASGN nil (arrow t0 t1).
Proof.
 unfold t0, t1.
 auto.
Qed.

Example ASGN_utype_test:
  ASGN ddot (utype k tau).
Proof.
  auto.
  (* apply_fresh_from* ASGN_utype with fv_of_goal. *)
Qed.

Example ASGN_etype_test:
  ASGN ddot (etype witnesschanges k tau).
Proof.
  auto.
  (* apply_fresh_from* ASGN_etype with fv_of_goal. *)
Qed.

(* Test WFDG *)

Example WFD_ddot_gdot_test:
  WFDG ddot gdot.
Proof.
  auto.
Qed.

Example WFD_Delta_nil_test:
  WFDG ddot (gdot & (varx ~ tau)).
Proof.
  auto.
Qed.

(* Test WFU. *)

Example WFU_nil_test:
  WFU udot.
Proof.
  auto.
Qed.

Example WFU_A_test:
  WFU (((varx, pdot) ~p tau) &p udot).
Proof.
  auto.
Qed.

Example WFC_DUG_test:
  WFC ddot udot gdot.
Proof.
  auto.
Qed.


From Undecidability.L Require Export Enumerable InterpreterResults DecidableRecognisable Rice Por.

(** * Markov's principle *)

Lemma re_exists p : enumerable p -> enumerable (fun t => exists s : term, p (s t)).
Proof.
  intros (u & proc_u & spec_u & corr_u).
  exists (lambda (u 0 (lambda (0 (lambda none) (lambda (lambda (some 0))) (lambda none))) none)).
  repeat split; value.
  - intros n.  destruct (spec_u n).
    + left. solveeq.
    + destruct H as ([] & ? & ?).
      * left; solveeq.
      * right. exists t. split. solveeq. eauto.
      * left; solveeq.
  - intros s [t [n H] % corr_u]. exists n. solveeq.
Qed.

Lemma DA p : recognisable p -> recognisable (fun _ => exists t, p t).
Proof.
  intros. eapply enumerable_recognisable.
  change (enumerable (fun t => exists s, (fun x => match x with app s t => p s | _ => False end) (app s t))).
  eapply re_exists. eapply recognisable_enumerable.
  destruct H as (u & pu & Hu).
  pose (v := (lambda (0 (lambda Omega) (lambda (lambda (u 1))) (lambda Omega)))).
  exists v.
  split. subst v; value. destruct s; unfold pi.
  - assert (v (tenc n) ≡ Omega). solveeq. rewrite H. firstorder using eva_Omega.
  - assert (v (tenc (s1 s2)) ≡ u (tenc s1)). solveeq. now rewrite H, Hu.
  - assert (v (tenc (lambda s)) ≡ Omega). solveeq. rewrite H. firstorder using eva_Omega.
Qed.

Definition Markov_Post:= forall p, recognisable p -> recognisable (complement p) -> decidable p.
Definition Markov_Sat := forall p, decidable p -> (~~ exists t, p t) -> exists t, p t.
Definition Markov_Eva := forall s, closed s -> ~~ eva s -> eva s.

Lemma Markov_Post_to_Sat : Markov_Post -> Markov_Sat.
Proof.
  intros post p dec_p H.
  assert (recognisable (fun _ => exists t, p t)). {
    eapply DA. now eapply dec_recognisable. }
  assert (recognisable (fun _ => ~ exists t, p t)). {
    exists D. split; value. intros. firstorder using D_pi. }
  destruct (dec_pdec (post _ H0 H1) I); tauto.
Qed.

Lemma Markov_Sat_to_Eva : Markov_Sat -> Markov_Eva.
Proof.
  intros markov t cls_t Ht.
  pose (q := fun s => exists n, s = var n /\ eval n t <> None).

  assert (decp : decidable q). {
    exists (.\ "s" ; "s" (.\ "n" ; !E "n" !(tenc t) !(lambda T) !F) !(lambda (lambda F)) !(lambda F)).
    split; value. intros s.
    cbn. destruct s.
    - destruct (eval n t) eqn:Eq.
      + left. split. exists n; firstorder congruence. eapply evaluates_equiv; split; value.
        transitivity (E (enc n) (tenc t) (lambda T) F). solveeq. rewrite E_correct, Eq. solveeq.
      + right. split. intros (n' & Hn & E'). inv Hn. congruence. eapply evaluates_equiv; split; value.
        transitivity (E (enc n) (tenc t) (lambda T) F). solveeq. rewrite E_correct, Eq. solveeq.
    - right. split. intros (n' & Hn & E'). inv Hn. solveeq.
    - right. split. intros (n' & Hn & E'). inv Hn. solveeq.
  }

  destruct (markov _ decp) as [t' [v H]].
  - assert (forall P Q : Prop, (P -> Q) -> (~~ P -> ~~ Q)) by tauto. eapply H; try eassumption; eauto.
    intros [v [n Hn] % evaluates_eval].
    exists n. exists n. firstorder congruence.
  - destruct H. subst. destruct (eval v t) eqn:Eq; try congruence.
    eapply eval_evaluates in Eq. eauto.
Qed.

Lemma Markov_Eva_to_Post : Markov_Eva -> Markov_Post.
Proof.
  intros H p [u [[lam_u cls_u] Hu]] [v [[lam_v cls_v] Hv]].
  pose (por_u_v := lambda (O ((App (tenc u) (Q 0))) ((App (tenc v) (Q 0))))).
  exists por_u_v.
  split; subst por_u_v; value. intros t.

  assert (A : eva (O (tenc (u (tenc t))) (tenc (v (tenc t))))). {
    eapply H; value.

    intros A.
    assert (Hnu : ~ eva (u (tenc t))). { intros B. eapply A, O_complete. tauto. }
    assert (Hnv : ~ eva (v (tenc t))). { intros B. eapply A, O_complete. tauto. }
    rewrite <- Hu in Hnu. rewrite <- Hv in Hnv. unfold complement in *. tauto.
  }

  eapply O_sound in A.

  destruct A as [[A [B ?] %evaluates_equiv] | [A [B ?] %evaluates_equiv]].
  - left; split; eauto. rewrite Hu. tauto. eapply evaluates_equiv; split; value.
    dobeta. now rewrite Q_correct, !App_correct, B.
  - right; split; eauto. unfold complement in *. rewrite Hv. tauto.
    eapply evaluates_equiv; split; value. dobeta; now rewrite Q_correct, !App_correct, B.
Qed.


Require Export Common.
Require Export LambdaDollar.
Require Export LambdaLetDollar.

(* ANCHOR Similarity Relation
 *)
Reserved Notation "e ~ₑ e'" (at level 40).
Reserved Notation "v ~ᵥ v'" (at level 40).
Reserved Notation "p ~ₚ p'" (at level 40).
Reserved Notation "j ~ⱼ j'" (at level 40).
Reserved Notation "k ~ₖ k'" (at level 40).
Reserved Notation "t ~ₜ t'" (at level 40).
Inductive sim_tm {A} : tm A → tm' A → Prop :=
| sim_var  : ∀ a, <{ var a }> ~ₑ <| var a |>
| sim_abs  : ∀ e e', e ~ₑ e' → <{ λ  e }> ~ₑ <| λ   e' |>
| sim_s_0  : ∀ e e', e ~ₑ e' → <{ S₀ e }> ~ₑ <| S₀, e' |>
| sim_app  : ∀ e1 e2 e1' e2', e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1   e2 }> ~ₑ <| e1'   e2' |>
| sim_dol  : ∀ e1 e2 e1' e2', e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1 $ e2 }> ~ₑ <| e1' $ e2' |>
| sim_eta  : ∀ (v : val A) (v' : val' A), v ~ₑ v' →
    <{ λ {liftV v} $ 0 }> ~ₑ v'
| sim_eta_dol : ∀ (v1 v2 : val A) (v1' v2' : val' A), v1 ~ₑ v1' → v2 ~ₑ v2' →
    <{ v1 $ v2 }> ~ₑ <| v1' v2' |>
| sim_let : ∀ j e j' e', j ~ⱼ j' → e ~ₑ e' →
    <{ j[e] }> ~ₑ <| let e' in ↑j'[0] |>
with sim_J {A} : J A → J' A → Prop :=
| sim_J_fun : ∀ (e : tm  A) (e' : tm'  A), e ~ₑ e' → J_fun e ~ⱼ J_fun' e'
| sim_J_arg : ∀ (v : val A) (v' : val' A), v ~ₑ v' → J_arg v ~ⱼ J_arg' v'
| sim_J_dol : ∀ (e : tm  A) (e' : tm'  A), e ~ₑ e' → J_dol e ~ⱼ J_dol' e'
where "e ~ₑ e'" := (sim_tm e e')
and   "j ~ⱼ j'" := (sim_J  j j').
Scheme sim_tm_mut := Minimality for sim_tm Sort Prop
with   sim_J_mut  := Minimality for sim_J Sort Prop.
Inductive sim_val {A} : val A → val' A → Prop :=
| sim_val_abs : ∀ v v', val_to_tm v ~ₑ val_to_tm' v' → v ~ᵥ v'
where "v ~ᵥ v'" := (sim_val v v').
Inductive sim_non {A} : non A → non' A → Prop :=
| sim_non_ : ∀ p p', non_to_tm p ~ₑ non_to_tm' p' → p ~ₚ p'
where "p ~ₚ p'" := (sim_non p p').
Inductive sim_K {A} : K A → K' A → Prop :=
| sim_K_nil  :
    K_nil ~ₖ K_nil'
| sim_K_cons : ∀ j j' k k',
    j ~ⱼ j' →
    k ~ₖ k' →
    K_cons j k ~ₖ K_let' k' <| ↑j'[0] |> (* J[K] ~ let x = K' in J'[0] *)
where "k ~ₖ k'" := (sim_K k k').
Inductive sim_T {A} : T A → T' A → Prop :=
| sim_T_nil  :
    T_nil ~ₜ T_nil'
| sim_T_cons : ∀ v v' k k' t t',
    v ~ᵥ v' →
    k ~ₖ k' →
    t ~ₜ t' →
    T_cons v k t ~ₜ T_cons' v' k' t'
where "t ~ₜ t'" := (sim_T t t').
Global Hint Constructors sim_J : core.
Global Hint Constructors sim_K : core.
Global Hint Constructors sim_T : core.
Global Hint Constructors sim_val : core.
Global Hint Constructors sim_non : core.
Global Hint Constructors sim_tm : core.

Lemma sim_let_fun {A} : ∀ (e1 : tm A) e2 e1' e2',
  e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1   e2 }> ~ₑ <| let e1' in (0   ↑e2') |>.
Proof.
  intros. apply (sim_let (J_fun _) _ (J_fun' _)); auto.
Qed.
Lemma sim_let_arg {A} : ∀ (v1 : val A) e2 (v1' : val' A) e2',
  v1 ~ₑ v1' → e2 ~ₑ e2' → <{ v1   e2 }> ~ₑ <| let e2' in ({liftV' v1'}  0 ) |>.
Proof.
  intros. apply (sim_let (J_arg _) _ (J_arg' _)); auto.
Qed.
Lemma sim_let_dol {A} : ∀ (e1 : tm A) e2 e1' e2',
  e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1 $ e2 }> ~ₑ <| let e1' in (0 $ ↑e2') |>.
Proof.
  intros. apply (sim_let (J_dol _) _ (J_dol' _)); auto.
Qed.
Global Hint Resolve sim_let_fun sim_let_arg sim_let_dol : core.

Fixpoint dollar_to_let {A} (e : tm A) : tm' A :=
  match e with
  | <{ var a }> => <| var a |>
  | <{ λ  e' }> => <| λ   {dollar_to_let e'} |>
  | <{ S₀ e' }> => <| S₀, {dollar_to_let e'} |>
  | <{ e1   e2 }> => <| {dollar_to_let e1}   {dollar_to_let e2} |>
  | <{ e1 $ e2 }> => <| {dollar_to_let e1} $ {dollar_to_let e2} |>
  end.

(* ANCHOR Reflexivity of the Similarity Relation *)

Lemma sim_refl_dollar_to_let : ∀ {A} (e : tm A),
  e ~ₑ dollar_to_let e.
Proof.
  induction e; cbn; auto.
Qed.

Lemma sim_tm_from_sim_val : ∀ {A v} {v' : val' A},
  v ~ᵥ v' →
  v ~ₑ v'.
Proof.
  intros. destruct v, v'; inversion H; clear H; subst; assumption.
Qed.
Global Hint Resolve sim_tm_from_sim_val : core.

Lemma sim_val_inv : ∀ {A} (v : val A) (e' : tm' A),
  v ~ₑ e' → ∃ (v' : val' A), e' = v' /\ v ~ᵥ v'.
Proof.
  intros. destruct v. inversion H; clear H; subst.
  exists (val_abs' e'0); split; auto. repeat constructor; auto.
  repeat eexists. repeat constructor; auto.
  destruct j; inversion H0.
Qed.

Lemma sim_non_inv : ∀ {A} (p : non A) (e' : tm' A),
  p ~ₑ e' → ∃ (p' : non' A), e' = p' /\ p ~ₚ p'.
Proof with split; cbn; auto; cbn; repeat (constructor; cbn); try assumption.
  intros. destruct p; inversion H; clear H; subst;
  try (destruct j; inversion H0; clear H0; subst; inversion H1; clear H1; subst).
  - exists (non_app' <| S₀ |> <| λ e'0 |>)...
  - exists (non_app' e1' e2')...
  - exists (non_let' e'0 <| 0 ↑e' |>)... apply sim_let_fun; auto.
  - exists (non_let' e'0 <| {liftV' v'} 0 |>)... apply sim_let_arg; auto.
  - exists (non_dol' e1' e2')...
  - exists (non_app' v1' v2')...
  - exists (non_let' e'0 <| 0 $ ↑e' |>)... apply sim_let_dol; auto.
Qed.

Ltac reason := repeat(
  match goal with
  | H : val_to_tm ?v ~ₑ ?e' |- _ =>
      let v' := fresh "v'" in
      let Hev := fresh "Hev" in
      let Hv := fresh "Hv" in
      apply sim_val_inv in H as [v' [Hev Hv]]; subst
  | H : non_to_tm ?p ~ₑ ?e' |- _ =>
      let p' := fresh "p'" in
      let Hep := fresh "Hep" in
      let Hp := fresh "Hp" in
      apply sim_non_inv in H as [p' [Hep Hp]]; rewrite Hep in *; clear e' Hep
  | H : val_to_tm' ?v1 = val_to_tm' ?v2 |- _ => apply inj_val' in H
  | H : val_to_tm  ?v1 = val_to_tm  ?v2 |- _ => apply inj_val  in H
  | H : non_to_tm  ?p1 = non_to_tm  ?p2 |- _ => rewrite H in *

  | H : non_to_tm  ?p = val_to_tm  ?v |- _ => destruct v, p; inversion H
  | H : val_to_tm  ?v = non_to_tm  ?p |- _ => destruct v, p; inversion H
  end).

Lemma broken_sim_plug_j_inv_as_term_not_nonvalue : ∀ {A} (j : J A) e term',
  <{ j[e] }> ~ₑ term' →
  (∃ j' e', j ~ⱼ j' /\ e ~ₑ e' /\ ( term' = <| j'[e'] |> \/ term' = <| let e' in ↑j'[0] |>)) \/
  (∃ v v' e', j = J_arg v /\ e ~ₑ e' /\ v ~ᵥ v' /\ term' = <| let v' in 0 ↑e' |>).
Proof.
  intros; destruct j; inversion H; clear H; subst; reason; cbn in *; subst;
  try solve [left; repeat eexists; eauto].
  admit. admit. left; repeat eexists; eauto.
  cbn.
  (* Imposible: v1' v2' = v1' $ v2' *)
Abort.

Lemma sim_plug_j_inv : ∀ {A} (j : J A) (p : non A) term',
  <{ j[p] }> ~ₑ term' →
  (∃ j' p', j ~ⱼ j' /\ p ~ₚ p' /\ ( term' = <| j'[p'] |> \/ term' = <| let p' in ↑j'[0] |>)) \/
  (∃ v v' p', j = J_arg v /\ p ~ₚ p' /\ v ~ᵥ v' /\ term' = <| let v' in 0 {↑(non_to_tm' p')} |>).
Proof.
  intros; destruct j; inversion H; clear H; subst; reason; cbn in *;
  try (inversion Hp; clear Hp; subst);
  try solve [left; repeat eexists; eauto];
  destruct j; inversion H0; clear H0; subst; reason; inversion H1; clear H1; subst; reason; subst; try (inversion Hp; clear Hp; subst);
  try solve [left; repeat eexists; eauto].
  right. repeat eexists; auto.
Qed.

(* k[p] ~ e' -->'* k'[p'] *)
Lemma plug_k_steps_to_similar_k' : ∀ (k : K ∅) (p : non ∅) term',
  <{ k [p] }> ~ₑ term' →
  ∃ (k' : K' ∅) (p' : non' ∅),
    term' -->'* <| k'[ p'] |> /\
    k ~ₖ k' /\
    p ~ₚ p'.
Proof with auto.
  induction k; intros; cbn in *.
  - apply sim_non_inv in H as [p' [H Hp]]; subst.
    exists K_nil'; exists p'; auto.
  - destruct (plug_non_is_non k T_nil p) as [kp Hkp]. cbn in Hkp. rewrite Hkp in H.
    apply sim_plug_j_inv in H as
      [[j' [p' [Hj [Hp [Hsub | Hsub]]]]]
      |[v [v' [p' [Hj [Hp [Hv Hsub]]]]]]
      ]; subst;
    inversion Hp; clear Hp; subst; rewrite <- Hkp in *; clear kp Hkp;
      apply IHk in H as [k' [p'' [Hstep [Hk He]]]].
    * exists (K_let' k' <| ↑j'[0] |>), p''; repeat split; cbn.
      + eapply multi_contr_multi'. apply contr_let'.
        apply multi_let'. apply Hstep.
      + constructor...
      + inversion He...
    * exists (K_let' k' <| ↑j'[0] |>), p''; repeat split; cbn.
      + apply multi_let'. apply Hstep.
      + constructor...
      + inversion He...
    * eexists (K_let' k' _), p''; repeat split; cbn.
      + eapply multi_contr_multi'. apply contr_let_beta'.
        cbn. rewrite bind_var_subst_lift'.
        eapply multi_contr_multi'. apply (contr_let' (J_arg' _)).
        apply multi_let'. apply Hstep.
      + constructor...
      + inversion He...
Qed.

Lemma plug_t_steps_to_similar_t' : ∀ (t : T ∅) (p : non ∅) term',
  <{ t [p] }> ~ₑ term' →
  ∃ (t' : T' ∅) (p' : non' ∅),
    term' -->'* <| t'[ p'] |> /\
    t ~ₜ t' /\
    p ~ₚ p'.
Proof.
  induction t; intros; cbn in *.
  - apply sim_non_inv in H as [p' [H Hp]]; subst.
    exists T_nil'; exists p'; auto.
  - inversion H; clear H; reason; subst.
    + destruct (plug_non_is_non K_nil t p) as [tp Htp]; cbn in Htp. rewrite Htp in H4.
      apply plug_k_steps_to_similar_k' in H4 as [k' [p' [Hmulti1 [Hk Hp]]]].
      inversion Hp; clear Hp; subst.
      rewrite <- Htp in H.
      apply IHt in H as [t' [p'' [Hmulti2 [Ht Hp2]]]].
      repeat eexists; eauto; cbn.
      apply multi_delim'.
      apply (multi_trans Hmulti1).
      apply (multi_k' Hmulti2).
      inversion Hp2; clear Hp2; subst. auto.
    + destruct (plug_non_is_non k t p) as [tp Htp]; cbn in Htp. rewrite Htp in *.
      destruct v2, tp; inversion H1.
    + destruct j; inversion H0; clear H0; subst.
      inversion H1; clear H1; subst; reason.
      destruct (plug_non_is_non K_nil t p) as [tp Htp]; cbn in Htp. rewrite Htp in H0.
      apply plug_k_steps_to_similar_k' in H0 as [k' [p' [Hmulti1 [Hk Hp]]]].
      inversion Hp; clear Hp; subst.
      rewrite <- Htp in H.
      apply IHt in H as [t' [p'' [Hmulti2 [Ht Hp2]]]].
      repeat eexists; eauto; cbn.
      apply (multi_contr_multi' (contr_let_beta' _ _)).
      cbn. change (map' Some e'0) with (↑e'0). rewrite bind_var_subst_lift'.
      apply multi_delim'.
      apply (multi_trans Hmulti1).
      apply (multi_k' Hmulti2).
      inversion Hp2; clear Hp2; subst. auto.
Qed.

Lemma plug_kt_steps_to_similar_kt' : ∀ (k : K ∅) (t : T ∅) (p : non ∅) term',
  <{ k [t [p]] }> ~ₑ term' →
  ∃ (k' : K' ∅) (t' : T' ∅) (p' : non' ∅),
    term' -->'* <| k'[ t' [p']] |> /\
    k ~ₖ k' /\
    t ~ₜ t' /\
    p ~ₚ p'.
Proof.
  intros.
  destruct (plug_non_is_non K_nil t p) as [tp Htp]; cbn in Htp. rewrite Htp in H.
  apply plug_k_steps_to_similar_k' in H as [k' [p1 [Hmulti1 [Hk Hp1]]]].
  inversion Hp1; clear Hp1; reason; subst.
  rewrite <- Htp in *.
  apply plug_t_steps_to_similar_t' in H as [t' [p2 [Hmulti2 [Ht Hp2]]]].
  inversion Hp2; clear Hp2; reason; subst;
  repeat eexists; eauto;
  apply (multi_trans Hmulti1);
  apply (multi_k' Hmulti2).
Qed.

Lemma sim_map : ∀ {A} {e e' B} {f : A → B},
  e ~ₑ e' →
  map f e ~ₑ map' f e'.
Proof with auto.
  intros. generalize dependent B.
  induction H using sim_tm_mut with
    (P0 := λ A j j', ∀ B (f : A → B), mapJ f j ~ⱼ mapJ' f j');
  intros; cbn; auto; reason; subst;
  try rewrite <- lift_val_to_tm;
  try rewrite <- lift_val_to_tm';
  try rewrite <- lift_map;
  try rewrite <- lift_map'...

  (* sim_eta *)
  rename v'0 into v'.
  destruct (map_val_is_val  v  f) as [v2  Hrv ].
  destruct (map_val_is_val' v' f) as [v2' Hrv'].
  rewrite Hrv; rewrite Hrv'.
  rewrite lift_val_to_tm.
  apply sim_eta.
  rewrite <- Hrv; rewrite <- Hrv'.
  apply IHsim_tm.

  (* sim_eta_dol *)
  rename v'0 into v1'.
  rename v' into v2'.
  destruct (map_val_is_val  v1  f) as [w1  Hrv1 ].
  destruct (map_val_is_val' v1' f) as [w1' Hrv1'].
  destruct (map_val_is_val  v2  f) as [w2  Hrv2 ].
  destruct (map_val_is_val' v2' f) as [w2' Hrv2'].
  rewrite Hrv1; rewrite Hrv1'; rewrite Hrv2; rewrite Hrv2'.
  apply sim_eta_dol.
  rewrite <- Hrv1; rewrite <- Hrv1'...
  rewrite <- Hrv2; rewrite <- Hrv2'...

  (* sim_let *)
  rewrite map_plug_j_is_plug_of_maps.
  rewrite map_plug_j_is_plug_of_maps'; cbn.
  rewrite <- lift_mapJ'.
  apply sim_let...

  (* J *)
  constructor.
  rewrite mapV_is_map; rewrite mapV_is_map'...
Qed.
Global Hint Resolve sim_map : core.

Lemma sim_bind : ∀ {A} {e e' B} {f : A → tm B} {f' : A → tm' B},
  e ~ₑ e' →
  (∀ a, f a ~ₑ f' a) →
  bind f e ~ₑ bind' f' e'.
Proof with auto.
  intros. generalize dependent B.
  induction H using sim_tm_mut with
    (P0 := λ A j j', ∀ B (f : A → tm B) (f' : A → tm' B), (∀ a, f a ~ₑ f' a) → bindJ f j ~ⱼ bindJ' f' j');
  intros; cbn; auto;
  try solve [constructor; apply IHsim_tm; auto; intros [a|]; auto];
  try rewrite <- lift_val_to_tm;
  try rewrite <- lift_val_to_tm';
  try (rewrite bind_lift + rewrite bind_lift'); try rewrite lambda_match_just_some;
  try change (λ a : A, map Some (f a)) with (lift ∘ f);
  try change (λ a : A, map' Some (f' a)) with (lift ∘ f');
  try rewrite <- lift_bind';
  try rewrite <- lift_bind;
  reason; subst; auto.

  (* sim_eta *)
  rename v'0 into v'.
  destruct (bind_val_is_val  v  f ) as [v2  Hrv ].
  destruct (bind_val_is_val' v' f') as [v2' Hrv'].
  rewrite Hrv; rewrite Hrv'.
  rewrite lift_val_to_tm.
  apply sim_eta.
  rewrite <- Hrv; rewrite <- Hrv'...

  (* ṣim_eta_dol *)
  rename v'0 into v1'.
  rename v' into v2'.
  destruct (bind_val_is_val  v1  f ) as [w1  Hrv1 ].
  destruct (bind_val_is_val' v1' f') as [w1' Hrv1'].
  destruct (bind_val_is_val  v2  f ) as [w2  Hrv2 ].
  destruct (bind_val_is_val' v2' f') as [w2' Hrv2'].
  rewrite Hrv1; rewrite Hrv1'; rewrite Hrv2; rewrite Hrv2'.
  apply sim_eta_dol.
  rewrite <- Hrv1; rewrite <- Hrv1'...
  rewrite <- Hrv2; rewrite <- Hrv2'...

  (* sim_let *)
  rewrite bind_plug_j_is_plug_of_binds;
  rewrite bind_plug_j_is_plug_of_binds'.
  rewrite bindJ_lift'. rewrite lambda_match_just_some. cbn. rewrite <- lift_bindJ'.
  apply sim_let...

  (* J *)
  constructor.
  rewrite bindV_is_bind; rewrite bindV_is_bind'...
Qed.
Global Hint Resolve sim_bind : core.

Lemma sim_plug_j : ∀ {A} (j : J A) j' e e',
  j ~ⱼ j' →
  e ~ₑ e' →
  <{ j[e] }> ~ₑ <| j'[e'] |>.
Proof with auto.
  intros; inversion H; clear H; subst; cbn...
Qed.

Lemma sim_plug_k : ∀ {A} (k : K A) k' e e',
  k ~ₖ k' →
  e ~ₑ e' →
  <{ k[e] }> ~ₑ <| k'[e'] |>.
Proof.
  intros. generalize dependent e. generalize dependent e'.
  induction H; intros; cbn; auto.
Qed.

Lemma sim_plug_t : ∀ {A} (t : T A) t' e e',
  t ~ₜ t' →
  e ~ₑ e' →
  <{ t[e] }> ~ₑ <| t'[e'] |>.
Proof.
  induction t; intros; inversion H; clear H; subst; cbn; auto.
  constructor; auto.
  apply sim_plug_k; auto.
Qed.

Lemma sim_lift : ∀ {A} {e : tm A} {e'},
   e ~ₑ  e' →
  ↑e ~ₑ ↑e'.
Proof.
  intros. unfold lift. unfold LiftTm'. unfold LiftTm. apply (sim_map H).
Qed.
Global Hint Resolve sim_lift : core.

Lemma sim_lift_val : ∀ {A} {v : val A} {v'},
  v ~ᵥ v' →
  liftV v ~ᵥ liftV' v'.
Proof.
  intros.
  inversion H; clear H; subst.
  constructor.
  rewrite <- lift_val_to_tm.
  rewrite <- lift_val_to_tm'.
  apply sim_lift; assumption.
Qed.
Global Hint Resolve sim_lift_val : core.

Lemma sim_lift_j : ∀ {A} {j : J A} {j'},
   j ~ⱼ  j' →
  ↑j ~ⱼ ↑j'.
Proof.
  intros. inversion H; clear H; subst; cbn; auto.
  reason; subst.
  apply sim_lift_val in Hv. auto.
Qed.
Global Hint Resolve sim_lift_j : core.

Lemma sim_lift_k : ∀ {A} {k : K A} {k'},
   k ~ₖ  k' →
  ↑k ~ₖ ↑k'.
Proof with auto.
  intros; induction H; cbn...

  assert (map' (option_map Some) <| ↑j'[0] |> = <| ↑↑j'[0] |>) as HH.
    inversion H; clear H; subst; cbn;
    try change (map' Some e') with (↑e');
    try change (mapV' Some v') with (liftV' v');
    repeat rewrite mapV_is_map';
    repeat rewrite <- lift_val_to_tm';
    unfold lift; unfold LiftTm';
    repeat rewrite map_map_law'...
  rewrite HH.
  constructor...
  apply sim_lift_j...
Qed.
Global Hint Resolve sim_lift_k : core.

Lemma sim_subst_lemma : ∀ e e' v (v' : val' ∅),
  e ~ₑ e' →
  v ~ᵥ v' →
  <{ e [0 := v] }> ~ₑ <| e' [0 := v'] |>.
Proof.
  intros. unfold tm_subst0. unfold tm_subst0'.
  apply sim_bind; auto.
  intros [n|]; try destruct n; cbn. auto.
Qed.

Ltac laws := repeat(
  try match goal with
  | |- context C [bind' (var_subst' _) (mapV' Some _)] =>
      rewrite mapV_is_map'
  end;
  try match goal with
  | |- context C [bind  (var_subst  _) (val_to_tm  (liftV  ?v))] =>
      rewrite <- (lift_val_to_tm  v)
  | |- context C [bind' (var_subst' _) (val_to_tm' (liftV' ?v))] =>
      rewrite <- (lift_val_to_tm' v)
  | |- context C [bind  (var_subst  _) (map  Some ?e)] =>
      change (map Some e) with (↑e)
  | |- context C [bind' (var_subst' _) (map' Some ?e)] =>
      change (map' Some e) with (↑e)
  end;
  match goal with
  | |- context C [bind  (var_subst  _) (↑ _)] =>
      rewrite bind_var_subst_lift
  | |- context C [bind' (var_subst' _) (↑ _)] =>
      rewrite bind_var_subst_lift'
  end).

Lemma k_inv_inner' : ∀ (k : K ∅) (k' : K' ∅),
  k ~ₖ k' →
  (k = K_nil /\ k' = K_nil') \/
  (∃ (k2 : K ∅) (k2' : K' ∅) (j2 : J ∅) (j2' : J' ∅),
    k2 ~ₖ k2' /\
    j2 ~ⱼ j2' /\
    (∀ (e  : tm ^∅), <{ ↑k[e ] }> = <{ ↑k2[↑j2[e ]] }>) /\
    (∀ (e' : tm' ∅), <| k'[e'] |> = <| k2'[let e' in ↑j2'[0]] |>)).
Proof with auto.
  induction k; intros; inversion H; clear H; subst; cbn; auto.
  destruct (IHk _ H4) as [[Hk Hk'] | [k2 [k2' [j2 [j2' [Hk2 [Hj2 [Hke Hke']]]]]]]]; subst; right.
  - exists K_nil, K_nil'. repeat eexists...
  - exists (K_cons j k2), (K_let' k2' <| ↑j'[0] |>), j2, j2'; repeat split; auto; intros.
    + rewrite Hke in *. reflexivity.
    + rewrite Hke' in *. reflexivity.
Qed.

Lemma sim_redex_beta : ∀ e (v : val ∅) ev' v',
  <{ λ e }> ~ₑ ev' →
  v ~ᵥ v' → ∃ term',
    <| ev' v' |> -->'* term' /\
    <{ e [0 := v] }> ~ₑ term'.
Proof with auto.
  intros. inversion H; clear H; subst.
  - repeat eexists.
    + apply multi_contr'. apply contr_beta'.
    + apply sim_subst_lemma...

  (* <{ (λ e) v }> = <{ (λ ↑v0 $ 0) v }> ~> <{ v0 $ v }> ~ₑ <{ v0' v' }>, a case where λ$ is behind one step *)
  - repeat eexists.
    + auto.
    + cbn. laws. apply sim_eta_dol...
  - destruct j; inversion H1.
Qed.

(* ANCHOR Simulation Step
 *)
Theorem dollar_step_to_let_multi : ∀ e1 e2 e1',
  e1 --> e2 →
  e1 ~ₑ e1' →
  ∃ e2', e1' -->'* e2' /\ e2 ~ₑ e2'.
Proof with auto.
  intros term1 term2 term1' Hstep Hsim.
  inversion Hstep; clear Hstep; subst.
  inversion H; clear H; subst.
  destruct (redex_is_non r) as [p Hrp]. rewrite Hrp in Hsim.
  apply plug_kt_steps_to_similar_kt' in Hsim as [k' [t' [p' [Hmulti [Hk [Ht Hp]]]]]].
  inversion Hp; clear Hp; subst.
  rewrite <- Hrp in *. clear Hrp p.
  destruct r; cbn in *.

  (* redex_beta *)
  { destruct v.
    inversion H; clear H; subst; reason;
    try (rewrite <- H2 in *; clear p' H2);
    try (rewrite <- H1 in *; clear p' H1);
    try (destruct j; inversion H0; clear H0; subst; inversion H2; clear H2; subst; reason).
    * destruct (sim_redex_beta _ _ _ _ H3 Hv) as [term' [Hmulti2 Hsim]].
      repeat eexists.
      + apply (multi_trans Hmulti). eapply multi_k'. eapply multi_t'. apply Hmulti2.
      + apply sim_plug_k... apply sim_plug_t...
    * destruct (sim_redex_beta _ _ _ _ H3 Hv) as [term' [Hmulti2 Hsim]].
      rewrite lambda_to_val in H3; reason.
      repeat eexists.
      + apply (multi_trans Hmulti). eapply multi_k'. eapply multi_t'.
        eapply multi_contr_multi'. apply contr_let_beta'.
        cbn. laws. apply Hmulti2.
      + apply sim_plug_k... apply sim_plug_t...
    * rewrite lambda_to_val in H1. apply inj_val in H1. subst.
      inversion Hv; clear Hv; subst. cbn in H.
      destruct (sim_redex_beta _ _ _ _ H Hv0) as [term' [Hmulti2 Hsim]].
      repeat eexists.
      + apply (multi_trans Hmulti). eapply multi_k'. eapply multi_t'.
        eapply multi_contr_multi'. apply contr_let_beta'.
        cbn. rewrite mapV_is_map'. laws. apply Hmulti2.
      + apply sim_plug_k... apply sim_plug_t...
  }

  (* redex_dollar *)
  { destruct p'; inversion H; clear H; reason; subst.
    + repeat eexists.
      * apply Hmulti.
      * apply sim_plug_k... apply sim_plug_t... constructor...
    + repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        cbn. apply (multi_contr' (contr_dollar' _ _)).
      - apply sim_plug_k... apply sim_plug_t...
    + destruct j; inversion H0; clear H0; subst; inversion H3; clear H3; subst; reason.
      cbn in *.
      repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        apply (multi_contr_multi' (contr_let_beta' _ _)).
        cbn. laws.
        apply (multi_contr' (contr_dollar' _ _)).
      - apply sim_plug_k... apply sim_plug_t...
  }

  (* redex_shift *)
  { change <{ S₀ t0 }> with (non_to_tm (non_s_0 t0)) in H.
    apply (plug_t_steps_to_similar_t' (T_cons v k0 T_nil) _ _) in H as [t'' [p'' [Hmulti' [Ht' Hp']]]].
    inversion Ht'; clear Ht'; subst. inversion H5; clear H5; subst. inversion Hp'; clear Hp'; subst. cbn in *.
    inversion H; clear H; subst; try solve [destruct j; inversion H0].
    rewrite <- H1 in *. clear H1 p''.
    destruct (k_inv_inner' _ _ H4) as [[Hk0 Hk'0] | [k2 [k2' [j2 [j2' [Hk2 [Hj2 [Hke Hke']]]]]]]]; subst.
    + repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        apply (multi_trans Hmulti').
        apply (multi_contr_multi' (contr_shift' v' <| λv' e' |>)).
        apply (multi_contr' (contr_beta' _ _)).
      - apply sim_plug_k... apply sim_plug_t... apply sim_subst_lemma... cbn. constructor. apply sim_eta...
    + repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        rewrite Hke' in *.
        apply (multi_trans Hmulti').
        eapply multi_trans.
        eapply multi_delim'.
        apply (plug_k_let_reassoc_s_0 _ _ _).
        eapply multi_contr_multi'. rewrite lambda_to_val'. apply contr_dol_let'.
        eapply multi_contr_multi'. rewrite lambda_to_val'. apply contr_shift'.
        apply multi_contr'. apply contr_beta'.
      - apply sim_plug_k... apply sim_plug_t... apply sim_subst_lemma...
        rewrite Hke.
        constructor. constructor. constructor... apply sim_plug_k... apply sim_plug_j...
  }
Qed.

(* ANCHOR Simulation
 *)
Theorem dollar_multi_to_let_multi : ∀ e1 e2 e1',
  e1 -->* e2 →
  e1 ~ₑ e1' →
  ∃ e2', e1' -->'* e2' /\ e2 ~ₑ e2'.
Proof.
  intros. generalize dependent e1'.
  induction H; intros;
  try solve [repeat eexists; auto].

  eapply (dollar_step_to_let_multi _ _ _ H) in H1 as Hstep. destruct Hstep as [e2' [Hmulti1 Hsim1]].
  apply IHmulti in Hsim1 as Hstep. destruct Hstep as [e3' [Hmulti2 Hsim2]].
  repeat eexists.
  - apply (multi_trans Hmulti1 Hmulti2).
  - assumption.
Qed.
(* Print Assumptions dollar_multi_to_let_multi. *)

Theorem dollar_multi_to_let_multi_val : ∀ e (v : val ∅) e',
  e -->* v →
  e ~ₑ e' →
  ∃ (v' : val' ∅), e' -->'* v' /\ v ~ᵥ v'.
Proof.
  intros e v e' Hmulti Hsim.
  destruct (dollar_multi_to_let_multi e v e' Hmulti Hsim) as [v' [Hmulti' Hsim']].
  reason; eauto.
Qed.

Theorem dollar_to_let_equivalent_steps : ∀ e (v : val ∅),
  e -->* v →
  ∃ (v' : val' ∅), dollar_to_let e -->'* v' /\ v ~ᵥ v'.
Proof.
  intros.
  apply (dollar_multi_to_let_multi_val e v (dollar_to_let e) H).
  apply sim_refl_dollar_to_let.
Qed.


Module Type S.
Parameter A : Type.
End S.

Module Type ES.
Parameter A : Type.
Parameter eq : A -> A -> Type.
End ES.

Module Make
  (AX : S)
  (X : ES with Definition A := AX.A with Definition eq := @eq AX.A).


(**
CoLoR, a Coq library on rewriting and termination.

See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2013-09-17

* Termination proof of Goedel System T
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil OrdUtil LSimple RelUtil.
From Coq Require Import Structures.Equalities Lia.
From CoLoR Require SetUtil.

(****************************************************************************)
(** ** Type constants of System T. **)

Inductive B : Type := Nat : B.

Lemma eq_B_dec : forall a b : B, {a=b}+{~a=b}.

Proof. (*COQ:decide equality*)destruct a. destruct b. auto. Qed.

(** [Typ] structure for type constants. *)

Module BTyp <: Typ.

  Definition t := B.

End BTyp.

(** [Cmp] structure for type constants. *)

Module BCmp <: Cmp.

  Include BTyp.

  Definition cmp (_ _ : B) := Eq.

  Lemma cmp_opp x y : cmp x y = CompOpp (cmp y x).

  Proof. refl. Qed.

End BCmp.

(** [CmpTransLeibniz] structure for type constants. *)

Module BCmpTransLeibniz <: CmpTransLeibniz.

  Include BCmp.

  Lemma cmp_eq x y : cmp x y = Eq -> x = y.

  Proof. destruct x; destruct y. refl. Qed.

  Lemma cmp_lt_trans x y z : cmp x y = Lt -> cmp y z = Lt -> cmp x z = Lt.

  Proof. fo. Qed.

End BCmpTransLeibniz.

(****************************************************************************)
(** ** Types of System T. *)

Notation TNat := (Base Nat).

(** [Cmp] structure for System T types. *)

Module Ty_Cmp := ST_Cmp BCmp.

(** [CmpTransLeibniz] structure for System T types. *)

Module Ty_CmpTransLeibniz := ST_CmpTransLeibniz BCmpTransLeibniz.

(****************************************************************************)
(** ** Function symbols of System T. *)

Inductive F : Type :=
| Zero : F
| Succ : F
| Rec : Ty B -> F.

(** Well-founded precedence on function symbols. *)

Definition prec f :=
  match f with
    | Zero => 0
    | Succ => 1
    | Rec _ => 2
  end.

(** [Cmp] structure for function symbols.

We use the lexicographic path ordering with Zero < Succ < Rec A and
Rec A < Rec B if A < B. *)

From Coq Require Import Compare_dec.

Module FCmp <: Cmp.

  Definition t := F.

  Definition cmp f g :=
    match f, g with
      | Rec u, Rec v => Ty_Cmp.cmp u v
      | _, _ => Nat.compare (prec f) (prec g)
    end.

  Lemma cmp_opp f g : cmp f g = CompOpp (cmp g f).

  Proof. destruct f; destruct g; try refl. apply Ty_Cmp.cmp_opp. Qed.

End FCmp.

(** [CmpTransLeibniz] structure for function symbols. *)

Module FCmpTransLeibniz <: CmpTransLeibniz.

  Include FCmp.

  Lemma cmp_eq x y : cmp x y = Eq -> x = y.

  Proof.
    destruct x; destruct y; simpl; try (refl||discr).
    intro e. apply Ty_CmpTransLeibniz.cmp_eq in e. subst. refl.
  Qed.

  Lemma cmp_lt_trans x y z : cmp x y = Lt -> cmp y z = Lt -> cmp x z = Lt.

  Proof.
    destruct x; destruct y; destruct z; simpl; try (refl||discr).
    apply Ty_CmpTransLeibniz.cmp_lt_trans.
  Qed.

End FCmpTransLeibniz.

(** [OrderedType] structure for function symbols. *)

Module FMOT := MOT_of_CmpTransLeibniz FCmpTransLeibniz.

Module FOrd := MOT_to_OT FMOT.

(****************************************************************************)
(** ** [L] structure (term algebra) of System T. *)

From CoLoR Require Import VecUtil.

Module L_SystemT <: L_Struct.

  Definition F := F.

  Module FOrd := FOrd.

  Module Export V := NatVar.

  Notation Te := (Te F X).
  Notation Tes := (vector Te).

  Notation Var := (@Var F X).
  Notation Fun := (@Fun F X).
  Notation App := (@App F X).
  Notation Lam := (@Lam F X).

  Notation apps := (@apps F X).
  Notation fv := (@fv F X ens_X).
  Notation eq_term_dec := (@eq_term_dec F X FOrd.eq_dec XOrd.eq_dec).

  Notation FZero := (Fun Zero).
  Notation FSucc := (Fun Succ).
  Definition FRec A := Fun (Rec A).

End L_SystemT.

(****************************************************************************)
(** ** [RS] structure (rewrite rules) of System T. *)

From CoLoR Require Import LCompRewrite.
Import VectorNotations.
Local Open Scope vector_scope.

Module RS_SystemT <: RS_Struct.

  Module Export L := L_SystemT.

  (* Some variables. *)
  Definition u := Var 0.
  Definition v := Var 1.
  Definition n := Var 2.

  Inductive R : relation Te :=
  | rule_Rec_Zero : forall A, R (apps (Fun (Rec A)) [FZero; u; v]) u
  | rule_Rec_Succ : forall A, R (apps (Fun (Rec A)) [apps FSucc [n]; u; v])
                                (apps v [n; apps (FRec A) [n; u; v]]).

  Definition rule := R.

  Global Instance fv_rule : Proper (rule --> Subset) fv.

  Proof.
    intros a b ba. inversion ba; subst; simpl; intro x; set_iff; tauto.
  Qed.

  Definition lhs_fun l r (_ : rule l r) :=
    match head l with
      | Def.Fun f => f
      | _ => Zero (* don't care *)
    end.

  Definition lhs_nb_args l r (_ : rule l r) := 3.

  Definition lhs_args l r :=
    match l as l return forall h : rule l r, Tes (lhs_nb_args h) with
      | Def.App (Def.App (Def.App (Def.Fun _) l1) l2) l3 =>
        fun _ => [l1; l2; l3]
      | _ => fun _ => [FZero; FZero; FZero] (* don't care *)
    end.

  Lemma lhs_ok l r ( h : rule l r) : l = apps (Fun (lhs_fun h)) (lhs_args h).

  Proof. inversion h; subst; refl. Qed.

End RS_SystemT.

(****************************************************************************)
(** ** [ST] structure (types of function symbols) of System T. *)

From Coq Require FMapAVL.

Module ST_SystemT <: ST_Struct.

  Module Export L := L_SystemT.

  Definition So := B.

  Notation Ty := (Ty So).

  Notation TNat := (Base Nat).

  Definition typ f :=
    match f with
      | Zero => TNat
      | Succ => TNat ~~> TNat
      | Rec A => TNat ~~> A ~~> (TNat ~~> A ~~> A) ~~> A
    end.

  Module Export XMap := FMapAVL.Make XOrd.

  Notation En := (@XMap.t Ty).
  Notation empty := (@XMap.empty Ty).
  Notation add := (@XMap.add Ty).
  Notation In := (@XMap.In Ty).
  Notation MapsTo := (@XMap.MapsTo Ty).
  Notation Equal := (@XMap.Equal Ty).
  Notation env := (mk_Env empty add In MapsTo Equal).

End ST_SystemT.

(****************************************************************************)
(** ** [DLQO] structure for the termination proof of System T.

We use [prec] to quasi-order function symbols in a wellfounded way. *)

From CoLoR Require Import SN LCall.

Module DLQO_SystemT <: DLQO_Struct.

  Module Export ST := ST_SystemT.

  Definition C := F.

  Definition code (f : F) := f.

  Import FCmp.

  Definition gtC := Rof gt prec.

  Lemma gtC_wf : WF gtC.

  Proof. apply WF_inverse. apply WF_gt. Qed.

  Definition filter_arity (_ : F) := 1.

  Definition filter (_ : F) := [0].

  Notation gt_call := (@gt_call F X C code gtC).
  Notation gt_args_lex := (@gt_args_lex F X FOrd.eq_dec XOrd.eq_dec ens_X
    var_notin C filter_arity filter).

End DLQO_SystemT.

(****************************************************************************)
(** ** Wellfounded [OrderedType] structure on type constants.

We use the empty relation to quasi-order type constants in a
wellfounded way. *)

From CoLoR Require Import EqUtil.

Module BOrdWF_MOT <: MiniOrderedType.

  Include BTyp.

  Include LeibnizFacts BTyp.

  Definition lt : relation t := empty_rel.

  Global Instance lt_trans : Transitive lt.

  Proof. fo. Qed.

  Lemma lt_not_eq x y : lt x y -> x <> y.

  Proof. fo. Qed.

  Lemma compare x y : Compare lt eq x y.

  Proof. apply EQ. destruct x; destruct y. refl. Qed.

End BOrdWF_MOT.

Module BOrdWF := MOT_to_OT BOrdWF_MOT.

(****************************************************************************)
(** ** [BI] structure (accessible arguments) of System T. *)

From CoLoR Require Import LCompInt.

Module BI_SystemT <: BI_Struct.

  Module Export ST := ST_SystemT.

  Module Export BOrd := BOrdWF.

  Infix "<B" := lt (at level 70).

  Lemma ltB_wf : well_founded lt.

  Proof. intro b. apply Acc_intro. fo. Qed.

  Import SetUtil.

  Inductive acc : F -> set nat :=
  | Acc_Succ : acc Succ 0.

  Definition Acc := acc.

  Lemma Acc_arity f i (hi : Acc f i) : i < arity (typ f).

  Proof. inversion hi; clear hi; subst; simpl; lia. Qed.

  Lemma Acc_ok f i (hi : Acc f i) a :
    occurs a (Vnth (inputs (typ f)) (Acc_arity hi)) ->
    a <B output_base (typ f)
    \/ (a = output_base (typ f)
      /\ pos a (Vnth (inputs (typ f)) (Acc_arity hi))).

  Proof. inversion hi; subst; simpl; clear hi. fo. Qed.

  Notation aeq := (@aeq F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation supterm_acc := (@supterm_acc F X So typ Acc Acc_arity).

End BI_SystemT.

(****************************************************************************)
(** ** [CC] structure for the termination proof of System T. *)

From CoLoR Require Import LCompClos.

Module CC_SystemT <: CC_Struct.

  Module Export BI := BI_SystemT.

  Notation cc := (@cc F X So ens_X env typ Acc Acc_arity).

End CC_SystemT.

(****************************************************************************)
(** ** Termination proof of System T. *)

(*VERY SLOW*)Module Export SN := SN_rewrite CC_SystemT RS_SystemT DLQO_SystemT.

From CoLoR Require Import Lexico.

Import DLQO_SystemT RS_SystemT.

Lemma tr_sn_SystemT : forall E v V, E |- v ~: V -> SN R_aeq v.

Proof.
  apply tr_sn_beta_eta_rewrite_aeq.
  intros l r h; inversion h; subst;
    unfold lhs_fun, lhs_args, lhs_nb_args; simpl.

  (* rule_Rec_Zero *)
  eapply cc_arg' with (i:=1); refl.

  (* rule_Rec_Succ *)
  set (ls := [App FSucc n; u; v]).

  assert (hn : cc gt1 (Rec A) ls ST.empty n TNat).
  eapply cc_acc' with (g:=Succ) (us:=[n]) (i:=0); simpl; try refl.
  eapply cc_arg' with (i:=0); refl.

  assert (hv : cc gt1 (Rec A) ls ST.empty v (TNat ~~> A ~~> A)).
  eapply cc_arg' with (i:=2); simpl; refl.

  assert (hu : cc gt1 (Rec A) ls ST.empty u A).
  eapply cc_arg' with (i:=1); simpl; refl.

  eapply cc_app. eapply cc_app. apply hv. hyp.
  eapply cc_call' with (g:=Rec A) (us:=[n; u; v]); try refl.
  simpl. lia.
  unfold gt1, Def.gt_call, Rof, transp. apply right_lex.
  unfold Def.gt_args_lex, Rof, lexv; simpl. apply lex1. apply opt_intro.
  unfold gt. apply clos_aeq_intro_refl. apply t_step.
  eapply stacc_intro' with (i:=0) (f:=Succ) (ts:=[n]); try refl.
  intros i i1 i2. destruct i. simpl. hyp. destruct i.
  simpl. hyp. destruct i. simpl. hyp. lia.

  Unshelve.
  simpl; lia. simpl; lia. apply Acc_Succ. simpl; lia. simpl; lia. simpl; lia.
  simpl; lia. simpl; lia. simpl; lia. apply Acc_Succ.
Qed.


Require Export Iron.Language.SystemF2Store.ExpBase.
Require Import Iron.Language.SystemF2Store.ExpLift.

(* Substitution of Types in Exps *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx
  | XLoc _     => xx

  |  XLAM x
  => XLAM (substTX (S d) (liftTT 1 0 u) x)

  |  XAPP x t
  => XAPP (substTX d u x)  (substTT d u t)

  |  XLam t x
  => XLam (substTT d u t)  (substTX d u x)

  |  XApp x1 x2
  => XApp (substTX d u x1) (substTX d u x2)

  |  XCon dc ts xs
  => XCon dc (map (substTT d u) ts) (map (substTX d u) xs)

  |  XCase xx alts
  => XCase (substTX d u xx) (map (substTA d u) alts)

  |  XUpdate c i ts x1 x2
  => XUpdate c i (map (substTT d u) ts) (substTX d u x1) (substTX d u x2)
 end

with substTA (d: nat) (u: ty) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (substTX d u xx)
  end.

(* Substitution of Exps in Exps *)
Fixpoint substXX (d:  nat) (u: exp) (xx: exp) : exp :=
 match xx with
    | XVar ix
    => match nat_compare ix d with
       (* Index matches the one we are substituting for. *)
       | Eq  => u

       (* Index was free in the original expression.
          As we've removed the outermost binder, also decrease this
          index by one. *)
       | Gt  => XVar (ix - 1)

       (* Index was bound in the original expression. *)
       | Lt  => XVar ix
       end

    |  XLoc l
    => XLoc l

    |  XLAM x1
    => XLAM (substXX d (liftTX 0 u) x1)

    |  XAPP x1 t2
    => XAPP (substXX d u x1) t2

    (* Increase the depth as we move across a lambda.
       Also lift free references in the exp being substituted
       across the lambda as we enter it. *)
    |  XLam t1 x2
    => XLam t1 (substXX (S d) (liftXX 1 0 u) x2)

    (* Applications *)
    |  XApp x1 x2
    => XApp (substXX d u x1) (substXX d u x2)

    |  XCon dc ts xs
    => XCon dc ts (map (substXX d u) xs)

    |  XCase x alts
    => XCase (substXX d u x) (map (substXA d u) alts)

    |  XUpdate c i ts x1 x2
    => XUpdate c i ts (substXX d u x1) (substXX d u x2)
    end

with substXA (d: nat) (u: exp) (aa: alt)
 := match aa with
    |  AAlt (DataCon tag arity) x
    => AAlt (DataCon tag arity)
         (substXX (d + arity)
                  (liftXX arity 0 u) x)
    end.

(* Substitute several expressions.

   Note that in the definition, each time we substitute an
   exp (u), we need to lift it by the number of exps remaining
   in the list (us). This is because we're placing the substitued
   exp under the binders corresponding to the remaining ones.

   The added lifting is then gradually "undone" each time we
   substitue one of the remaining expressions. This happens due
   to the free variable/Gt case in the definition of substX.

   Example:
               (A->B), A |- 0 :: A
               (A->B), A |- 1 :: (A->B)
    (A->B), A, A, (A->B) |- (0 1) [1 0] :: B

    Substitute first exp in list.
            (A->B), A, A |- (2 0) [0] :: B

    We get '2' by adding the length of the remaining substitution
    (1) to the index substituted (1). The argument of the function
    is changed from 1 to 0 by the free variable case of substX.

    Substitute remaining exp in list.
               (A->B), A |- (1 0) :: B

    Here, 0 is subst for 0, and 2 changes to 1 due as it's a free
    variable.
*)
Fixpoint substXXs (d: nat) (us: list exp) (xx: exp) :=
 match us with
 | nil      => xx
 | u :: us' => substXXs d us'
                 (substXX d (liftXX (List.length us') 0 u)
                            xx)
 end.

(* The data constructor of an alternative is unchanged
   by exp substitution. *)
Lemma dcOfAlt_substXA
 : forall d u a
 , dcOfAlt (substXA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substXA : global.

(* The data constructor of an alternative is unchanged
   by type substitution. *)
Lemma dcOfAlt_substTA
 : forall d u a
 , dcOfAlt (substTA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substTA : global.