Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import Coq.Program.Equality.
Require Import SystemF.
Require Import Typing.

Module MExtended
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MTyping := MTyping(VarTyp)(set).
Export MTyping.

(* Notes:

The syntax is encoded using Charguéraud's Locally nameless representation:

http://www.chargueraud.org/softs/ln/

We annotate the Coq theorems with the correnposing lemmas/theorems in the paper.
The reader can just look for:

Lemma 4

for example, to look for the proof of lemma 4 in the paper.

All lemmas and theorems are complete: there are no uses of admit or Admitted,
with the exceptions of "sound_sub" due to a technical limitation.

*)

Lemma wfenv_no_refl : forall Gamma x, WFEnv Gamma -> not (List.In (x, TyDis (PFVarT x)) Gamma).
Proof.
  intros.
  induction H.
  - auto.
  - unfold not, extend; simpl in *; intros.
    destruct H2.
    inversion H2; subst.
    apply H0; simpl.
    now apply MSetProperties.Dec.F.singleton_2.
    contradiction.
  - unfold not, extend; simpl; intros [a | b]; apply IHWFEnv.
    inversion a. auto.
Qed.

Lemma wfenv_no_var_sub :
  forall Gamma x A, WFEnv Gamma -> Sub A (PFVarT x) -> not (List.In (x, TyDis A) Gamma).
Proof.
  intros.
  induction H.
  - auto.
  - unfold not, extend; simpl in *; intros.
    destruct H3.
    inversion H3; subst.
    inversion H0.
    clear IHWFEnv H2 H0 H.
    dependent induction H4.
    + simpl in *; apply IHsub; not_in_L x.
    + simpl in *; apply IHsub; not_in_L x.
    + apply H1; simpl; now apply MSetProperties.Dec.F.singleton_2.
    + contradiction.
  - unfold not, extend; simpl; intros [a | b]; apply IHWFEnv.
    inversion a. auto.
Qed.

Inductive TopLike : PTyp -> Prop :=
  | TLTop : TopLike Top
  | TLAnd : forall t1 t2, TopLike t1 -> TopLike t2 -> TopLike (And t1 t2)
  | TLFun : forall t1 t2, TopLike t2 -> TopLike (Fun t1 t2)
  | TLForAll : forall L d t,
                 (forall x, not (In x L) -> TopLike (open_typ_source t (PFVarT x))) ->
                 TopLike (ForAll d t)
  | TLRec : forall l t, TopLike t -> TopLike (Rec l t).

Hint Constructors TopLike.

Lemma toplike_subst :
  forall t u z, PType u -> TopLike t -> TopLike (subst_typ_source z u t).
Proof.
  intros t u z HTypu HBLt.
  induction HBLt; intros; simpl in *; auto.
  (* TLForAll *)
  apply_fresh TLForAll as x.
  rewrite subst_typ_source_open_source_var; auto.
  apply H0.
  not_in_L x.
  not_in_L x.
Qed.

Lemma fresh_top :
  forall t x, ~(In x (fv_ptyp t)) -> TopLike (open_typ_source t (PFVarT x)) ->
         forall y, ~(In y (fv_ptyp t)) -> TopLike (open_typ_source t (PFVarT y)).
Proof.
  intros.
  destruct (VarTyp.eq_dec x y).
  - subst; auto.
  - rewrite subst_typ_source_intro with (x := x); auto.
    apply toplike_subst; auto.
Qed.

Lemma toplike_dec : forall t, PType t -> (TopLike t) \/ (not (TopLike t)).
Proof.
  intros t Ht.
  induction Ht; intros.
  - right; unfold not; intros HInv; inversion HInv.
  - right; unfold not; intros HInv; inversion HInv.
  - inversion IHHt2; auto.
    right; unfold not; intros HInv; inversion HInv; subst.
    contradiction.
  - destruct IHHt1; destruct IHHt2; subst; auto.
    right. unfold not. intros. inversion H1; subst. contradiction.
    right. unfold not. intros. inversion H1; subst. contradiction.
    right. unfold not. intros. inversion H1; subst. contradiction.
  - (* right; unfold not; intros HInv; inversion HInv. *)
    pick_fresh x.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha.
    destruct Ha.
    left; apply_fresh TLForAll as y.
    apply fresh_top with (x := x); auto.
    not_in_L x.
    not_in_L y.
    right; unfold not; intros HInv; inversion HInv; subst.
    apply H1.
    pick_fresh y.
    assert (Ha : ~ In y L0) by not_in_L y.
    apply H3 in Ha.
    apply fresh_top with (x := y); auto.
    not_in_L y.
    not_in_L x.
  - left; apply TLTop.
  - destruct IHHt; subst; auto.
    right. unfold not. intros H1. inversion H1; subst. contradiction.
Qed.

Lemma wf_weaken_sub :
  forall E G x t d1 d2, ~ In x (fv_ptyp d2) ->
                   WFTyp (E ++ extend x (TyDis d1) G) t ->
                   usub d2 d1 ->
                   WFTyp (E ++ extend x (TyDis d2) G) t.
Proof.
  intros E G x t d1 d2 HNotIn HWFTyp Husub.
  remember (E ++ extend x (TyDis d1) G) as Gamma.
  generalize dependent HeqGamma.
  generalize dependent E.
  induction HWFTyp; intros; subst; eauto.
  - apply WFInt.
    apply wfenv_app_comm; apply wfenv_app_comm in H.
    unfold extend in *; rewrite <- app_assoc; rewrite <- app_assoc in H.
    inversion H; subst; apply WFPushV; auto.
  - apply WFAnd; auto.
    apply ortho_weaken_sub with (d1 := d1); auto.
    apply wf_gives_wfenv in HWFTyp1.
    apply wfenv_app_comm in HWFTyp1.
    unfold extend in HWFTyp1; rewrite <- app_assoc in HWFTyp1.
    inversion HWFTyp1; subst.
    not_in_L x.
  - apply wfenv_app_comm in H0.
    unfold extend in H0; rewrite <- app_assoc in H0.
    inversion H0; subst.
    destruct (VarTyp.eq_dec x x0); subst.
    assert (Ha : ty = d1).
    apply in_app_or in H.
    destruct H.
    apply list_impl_m in H.
    not_in_L x0.
    apply in_app_or in H.
    destruct H.
    inversion H; now inversion H1.
    apply list_impl_m in H.
    not_in_L x0.
    subst.
    apply WFVar with (ty := d2); auto.
    apply in_or_app.
    right.
    now left.
    apply wfenv_app_comm; unfold extend; rewrite <- app_assoc.
    apply WFPushV; auto.
    apply WFVar with (ty := ty); auto.
    apply in_app_or in H.
    destruct H; auto.
    apply in_app_or in H.
    destruct H.
    simpl in H; destruct H.
    inversion H; subst; exfalso; now apply n.
    inversion H.
    apply in_or_app; right.
    apply in_or_app; auto.
    apply wfenv_app_comm; unfold extend; rewrite <- app_assoc.
    apply WFPushV; auto.
  - apply_fresh WFForAll as x.
    change (extend y (TyDis d) (E ++ extend x (TyDis d2) G)) with
           ((extend y (TyDis d) E) ++ extend x (TyDis d2) G).
    apply H0; auto.
    not_in_L y.
    apply IHHWFTyp; auto.
  - apply WFTop.
    apply wfenv_app_comm in H; unfold extend in H; rewrite <- app_assoc in H.
    apply wfenv_app_comm; unfold extend; rewrite <- app_assoc.
    inversion H; subst.
    apply WFPushV; auto.
Qed.

Lemma wf_weaken_sub_extend :
  forall Gamma x d1 d2 t, ~ In x (fv_ptyp d2) ->
                 WFTyp (extend x (TyDis d1) Gamma) t ->
                 usub d2 d1 ->
                 WFTyp (extend x (TyDis d2) Gamma) t.
Proof.
  intros.
  change (extend x (TyDis d2) Gamma) with (nil ++ (extend x (TyDis d2) Gamma)).
  apply wf_weaken_sub with (d1 := d1); auto.
Qed.

Lemma wf_weaken_sub_andl :
  forall Gamma x d1 d2 t, ~ In x (fv_ptyp d2) ->
                 PType (And d1 d2) ->
                 WFTyp (extend x (TyDis d1) Gamma) t ->
                 WFTyp (extend x (TyDis (And d1 d2)) Gamma) t.
Proof.
  intros.
  apply wf_weaken_sub_extend with (d1 := d1); auto.
  apply wf_gives_wfenv in H1; inversion H1; subst.
  simpl; not_in_L x.
  inversion H0; subst.
  apply USAnd2.
  apply usub_refl.
  auto.
  auto.
Qed.

Lemma wf_weaken_sub_andr :
  forall Gamma x d1 d2 t, ~ In x (fv_ptyp d1) ->
                 PType (And d1 d2) ->
                 WFTyp (extend x (TyDis d2) Gamma) t ->
                 WFTyp (extend x (TyDis (And d1 d2)) Gamma) t.
Proof.
  intros.
  apply wf_weaken_sub_extend with (d1 := d2); auto.
  apply wf_gives_wfenv in H1; inversion H1; subst.
  simpl; not_in_L x.
  inversion H0; subst.
  apply USAnd3.
  apply usub_refl.
  auto.
  auto.
Qed.

Hint Resolve ortho_and_l ortho_and_r Ortho_sym.

Lemma ortho_no_sub :
  forall Gamma A B, WFTyp Gamma A -> WFTyp Gamma B -> Ortho Gamma A B -> ~ TopLike B -> not (Sub A B).
Proof.
  intros Gamma A B WFA WFB HOrtho HNotTL HSub.

  inversion HSub.
  generalize dependent Gamma.
  induction H; intros.
  - inversion HOrtho; subst. destruct H as [a [b c]]; now apply c.
  - inversion HOrtho; subst.
    inversion WFA; inversion WFB; subst.
    apply IHsub2 with (Gamma := Gamma); auto.
    inversion HSub. inversion H1; subst.
    eexists; apply H13.
    destruct H1 as [a [b c]]; now apply c.
  - inversion WFB; subst.
    assert (Ha : ~ TopLike t1 \/ ~ TopLike t2).
    apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; auto.
    destruct Ha.
    apply IHsub1 with (Gamma := Gamma); auto.
    eexists; apply H.
    eauto.
    apply IHsub2 with (Gamma := Gamma); eauto.
    eexists; apply H0.
  - inversion WFA; subst; apply IHsub with (Gamma := Gamma); auto.
    eexists; apply H.
    apply ortho_and_l with (t2 := t2); auto.
  - inversion WFA; subst; apply IHsub with (Gamma := Gamma); auto.
    eexists; apply H.
    apply ortho_and_r with (t1 := t1); auto.
  - inversion HOrtho; subst.
    apply wfenv_no_var_sub with (Gamma := Gamma) (A := A) (x := v); auto.
    now apply wf_gives_wfenv in WFA.
    now apply sound_sub.
    apply wfenv_no_var_sub with (Gamma := Gamma) (A := A) (x := v); auto.
    now apply wf_gives_wfenv in WFA.
    now apply sound_sub.
    destruct H as [a [b c]]; now apply c.
  - inversion WFA; inversion WFB; subst.
    inversion HSub.
    inversion H2; subst.
    inversion HOrtho; subst.
    pick_fresh x.
    eapply H0 with (x := x).
    not_in_L x.
    unfold not; intros HH; apply HNotTL.
    apply_fresh TLForAll as y.
    apply fresh_top with (x := x).
    not_in_L x.
    assumption.
    not_in_L y.
    eexists; apply H12.
    not_in_L x.
    Focus 3.
    apply H9.
    not_in_L x.
    apply wf_weaken_sub_andl.
    not_in_L x.
    auto.
    apply H5.
    not_in_L x.
    apply wf_weaken_sub_andr.
    not_in_L x.
    auto.
    apply H10.
    not_in_L x.
    destruct H3 as [a [b HH]]; now apply HH.
  - auto.
  - inversion HOrtho; subst.
    now apply H2.
    inversion WFA; inversion WFB; subst.
    eapply IHsub; eauto.
    unfold Sub; eauto.
    destruct H0 as [a [b c']]; now apply c'.
Qed.

Lemma usub_top : forall D, usub Top D -> TopLike D.
  intros. dependent induction H. apply TLAnd; auto. apply TLTop.
Defined.

(* Unique subtype contributor: Lemma 2 *)

Lemma uniquesub :
  forall Gamma A B C, WFTyp Gamma A -> WFTyp Gamma B -> ~ TopLike C ->
             Ortho Gamma A B -> Sub (And A B) C -> not (Sub A C /\ Sub B C).
Proof.
  intros Gamma A B C WFA WFB HNotTL HOrtho HSubAnd.
  unfold not; intros [HSubA HSubB].
  generalize dependent C.
  dependent induction HOrtho; intros.
  - induction C;
    try now inversion WFA;
    inversion HSubA; inversion H5; subst; [ eapply IHHOrtho1 | eapply IHHOrtho2 ];
    eauto; unfold Sub; eauto.
    + inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; auto; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; auto; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      inversion H2.
      inversion H2.
      inversion H3.
      inversion H3.
    + now apply HNotTL.
  - induction C;
    try now inversion WFB; subst;
    inversion HSubB; inversion H; subst; [ eapply IHHOrtho1 | eapply IHHOrtho2 ];
    eauto; unfold Sub; eauto.
    + inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; auto; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; auto; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      inversion H6.
      inversion H6.
      inversion H1.
      inversion H1.
    + now apply HNotTL.
  - induction C; try (now (inversion HSubA as [x HInv]; inversion HInv)).
    + inversion WFA; subst; inversion WFB; subst.
      inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      assert (Ha : ~ TopLike C2) by (unfold not; auto).
      eapply IHHOrtho; auto; [ apply Ha
                             | apply sand2; unfold Sub; eauto
                             | unfold Sub; eauto
                             | unfold Sub; eauto ].
    + assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      inversion WFA; subst; inversion WFB; subst.
      inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      destruct Ha.
      apply IHC1; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
    + now apply HNotTL.
  - induction C; try (now (inversion HSubA as [x HInv]; inversion HInv)).
    + inversion HSubA; inversion H2; subst.
      inversion HSubB; inversion H3; subst.
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
    + inversion HSubA; inversion H2; subst.
      inversion HSubB; inversion H3; subst.
      inversion WFA; inversion WFB; subst.
      pick_fresh x.
      clear IHC1; clear IHC2; clear HSubAnd.
      eapply H0 with (x := x) (C := open_typ_source C2 (PFVarT x)).
      not_in_L x; apply H7.
      apply wf_weaken_sub_andl.
      not_in_L x.
      auto.
      apply H7; not_in_L x.
      apply wf_weaken_sub_andr.
      not_in_L x.
      auto.
      apply H16; not_in_L x.
      unfold not; intros; apply HNotTL.
      apply_fresh TLForAll as y.
      apply fresh_top with (x := x); auto.
      not_in_L x.
      not_in_L y.
      apply sand2.
      eexists; apply H8.
      not_in_L x.
      apply wf_gives_types_source with (Gamma := (extend x (TyDis d2) Gamma)).
      apply H16; not_in_L x.
      eexists; apply H8; not_in_L x.
      eexists; apply H11; not_in_L x.
    + now apply HNotTL.
  - induction C; try (now (inversion HSubA as [z HInv]; inversion HInv)).
    + destruct HSubA as [c HsubA]; inversion HsubA; subst.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      inversion H3.
      inversion H3.
    + clear HSubAnd.
      destruct HSubA as [c HsubA]; inversion HsubA; subst.
      assert (Ha : Ortho Gamma ty (PFVarT v)).
      apply OVarSym with (A := A); auto.
      apply ortho_no_sub in Ha.
      contradiction.
      auto.
      auto.
      unfold not; intros HInv; inversion HInv.
    + now apply HNotTL.
  (* same as above (var_sym) *)
  - induction C; try (now (inversion HSubB as [z HInv]; inversion HInv)).
    + destruct HSubA as [c HsubA]; inversion HsubA; subst.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      inversion H3.
      inversion H3.
    + clear HSubAnd.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      assert (Ha : Ortho Gamma ty (PFVarT v)).
      apply OVarSym with (A := A); auto.
      apply ortho_no_sub in Ha.
      contradiction.
      auto.
      auto.
      unfold not; intros HInv; inversion HInv.
    + now apply HNotTL.
  - apply complete_sub in HSubA; apply usub_top in HSubA; contradiction.
  - apply complete_sub in HSubB; apply usub_top in HSubB; contradiction.
  - induction C; try (now (inversion HSubA as [z HInv]; inversion HInv)).
    + destruct HSubA as [c HsubA]; inversion HsubA; subst.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
    + now apply HNotTL.
    + destruct HSubA as [c HsubA]; inversion HsubA; subst.
      destruct HSubB as [c' HsubB]; inversion HsubB; subst.
      now apply H.
  - induction C; try (now (inversion HSubA as [z HInv]; inversion HInv)).
    + destruct HSubA as [c HsubA]; inversion HsubA; subst.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
    + now apply HNotTL.
    + inversion WFA; inversion WFB; subst.
      inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      assert (Ha : ~ TopLike C) by (unfold not; auto).
      eapply IHHOrtho; auto; [ unfold not; apply Ha
                             | apply sand2; unfold Sub; eauto
                             | unfold Sub; eauto
                             | unfold Sub; eauto ].
  - destruct H as [ PTypHd1 [ PTypHd2 PTypHd3 ]].
    induction C.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
      inversion HSubB as [x HsB]; inversion HsB; subst; try orthoax_inv PTypHd2.
      apply PTypHd3; auto.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
      inversion HSubB as [x HsB]; inversion HsB; subst; try orthoax_inv PTypHd2.
      apply PTypHd3; auto.
    + inversion HSubA as [x HInv1]; inversion HInv1; subst; try (now inversion H0).
      inversion HSubB as [x HInv2]; inversion HInv2; subst; try (now inversion H0).
      assert (Ha : ~ TopLike C1 \/ ~ TopLike C2).
      apply Classical_Prop.not_and_or; unfold not; intros HH; destruct HH; eauto.
      destruct Ha.
      apply IHC1; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
      apply IHC2; unfold Sub; eauto.
      apply sand2; unfold Sub; eauto.
    + inversion HSubA as [x HsA]; inversion HsA; subst; inversion H0.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
      inversion HSubB as [x HsB]; inversion HsB; subst; try orthoax_inv PTypHd2.
      apply PTypHd3; auto.
    + now apply HNotTL.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
      inversion HSubB as [x' HsB]; inversion HsB; subst; try orthoax_inv PTypHd2.
      apply PTypHd3; auto.
Qed.

(* and_coercion (toplike cases) lemmas *)

Lemma and_coercion_inl :
  forall {t e},
    PType t ->
    TopLike t ->
    exists r, and_coercion e t (inl r).
Proof.
  intros.
  induction H0.
  - exists (STUnit _); auto.
  - inversion H; subst; destruct IHTopLike1, IHTopLike2; eauto.
  - inversion H; subst.
    apply IHTopLike in H4.
    inversion H4.
    exists (STLam _ x).
    auto.
  - inversion H; subst.
    apply ac_ptype with (e := e) in H.
    destruct H.
    inversion H; subst.
    eauto.
    pick_fresh x.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H1 in Ha.
    destruct Ha.
    assert (Ha1 : ~ In x L1) by not_in_L x.
    apply H7 in Ha1.
    assert (HaInv : inl x0 = inr e).
    eapply same_coercion with (A := (open_typ_source t0 (PFVarT x))).
    apply H5; not_in_L x.
    apply H2.
    apply Ha1.
    inversion HaInv.
    apply H5; not_in_L x.
  - inversion H; subst; destruct IHTopLike; eauto.
Qed.

Ltac wftyp_to_ok :=
  match goal with
    | H: WFTyp ?Gamma _ |- ok (∥ ?Gamma ∥) => apply ok_map;
        apply wf_gives_wfenv in H; now apply wfenv_to_ok in H
  end.

Ltac env_resolve := (try now auto; now wftyp_to_ok); try now WFTyp_to_WFType.

Lemma and_coercion_inl_typing :
  forall {t e Gamma r},
    TopLike t ->
    and_coercion e t (inl r) ->
    WFTyp Gamma t ->
    has_type_st (∥ Gamma ∥) r (|t|).
Proof.
  intros.
  generalize dependent Gamma.
  dependent induction H0; intros; try (now simpl; eauto).
  - simpl; inversion H; inversion H1; subst.
    apply_fresh STTyLam as x.
    apply (IHand_coercion H3) in H9.
    unfold open.
    rewrite <- open_rec_term.
    apply typing_weaken_extend; auto.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    now apply ac_inl_term in H0.
    env_resolve.
  - inversion H; inversion H1; subst; simpl; auto.
  - inversion H; inversion H2; subst; simpl.
    apply_fresh STTyTLam as x.
    unfold open_typ_source in H0.
    assert (Ha : has_type_st (∥ (extend x (TyDis d) Gamma) ∥) e1 (| open_rec_typ_source 0 (PFVarT x) A |)).
    apply H0.
    not_in_L x.
    apply H4.
    not_in_L x.
    apply H9.
    not_in_L x.
    rewrite open_rec_typ_eq_source in Ha.
    simpl in Ha; unfold extend; unfold open_typ; simpl.
    unfold open_typ_term; rewrite <- open_rec_typ_term_term; auto.
    assert (Ha1 : ~ In x L) by not_in_L x.
    apply H1 in Ha1.
    now apply ac_inl_term in Ha1.
  - inversion H; inversion H1; subst; simpl; auto.
Qed.

Lemma and_coercion_inr :
  forall {t} e,
    PType t ->
    not (TopLike t) ->
    and_coercion e t (inr e).
Proof.
  intros.
  generalize dependent e.
  induction H; try simpl; auto.
  - intros; auto 10.
  - intros.
    assert (Ha : ~ TopLike t1 \/ ~ TopLike t2) by
        (apply Classical_Prop.not_and_or; unfold not; intros; apply H0; now apply TLAnd).
    destruct Ha; eauto.
  - intros.
    apply ACForAllR with (L := union L (fv_ptyp t0)).
    intros.
    apply H2.
    not_in_L x.
    unfold not; intros; apply H0.
    apply_fresh TLForAll as x.
    apply fresh_top with (x := x); auto.
    not_in_L x.
    not_in_L y.
  - intros; exfalso; apply H0; apply TLTop.
  - intros; auto 10.
Qed.

Lemma change_coercion_toplike :
  forall A e1 e2 c, TopLike A -> and_coercion e1 A c -> and_coercion e2 A c.
Proof.
  intros A e1 e2 c HTL HAC.
  generalize dependent e2.
  induction HAC; intros; try now inversion HTL.
  - inversion HTL; subst; auto.
  - inversion HTL; subst.
    apply IHHAC with (e2 := e2) in H0.
    apply ac_inr_inv_eq in H0.
    subst; auto.
  - inversion HTL; subst.
    apply IHHAC1 with (e2 := e3) in H1.
    apply IHHAC2 with (e3 := e3) in H2.
    auto.
  - inversion HTL; subst.
    apply IHHAC with (e2 := e2) in H1.
    apply ac_inr_inv_eq in H1.
    subst; auto.
  - inversion HTL; subst.
    apply IHHAC with (e2 := e2) in H2.
    apply ac_inr_inv_eq in H2.
    subst; auto.
  - inversion HTL; subst.
    eapply ACForAllL with (L := union L L0).
    intros x HNotIn.
    apply H0.
    not_in_L x.
    apply H2.
    not_in_L x.
  - inversion HTL; subst.
    pick_fresh x.
    assert (Ha : ~ In x L) by not_in_L x.
    assert (Ha1 : ~ In x L0) by not_in_L x.
    apply H2 in Ha1.
    apply (H0 _ Ha) with (e2 := e2) in Ha1.
    apply ac_inr_inv_eq in Ha1; subst.
    eapply ACForAllR with (L := union L L0).
    intros y H3.
    apply H0.
    not_in_L y.
    apply H2.
    not_in_L y.
  - inversion HTL; subst.
    apply IHHAC with (e2 := e2) in H0.
    auto.
Qed.

(* Coercive subtyping is coeherent: Lemma 3 *)

Lemma sub_coherent :
  forall {A Gamma}, WFTyp Gamma A ->
           forall {B}, WFTyp Gamma B ->
                  forall {C1}, sub A B C1 ->
                          forall {C2}, sub A B C2 -> C1 = C2.
Proof.
  intros.
  generalize dependent C2.
  generalize dependent Gamma.
  (* Case: Int <: Int *)
  induction H1; intros.
  - inversion H2.
    reflexivity.
  (* Case: Fun t1 t2 <: Fun t3 t4 *)
  - inversion H. inversion H0. inversion H2.
    assert (c2 = c3). apply IHsub2 with (Gamma := Gamma); auto.
    assert (c1 = c0). apply IHsub1 with (Gamma := Gamma); auto.
    now subst.
  (* Case: t <: And t1 t2 *)
  - inversion H2; inversion H0; subst.
    assert (c1 = c0) by (apply IHsub1 with (Gamma := Gamma); auto).
    assert (c2 = c3) by (apply IHsub2 with (Gamma := Gamma); auto).
    now subst.
    now subst.
    now subst.
  (* Case: And t1 t2 <: t (first) *)
  - inversion H3; subst.
    inversion H5; subst.
    + inversion H.
    + assert (c = c0). apply IHsub with (Gamma := Gamma); auto.
      subst.
      assert (ac0 = ac).
      eapply same_coercion with (A := t0).
      now apply wf_gives_types_source with (Gamma := Gamma).
      apply H16. apply H2.
      now subst.
    + destruct (toplike_dec t0).
      now apply wf_gives_types_source with (Gamma := Gamma).
      apply change_coercion_toplike with
      (e2 := (STApp var c (STProj1 var (STBVar var 0)))) in H16; auto.
      repeat apply f_equal.
      rewrite same_coercion with (e := (STApp var c (STProj1 var (STBVar var 0))))
                                   (c2 := ac) (A := t0); auto.
      now apply wf_gives_types_source with (Gamma := Gamma).
      assert (HSub : Sub (And t1 t2) t0) by (apply sand2; unfold Sub; eauto).
      assert (Ha := uniquesub _ t1 t2 t0 H8 H10 H6 H11 HSub).
      exfalso; apply Ha.
      split; unfold Sub; eauto.
    + inversion H.
  - inversion H3; subst.
    inversion H5; subst.
    + inversion H.
    + destruct (toplike_dec t0).
      now apply wf_gives_types_source with (Gamma := Gamma).
      apply change_coercion_toplike with
      (e2 := (STApp var c (STProj2 var (STBVar var 0)))) in H16; auto.
      repeat apply f_equal.
      rewrite same_coercion with (e := (STApp var c (STProj2 var (STBVar var 0))))
                                   (c2 := ac) (A := t0); auto.
      now apply wf_gives_types_source with (Gamma := Gamma).
      assert (HSub : Sub (And t1 t2) t0) by (apply sand2; unfold Sub; eauto).
      assert (Ha := uniquesub _ t1 t2 t0 H8 H10 H6 H11 HSub).
      exfalso; apply Ha.
      split; unfold Sub; eauto.
    + assert (c = c0). apply IHsub with (Gamma := Gamma); auto.
      subst.
      assert (ac0 = ac).
      eapply same_coercion with (A := t0).
      now apply wf_gives_types_source with (Gamma := Gamma).
      apply H16. apply H2.
      now subst.
    + inversion H.
  - now inversion H2.
  - inversion H2; subst.
    inversion H3; subst.
    inversion H4; subst.
    pick_fresh x.
    assert (Ha : (open_typ_term c (STFVarT x)) = (open_typ_term c0 (STFVarT x))).
    assert (ty := Top).
    eapply H0 with (Gamma := extend x (TyDis (And d1 d2)) Gamma).
    not_in_L x.
    apply wf_weaken_sub_andl.
    not_in_L x.
    assert (Ha : Sub d2 d1) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha; auto.
    apply H8.
    not_in_L x.
    apply wf_weaken_sub_andr.
    not_in_L x.
    assert (Ha : Sub d2 d1) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha; auto.
    apply H10.
    not_in_L x.
    apply H14.
    not_in_L x.
    assert (c = c0).
    eapply open_typ_term_app_eq with (x := x) (n := 0).
    not_in_L x.
    not_in_L x.
    apply Ha.
    now subst.
  - inversion H2.
    inversion H4.
    inversion H4.
    now subst.
  - inversion H; inversion H0; inversion H2; subst.
    erewrite IHsub; eauto.
Qed.

(*
End ExtendedSub.

Module Extended
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Require Import Extended_infrastructure.
Module Infrastructure := Infrastructure(VarTyp)(set).
Export Infrastructure.

Module ExtendedSub := ExtendedSub(VarTyp)(set).
Import ExtendedSub.
 *)

(* Typing lemmas *)

Lemma typing_wf_source_alg:
  forall Gamma t T E dir, has_type_source_alg Gamma t dir T E -> WFTyp Gamma T.
Proof.
  intros Gamma t dir T E H.
  induction H; auto.
  - inversion IHhas_type_source_alg1; assumption.
  - inversion IHhas_type_source_alg; subst.
    apply open_body_wf_type with (d := d); auto.
    unfold body_wf_typ; eauto.
  - now inversion IHhas_type_source_alg.
  - apply_fresh WFForAll as x.
    apply H1.
    not_in_L x.
    auto.
  - pick_fresh x.
    assert (Ha : not (M.In x L)) by (not_in_L x).
    apply WFFun.
    assumption.
    apply H0 in Ha.
    rewrite <- app_nil_l with (l := Gamma).
    eapply wf_strengthen_source with (z := x).
    not_in_L x.
    rewrite app_nil_l; apply Ha.
Qed.

Lemma type_correct_alg_terms : forall Gamma E ty e dir, has_type_source_alg Gamma E dir ty e -> PTerm E.
Proof.
  intros.
  induction H; auto.
  - apply PTerm_TApp.
    auto.
    now apply wf_gives_types_source in H.
  - apply_fresh PTerm_TLam as x.
    apply H1; not_in_L x.
  - apply_fresh PTerm_Lam as x; auto.
    apply H0; not_in_L x.
Qed.

Lemma typing_alg_wf_env :
  forall Gamma E dir ty e, has_type_source_alg Gamma E dir ty e -> WFEnv Gamma.
Proof.
  intros.
  induction H; auto.
  - pick_fresh x.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H1 in Ha.
    now inversion Ha.
  - pick_fresh x;
    assert (Ha: not (In x L)) by not_in_L x;
    pose (H0 _ Ha) as HInv;
    inversion HInv; auto.
Qed.

(* TODO move to infrastructure *)
Lemma open_typ_app_eq_source : forall x E n F,
  not (In x (fv_ptyp E)) ->
  not (In x (fv_ptyp F)) ->
  (open_rec_typ_source n (PFVarT x) E) = (open_rec_typ_source n (PFVarT x) F) ->
  E = F.
Proof.
  intros x E.
  induction E; intros n' F HNotE HNotF HEqOpen.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    destruct (Nat.eqb n' n); auto.
    inversion H0.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    rewrite IHE1 with (F := F1) (n := n'); try not_in_L x.
    rewrite IHE2 with (F := F2) (n := n'); try not_in_L x.
    reflexivity.
    simpl; rewrite union_spec; auto.
    auto.
    simpl; rewrite union_spec; auto.
    auto.
    destruct (Nat.eqb n' n); inversion H0.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    rewrite IHE1 with (F := F1) (n := n'); try not_in_L x.
    rewrite IHE2 with (F := F2) (n := n'); try not_in_L x.
    reflexivity.
    simpl; rewrite union_spec; auto.
    auto.
    simpl; rewrite union_spec; auto.
    auto.
    destruct (Nat.eqb n' n); inversion H0.
  - induction F; simpl in *; try (now (destruct (Nat.eqb n' n); inversion HEqOpen)).
    case_eq (Nat.eqb n' n); intros.
    case_eq (Nat.eqb n' n0); intros.
    apply f_equal.
    apply beq_nat_true in H.
    apply beq_nat_true in H0.
    now subst.
    rewrite H in HEqOpen.
    rewrite H0 in HEqOpen.
    inversion HEqOpen.
    rewrite H in HEqOpen.
    case_eq (Nat.eqb n' n0); intros;
    rewrite H0 in HEqOpen; inversion HEqOpen.
    reflexivity.
    destruct (Nat.eqb n' n).
    exfalso; apply HNotF.
    apply MSetProperties.Dec.F.singleton_2; inversion HEqOpen; reflexivity.
    inversion HEqOpen.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    destruct (Nat.eqb n' n).
    inversion H0; subst.
    exfalso; apply HNotE.
    apply MSetProperties.Dec.F.singleton_2; inversion HEqOpen; reflexivity.
    auto.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    destruct (Nat.eqb n' n); inversion H0.
    rewrite IHE1 with (F := F1) (n := n'); try not_in_L x.
    rewrite IHE2 with (F := F2) (n := S n'); try not_in_L x.
    reflexivity.
    simpl; rewrite union_spec; auto.
    auto.
    simpl; rewrite union_spec; auto.
    auto.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    destruct (Nat.eqb n' n); auto.
    inversion H0.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    destruct (Nat.eqb n' n); inversion H0.
    inversion HEqOpen; subst.
    simpl in HNotF.
    rewrite IHE with (F := F) (n := n'); try not_in_L x; auto.
Qed.

(* Ignoring the generated expressions + smart constructors *)

Definition has_ty Gamma e d t := exists E, has_type_source_alg Gamma e d t E.

(* Uniqueness *)

Definition almost_unique (A B : PTyp) (d : Dir) : Prop :=
  match d with
    | Inf => A = B
    | Chk => True (* Is this result useful for checking: exists C, Sub C A /\ Sub C B*)
  end.

Lemma typ_unique : forall Gamma e d t1 E1, has_type_source_alg Gamma e d t1 E1 -> forall t2 E2, has_type_source_alg Gamma e d t2 E2 -> almost_unique t1 t2 d.
intros Gamma e d t1 E1 H.
induction H; intros; unfold almost_unique; auto.
(* case Unit *)
- inversion H0; now subst.
(* case Var *)
- inversion H2; subst.
  assert (Ha : TermV ty = TermV t2).
  erewrite ok_unique_type with (x0 := x).
  reflexivity.
  apply wfenv_to_ok in H4.
  apply H4.
  apply (conj H5 H0).
  decide equality.
  now inversion Ha.
(* case Lit *)
- inversion H0. auto.
(* case App *)
- inversion H1.
  apply IHhas_type_source_alg1 in H5. simpl in H5.
  apply IHhas_type_source_alg2 in H6.
  injection H5. intros. auto.
(* Case Merge *)
- inversion H2.
  apply IHhas_type_source_alg1 in H5.
  apply IHhas_type_source_alg2 in H7.
  rewrite H5. rewrite H7. auto.
(* Case Ann *)
- inversion H0. auto.
(* Case TApp *)
- inversion H2; subst.
  apply IHhas_type_source_alg in H7.
  injection H7; intros.
  now subst.
(* Case Rec *)
- inversion H0; subst; apply IHhas_type_source_alg in H3; simpl in H3.
  now subst.
- inversion H0; subst; apply IHhas_type_source_alg in H3; simpl in H3; now inversion H3.
- inversion H2; subst.
  pick_fresh x.
  assert (Ha1 : ~ In x L) by not_in_L x.
  assert (Ha2 : ~ In x L0) by not_in_L x.
  apply H7 in Ha2.
  apply H1 with (t2 := (open_typ_source A0 (PFVarT x)))
                  (E2 := (open_typ_term E0 (STFVarT x))) in Ha1; auto.
  unfold almost_unique in Ha1.
  apply f_equal.
  rewrite open_typ_app_eq_source with (E := A) (F := A0) (n := 0) (x := x); auto;
  not_in_L x.
Qed.

(* Theorem 5. Type inference always gives unique types *)

Lemma typ_inf_unique : forall {Gamma e t1 t2 E1 E2}, has_type_source_alg Gamma e Inf t1 E1 -> has_type_source_alg Gamma e Inf t2 E2 -> t1 = t2.
intros.
pose (@typ_unique _ _ _ _ _ H _ _ H0). simpl in a. auto.
Qed.

(* Theorem 6. *)
Lemma typ_coherence : forall Gamma e d t E1, has_type_source_alg Gamma e d t E1 -> forall E2, has_type_source_alg Gamma e d t E2 -> E1 = E2.
intros Gamma e d t E1 H.
induction H; intros.
(* case Unit *)
- inversion H0; reflexivity.
(* case PFVar *)
- inversion H2; reflexivity.
(* case STLit *)
- inversion H0; reflexivity.
(* Case App *)
- inversion H1.
  assert (Fun A B = Fun A0 B).
  apply (typ_inf_unique H H5). injection H9. intros.
  rewrite <- H9 in H5. rewrite <- H10 in H6.
  apply IHhas_type_source_alg1 in H5.
  apply IHhas_type_source_alg2 in H6.
  rewrite H5. rewrite H6. auto.
(* Case Merge *)
- inversion H2.
  apply IHhas_type_source_alg1 in H8.
  apply IHhas_type_source_alg2 in H9.
  rewrite H8. rewrite H9. auto.
(* Case Ann *)
- inversion H0.
  apply IHhas_type_source_alg in H3. auto.
(* Case TApp *)
- inversion H2; subst.
  assert (Ha : ForAll d ty = ForAll d0 ty0).
  eapply typ_inf_unique.
  apply H0.
  apply H8.
  rewrite <- Ha in H8.
  apply IHhas_type_source_alg in H8.
  now subst.
(* Case Rec *)
- inversion H0; subst; now apply IHhas_type_source_alg in H5.
(* Case ProjR *)
- inversion H0; subst; now apply IHhas_type_source_alg in H3.
(* Case TLam *)
- inversion H2; subst.
  apply f_equal.
  pick_fresh x.
  apply open_typ_term_app_eq with (E := E) (F := E0) (x := x) (n := 0).
  not_in_L x.
  not_in_L x.
  apply H1.
  not_in_L x.
  apply H8.
  not_in_L x.
(* Case Lam *)
- inversion H2; subst.
  apply f_equal.
  pick_fresh x.
  assert (Ha1: not (M.In x L0)) by (not_in_L x).
  apply H7 in Ha1.
  apply H0 in Ha1.
  assert (HNotE : not (In x (fv E))) by (not_in_L x).
  assert (HNotF : not (In x (fv E0))) by (not_in_L x).
  apply (open_app_eq _ _ _ _ HNotE HNotF Ha1).
  not_in_L x.
  inversion H3.
(* ATySub *)
- inversion H2.
  subst.
  inversion H.
  assert (A = A0).
  apply (typ_inf_unique H H3).
  subst.
  apply IHhas_type_source_alg in H3.
  subst.
  assert (WFTyp Gamma A0). now apply typing_wf_source_alg in H.
  assert (WFTyp Gamma B). assumption.
  assert (C = C0).
  apply (sub_coherent H3 H6 H0 H4).
  subst; reflexivity.
Qed.

Hint Resolve coercions_produce_terms.

(* Subtyping rules produce type-correct coercions: Lemma 1 *)
Lemma type_correct_coercions :
  forall Gamma A B E, sub A B E ->
             WFEnv Gamma ->
             WFTyp Gamma A ->
             WFTyp Gamma B ->
             has_type_st (∥ Gamma ∥) E (STFun (|A|) (|B|)) .
Proof.
  intros.
  generalize dependent Gamma.
  induction H; intros.
  (* Case SInt *)
  - simpl.
    remember (∥ Gamma ∥).
    apply_fresh STTyLam as x; cbn; auto.
    apply STTyVar; auto.
    apply WFType_Int; auto.
    apply Ok_push; auto.
    subst; auto.
    apply wfenv_to_ok in H0; auto.
    not_in_L x.
    apply Ok_push; auto.
    subst; auto.
    not_in_L x.
    left; simpl; auto.
    apply WFType_Int.
    subst; auto.
  (* Case SFun *)
  - inversion H2; inversion H3.
    subst.
    remember (∥ Gamma ∥).
    apply_fresh STTyLam as x; cbn.
    apply_fresh STTyLam as y; cbn.
    apply STTyApp with (A := (| o2 |)).
    rewrite <- open_rec_term.
    rewrite <- open_rec_term.
    repeat apply typing_weaken_extend.
    subst; apply (IHsub2 _ H1 H8 H13).
    not_in_L x.
    not_in_L y.
    not_in_L x.
    now apply coercions_produce_terms in H0.
    rewrite <- open_rec_term.
    now apply coercions_produce_terms in H0.
    now apply coercions_produce_terms in H0.
    apply STTyApp with (A := (| o1 |)).
    apply STTyVar.
    repeat apply wf_weaken_extend.
    apply WFType_Fun.
    subst; now apply WFTyp_to_WFType.
    subst; now apply WFTyp_to_WFType.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    right; left; auto.
    rewrite <- open_rec_term.
    rewrite <- open_rec_term.
    eapply STTyApp.
    repeat apply typing_weaken_extend.
    subst; apply IHsub1; auto.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    apply STTyVar.
    repeat apply wf_weaken_extend.
    inversion H3.
    subst; now apply WFTyp_to_WFType.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    left; auto.
    now apply coercions_produce_terms in H.
    rewrite <- open_rec_term.
    now apply coercions_produce_terms in H.
    now apply coercions_produce_terms in H.
    apply wf_weaken_extend.
    subst; now apply WFTyp_to_WFType.
    not_in_L x.
    apply WFType_Fun; subst; now apply WFTyp_to_WFType.
  (* Case SAnd1 *)
  - remember (∥ Gamma ∥).
    inversion H3.
    apply_fresh STTyLam as x; cbn.
    apply STTyPair.
    + rewrite <- open_rec_term.
      apply STTyApp with (A := (| t0 |)).
      apply typing_weaken_extend.
      subst; apply IHsub1; auto.
      not_in_L x.
      apply STTyVar.
      apply wf_weaken_extend.
      subst; now apply WFTyp_to_WFType.
      not_in_L x.
      apply Ok_push.
      subst; auto.
      not_in_L x.
      left; auto.
      now apply coercions_produce_terms in H.
    + rewrite <- open_rec_term.
      apply STTyApp with (A := (| t0 |)).
      apply typing_weaken_extend.
      subst; apply IHsub2; auto.
      not_in_L x.
      apply STTyVar.
      apply wf_weaken_extend.
      subst; now apply WFTyp_to_WFType.
      not_in_L x.
      apply Ok_push.
      subst; auto.
      not_in_L x.
      left; auto.
      now apply coercions_produce_terms in H0.
    + subst; now apply WFTyp_to_WFType.
  (* Case SAnd2 *)
  - assert (Ha1 : Sub t1 t0) by (unfold Sub; eauto).
    assert (Ha : PType t0) by (apply sub_lc in Ha1; now destruct Ha1).
    pose (toplike_dec t0 Ha).
    inversion o; clear o.
    change (STFun (| And t1 t2 |) (| t0 |)) with
    (| Fun (And t1 t2) t0 |).
    eapply and_coercion_inl_typing; auto.
    apply ACFunL.
    eapply and_coercion_inl in H6.
    destruct H6.
    assert (Ha2 : ac = inl x).
    eapply same_coercion with (A := t0); auto.
    apply H2. apply H6.
    subst.
    unfold join_sum; simpl.
    apply H6.
    auto.
    apply_fresh STTyLam as x.
    apply and_coercion_inr with (e := (STApp var c (STProj1 var (STBVar var 0)))) in H6.
    assert (Ha2 : ac = (inr (STApp var c (STProj1 var (STBVar var 0))))).
    eapply same_coercion with (A := t0); auto.
    apply H2. apply H6. subst.
    unfold join_sum, open; simpl.
    rewrite <- open_rec_term.
    eapply STTyApp.
    change (extend x (TermVar STyp (STTuple (| t1 |) (| t2 |))) (∥ Gamma ∥)) with
    (∥ extend x (TermV (And t1 t2)) Gamma ∥).
    apply IHsub.
    apply WFPushT; auto; not_in_L x.
    apply wf_weaken_extend_source_termv.
    now inversion H4.
    simpl; not_in_L x.
    apply wf_weaken_extend_source_termv.
    now inversion H4.
    simpl; not_in_L x.
    apply STTyProj1 with (B := (| t2 |)).
    apply STTyVar.
    apply wf_weaken_extend.
    apply WFType_Tuple.
    inversion H4; env_resolve.
    inversion H4; env_resolve.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    apply Ok_push.
    env_resolve.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    left; reflexivity.
    now apply coercions_produce_terms in H.
    auto.
    auto.
  (* Case SAnd3 *)
  - assert (Ha1 : Sub t2 t0) by (unfold Sub; eauto).
    assert (Ha : PType t0) by (apply sub_lc in Ha1; now destruct Ha1).
    pose (toplike_dec t0 Ha).
    inversion o; clear o.
    change (STFun (| And t1 t2 |) (| t0 |)) with
    (| Fun (And t1 t2) t0 |).
    eapply and_coercion_inl_typing; auto.
    apply ACFunL.
    eapply and_coercion_inl in H6.
    destruct H6.
    assert (Ha2 : ac = inl x).
    eapply same_coercion with (A := t0); auto.
    apply H2. apply H6.
    subst.
    unfold join_sum; simpl.
    apply H6.
    auto.
    apply_fresh STTyLam as x.
    apply and_coercion_inr with (e := (STApp var c (STProj2 var (STBVar var 0)))) in H6.
    assert (Ha2 : ac = (inr (STApp var c (STProj2 var (STBVar var 0))))).
    eapply same_coercion with (A := t0); auto.
    apply H2. apply H6. subst.
    unfold join_sum, open; simpl.
    rewrite <- open_rec_term.
    eapply STTyApp.
    change (extend x (TermVar STyp (STTuple (| t1 |) (| t2 |))) (∥ Gamma ∥)) with
    (∥ extend x (TermV (And t1 t2)) Gamma ∥).
    apply IHsub.
    apply WFPushT; auto; not_in_L x.
    apply wf_weaken_extend_source_termv.
    now inversion H4.
    simpl; not_in_L x.
    apply wf_weaken_extend_source_termv.
    now inversion H4.
    simpl; not_in_L x.
    apply STTyProj2 with (A := (| t1 |)).
    apply STTyVar.
    apply wf_weaken_extend.
    apply WFType_Tuple.
    inversion H4; env_resolve.
    inversion H4; env_resolve.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    apply Ok_push.
    env_resolve.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    left; reflexivity.
    now apply coercions_produce_terms in H.
    auto.
    auto.
  - remember (∥ Gamma ∥).
    apply_fresh STTyLam as x.
    unfold open; simpl.
    apply STTyVar.
    apply wf_weaken_extend.
    subst; now apply WFTyp_to_WFType in H1.
    not_in_L x.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    left; auto.
    subst; now apply WFTyp_to_WFType in H1.
  (* ForAll *)
  - inversion H3.
    inversion H4.
    apply_fresh STTyLam as x.
    unfold open; simpl.
    apply_fresh STTyTLam as y.
    unfold open_typ_term; simpl.
    apply STTyApp with (A := (open_typ (| t1 |) (STFVarT y))).
    rewrite open_comm_open_typ_term.
    rewrite <- open_rec_term.
    unfold open_typ; simpl.
    unfold open_typ_source in H0; simpl in H0.
    change (extend y (TyVar STyp)
                   (extend x (TermVar STyp (STForAll (| t1 |))) (∥ Gamma ∥))) with
    (∥ (extend y (TyDis (And d1 d2))
               (extend x (TermV (ForAll d t1)) Gamma)) ∥).
    change (STFVarT y) with (| PFVarT y |).
    rewrite <- open_rec_typ_eq_source.
    rewrite <- open_rec_typ_eq_source.
    apply H0.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    simpl.
    not_in_L y.
    simpl.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.add_iff in HH.
    destruct HH; subst.
    not_in_L y.
    exfalso; apply H27; now apply MSetProperties.Dec.F.singleton_2.
    not_in_L y.
    unfold extend.
    apply wf_weaken_source.
    subst.
    apply wf_weaken_sub_andl.
    not_in_L y.
    assert (Ha : Sub d2 d1) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha; auto.
    apply H8.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    simpl.
    not_in_L y.
    simpl.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.add_iff in HH.
    destruct HH; subst.
    not_in_L y.
    exfalso; apply H27; now apply MSetProperties.Dec.F.singleton_2.
    not_in_L y.
    apply wf_weaken_source.
    subst.
    apply wf_weaken_sub_andr.
    not_in_L y.
    assert (Ha : Sub d2 d1) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha; auto.
    apply H13.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    simpl.
    not_in_L y.
    not_in_L y.
    not_in_L x.
    assert (Ha : not (In y L)) by not_in_L y.
    apply H in Ha.
    now apply coercions_produce_terms in Ha.
    apply STTyTApp.
    apply WFType_Var.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    unfold conv_context; rewrite <- dom_map_id.
    not_in_L x.
    unfold extend; not_in_L y.
    not_in_L x.
    subst; unfold conv_context in H17; rewrite <- dom_map_id in H17; contradiction.
    left; auto.
    apply STTyVar.
    repeat apply wf_weaken_extend.
    change (STForAll (| t1 |)) with (| ForAll d1 t1 |).
    env_resolve.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    unfold extend; not_in_L y.
    not_in_L x.
    subst; unfold conv_context in H17; rewrite <- dom_map_id in H17; contradiction.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    unfold extend; not_in_L y.
    not_in_L x.
    subst; unfold conv_context in H17; rewrite <- dom_map_id in H17; contradiction.
    right; left; auto.
    subst.
    env_resolve.
  - apply_fresh STTyLam as x.
    unfold open; simpl.
    apply STTyUnit.
    apply Ok_push.
    env_resolve.
    unfold conv_context; rewrite <- dom_map_id; not_in_L x.
    env_resolve.
  - simpl; inversion H1; inversion H2; subst; apply IHsub; auto.
Qed.

(* Type preservation: Theorem 1 *)
Lemma type_preservation :
  forall x ty dir E (Gamma : context TyEnvSource) (H : has_type_source_alg Gamma x dir ty E),
  has_type_st (∥ Gamma ∥) E (|ty|).
Proof.
  intros.
  induction H; subst; auto.
  (* TyVar *)
  - apply STTyVar.
    now apply WFTyp_to_WFType.
    auto.
    now apply in_persists in H0.
  (* TyApp *)
  - simpl in *.
    apply STTyApp with (A := |A|).
    assumption.
    assumption.
  (* TyMerge *)
  - simpl; apply STTyPair; assumption.
  (* TyTApp *)
  - simpl in *.
    unfold open_typ_source; rewrite open_rec_typ_eq_source.
    apply STTyTApp.
    now apply WFTyp_to_WFType.
    apply IHhas_type_source_alg.
  (* ATyTLam *)
  - simpl; apply_fresh STTyTLam as x.
    simpl in *.
    unfold open_typ.
    change (STFVarT x) with (| PFVarT x |).
    rewrite <- open_rec_typ_eq_source.
    apply H1.
    not_in_L x.
  (* TyLam *)
  - simpl.
    apply_fresh STTyLam as x.
    unfold open; simpl.
    assert (Ha : not (M.In x L)).
    not_in_L x.
    apply H0 in Ha.
    simpl in *.
    unfold extend.
    simpl.
    apply Ha.
    now apply WFTyp_to_WFType.
  (* ATySub *)
  - apply STTyApp with (|A|).
    apply type_correct_coercions.
    assumption.
    now apply typing_alg_wf_env in H.
    now apply typing_wf_source_alg in H.
    assumption.
    assumption.
Qed.

End MExtended.


Require Export CatSem.CAT.category.
Require Export CatSem.CAT.functor.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section coprod.

Variable obC: Type.
Variable morC: obC -> obC -> Type.

Class Cat_Coprod (C:Cat_struct morC) := {
   coprod : obC -> obC -> obC;
   inl: forall a b, morC a (coprod a b);
   inr: forall a b, morC b (coprod a b);
   coprod_mor: forall (a b d:obC) (f: morC a d)(g: morC b d),
         morC (coprod a b) d ;
   coprod_mor_oid:> forall a c d,
       Proper (equiv ==> equiv ==> equiv) (@coprod_mor a c d);
   coprod_diag: forall (a b d: obC) (f:morC a d)(g:morC b d),
              inl a b ;; (coprod_mor f g) == f /\
              inr a b ;; (coprod_mor f g) == g;
   coprod_mor_unique: forall (a b d:obC)
            (f:morC a d) (g:morC b d) (h':morC (coprod a b) d),
       inl a b ;; h' == f /\ inr a b ;; h' == g  ->
                 h'== coprod_mor f g
}.

Lemma inl_coprod (C:Cat_struct morC)(H:Cat_Coprod C): forall (a b d: obC)
       (f: morC a d) (g: morC b d),
           inl a b ;; (coprod_mor f g) == f.
Proof.
  intros;
  apply coprod_diag.
Qed.

Lemma inr_coprod (C:Cat_struct morC)(H:Cat_Coprod C): forall (a b d: obC)
       (f: morC a d) (g: morC b d),
           inr a b ;; (coprod_mor f g) == g.
Proof.
  intros;
  apply coprod_diag.
Qed.

End coprod.

Hint Rewrite inl_coprod inr_coprod : cat.
Hint Resolve inl_coprod inr_coprod : cat.

Section coprod_arrow.

Notation "a 'u' b" := (coprod a b) (at level 40).

Variable obC: Type.
Variable morC: obC -> obC -> Type.
Variable C: Cat_struct morC.
Variable H: Cat_Coprod C.

Definition coproduct_mor a a' b b' (f: morC a a') (g : morC b b') :
  morC (a u b) (a' u b') :=
     coprod_mor (f ;; inl _ _ ) (g ;; inr _ _ ).

Notation "f 'U' g" := (coproduct_mor f g) (at level 40).

Variables a a' a'' b b' b'' c d e: obC.

Lemma coprod_mor_coprod_mor (f: morC a (c u d))(g:morC b (c u d))
                            (h:morC c e) (j: morC d e) :
  coprod_mor f g ;; coprod_mor h j ==
     coprod_mor (f;; coprod_mor h j) (g;;coprod_mor h j).
Proof.
  intros;
  apply coprod_mor_unique;
  split; rewrite <- assoc; cat.
Qed.

Lemma coproduct_mor_Proper:
     Proper (equiv ==> equiv ==> equiv) (@coproduct_mor a a' b b').
Proof.
  unfold Proper;
  do 2 red;
  intros;
  unfold coproduct_mor;
  apply coprod_mor_unique;
  rewrite inl_coprod;
  cat.
Qed.

Lemma coproduct_mor_id: id a U id b == id _ .
Proof.
  unfold coproduct_mor;
  apply hom_sym;
  apply coprod_mor_unique;
  cat.
Qed.

Lemma coprod_mor_coproduct_mor (f: morC a c) (g: morC b d)
          (h: morC c e) (j: morC d e):
   f U g ;; coprod_mor h j == coprod_mor (f ;; h) (g ;; j).
Proof.
  intros;
  unfold coproduct_mor;
  apply coprod_mor_unique;
  repeat rewrite <- assoc;
  rewrite inl_coprod;
  rewrite inr_coprod;
  repeat rewrite  assoc;
  cat.
Qed.

Lemma coproduct_mor_coproduct_mor (f: morC a a') (f': morC a' a'')
     (g: morC b b') (g': morC b' b''):
  (f ;; f') U (g ;; g') ==  f U g ;; f' U g'.
Proof.
  intros;
  unfold coproduct_mor;
  apply hom_sym;
  apply coprod_mor_unique;
  repeat rewrite <- assoc;
  rewrite inl_coprod;
  rewrite inr_coprod;
  repeat rewrite assoc;
  cat.
Qed.

End coprod_arrow.

Existing Instance coproduct_mor_Proper.

Section coprod_assoc.

Variable obC: Type.
Variable morC: obC -> obC -> Type.
Variable C: Cat_struct morC.
Variable H: Cat_Coprod C.

Variables a b c: obC.

Definition coprod_assoc_l_r := coprod_mor
        (coprod_mor (inl a (coprod b c)) (inl _ _ ;; inr _ _ ))
           (inr b c ;; inr a (coprod b c)).

Definition coprod_assoc_r_l := coprod_mor
        (inl _ _  ;; inl _ _ )
        (coprod_mor (inr a b ;; inl _ _) (inr (coprod a b) c )).

Lemma coprod_assoc_r_l_l_r:
     coprod_assoc_r_l ;; coprod_assoc_l_r == id _ .
Proof.
  unfold coprod_assoc_r_l,
         coprod_assoc_l_r;
  rewrite coprod_mor_coprod_mor;
  rewrite assoc;
  rewrite inl_coprod;
  rewrite inl_coprod;
  apply hom_sym;
  apply coprod_mor_unique;
  rewrite idr;
  rewrite idr;
  split;
   cat;
  rewrite coprod_mor_coprod_mor;
  apply coprod_mor_unique;
  split;
  try rewrite assoc;
  try rewrite inl_coprod;
  try rewrite inr_coprod;
  cat.
Qed.

Lemma coprod_assoc_l_r_r_l:
     coprod_assoc_l_r ;; coprod_assoc_r_l == id _ .
Proof.
  unfold coprod_assoc_r_l,
         coprod_assoc_l_r.
  rewrite coprod_mor_coprod_mor.
  rewrite assoc.
  rewrite inr_coprod.
  rewrite inr_coprod.
  apply hom_sym.
  apply coprod_mor_unique.
  rewrite idr.
  rewrite idr.
  split.
  rewrite coprod_mor_coprod_mor.
  apply coprod_mor_unique.
  split.
  rewrite inl_coprod.
  cat.
  rewrite assoc.
  rewrite inr_coprod.
  rewrite inl_coprod.
  cat.
  cat.
Qed.

End coprod_assoc.

(** coprod with a constant element on the right is a functor *)

Section coprod_rconst.
Notation "f 'U' g" := (coproduct_mor _ f g) (at level 40).
Variable obC: Type.
Variable morC: obC -> obC -> Type.
Variable C : Cat_struct morC.
Variable H : Cat_Coprod C.
Variable c : obC.

Program Instance CoP_R_struct : Functor_struct
 (Fobj:= fun x => coprod x c)
 (fun a b f => coproduct_mor _ f (id c)).
Next Obligation.
Proof.
  unfold Proper; red.
  intros.
  match goal with [H:_ |-_] => rewrite H end.
  cat.
Qed.
Next Obligation.
Proof.
  intros.
  rewrite coproduct_mor_id.
  cat.
Qed.
Next Obligation.
Proof.
  intros.
  rewrite <- coproduct_mor_coproduct_mor.
  cat.
Qed.

Definition CoP_R := Build_Functor CoP_R_struct.

End coprod_rconst.


(** * The new type variable relations
      This file contains the defintions of new type variable for types [new_tv_ty],
      schemes [new_tv_schm], contexts [new_tv_ctx] and substitutions [new_tv_subst].
      Several lemmas about new type variables are necessary for the completeness proof
      of algorithm W.
    *)

Set Implicit Arguments.

Require Import SimpleTypes.
Require Import Gen.
Require Import Omega.
Require Import Schemes.
Require Import Context.
Require Import SubstSchm.
Require Import List.
Require Import MyLtacs.
Require Import Subst.
Require Import SubstSchm.
Require Import ListIds.
Require Import Context.
Require Import Relation_Operators.
Require Import Coq.Setoids.Setoid.
Require Import LibTactics.

(** * New type variable definition for simple types *)

Inductive new_tv_ty : ty -> id -> Prop :=
| new_tv_con : forall i i' : id, new_tv_ty (con i') i
| new_tv_var : forall i i' : id, i < i' -> new_tv_ty (var i) i'
| new_tv_arrow : forall (tau tau' : ty) (i : id), new_tv_ty tau i ->
                                             new_tv_ty tau' i ->
                                             new_tv_ty (arrow tau tau') i.

Hint Constructors new_tv_ty:core.

(** ** Lemmas that are only about new type variables for simple types. *)

Lemma new_tv_var_id : forall st1 st2 : id, st1 < st2 -> new_tv_ty (var st1) st2.
Proof.
  intros.
  eauto.
Qed.

Hint Resolve new_tv_var_id:core.

Lemma new_tv_ty_ids : forall (st : id) (tau : ty),
    new_tv_ty tau st ->
    forall x : id, in_list_id x (ids_ty tau) = true -> x < st.
Proof.
  induction tau; intros; simpl in *; mysimp; intuition.
  destruct (eq_id_dec i x); intuition. inversion H. omega.
  apply in_list_id_or_append_inversion in H0.
  destruct H0; inversion H; auto.
Qed.

Hint Resolve new_tv_ty_ids:core.

Lemma add_subst_new_tv_ty : forall (s : substitution) (st : id) (tau1 tau2 : ty),
    new_tv_ty tau1 st -> apply_subst ((st, tau2)::s) tau1 = apply_subst s tau1.
Proof.
  induction s; crush.
  rewrite apply_subst_nil.
  induction tau1; crush.
  inverts* H; intuition.
  inverts* H.
  fequals; eauto.
  induction tau1; crush;
  inverts* H; intuition.
  inverts* H.
  fequals; eauto.
Qed.

Hint Resolve add_subst_new_tv_ty:core.
Hint Rewrite add_subst_new_tv_ty:RE.

Lemma new_tv_ty_trans_le : forall (tau : ty) (st1 st2 : id),
    new_tv_ty tau st1 -> st1 <= st2 -> new_tv_ty tau st2.
Proof.
  induction tau; crush.
  inverts* H.
  econstructor. omega.
  inverts* H.
Qed.

Hint Resolve new_tv_ty_trans_le:core.

Lemma new_tv_compose_subst_type : forall (s s1 s2 : substitution) (st : id) (tau : ty),
    (forall i : id, i < st -> apply_subst s (var i) = apply_subst s2 (apply_subst s1 (var i))) ->
    new_tv_ty tau st -> apply_subst s tau = apply_subst s2 (apply_subst s1 tau).
  induction tau.
  - crush.
  - crush.
  - intros.
    simpl.
    inverts* H0.
    fequals; eauto.
Qed.

Hint Resolve new_tv_compose_subst_type:core.
Hint Rewrite new_tv_compose_subst_type:RE.

(** * New type variable definition for schemes *)

Inductive new_tv_schm : schm -> id -> Prop :=
| new_tv_sc_con : forall i i' : id, new_tv_schm (sc_con i') i
| new_tv_sc_var : forall i i' : id, i < i' -> new_tv_schm (sc_var i) i'
| new_tv_sc_gen : forall i i' : id, new_tv_schm (sc_gen i') i
| new_tv_sc_arrow : forall (tau tau' : schm) (i : id), new_tv_schm tau i ->
                                               new_tv_schm tau' i ->
                                               new_tv_schm (sc_arrow tau tau') i.

Hint Constructors new_tv_schm:core.

(** ** Lemmas that are only about new type variables for schemes (and simple types). *)

(** Relating new type variables for simple types and schemes through [ty_to_schm]. *)
Lemma new_tv_ty_to_schm : forall tau st,
    new_tv_schm (ty_to_schm tau) st <-> new_tv_ty tau st.
Proof.
  intros. split.
  induction tau; simpl in *; try inversion H; try econstructor; eauto.
  inverts* H.
  inverts* H.
  inverts* H.
  intros.
  induction tau; simpl in *; try inversion H; try econstructor; eauto.
Qed.

Hint Resolve new_tv_ty_to_schm:core.

Lemma new_tv_schm_to_new_tv_ty : forall sigma x x0 i,
    new_tv_schm sigma x ->
    apply_inst_subst (compute_inst_subst x i) sigma = Some x0 ->
    new_tv_ty x0 (x + i).
Proof.
  induction sigma; intros; simpl in *; mysimp.
  - inversion H. inversion H0. econstructor. omega.
  - pose proof (Nat.lt_ge_cases i0 i).
    destruct H1.
    + erewrite nth_error_compute_inst_None in H0; auto.
      inversion H0.
    + apply Nat.lt_eq_cases in H1.
      destruct H1.
      * erewrite nth_error_compute_inst_Some in H0; auto.
        inversion H0. inversion H.
        subst.
        econstructor.
        omega.
      * subst.
        rewrite nth_error_compute_inst_None' in H0.
        inversion H0.
  - inversion H.
    subst.
    cases (apply_inst_subst (compute_inst_subst x i) sigma1).
    cases (apply_inst_subst (compute_inst_subst x i) sigma2).
    inversion H0.
    econstructor; eauto.
    inversion H0.
    inversion H0.
Qed.

Hint Resolve new_tv_schm_to_new_tv_ty:core.

Lemma new_tv_schm_plus : forall sigma st st', new_tv_schm sigma st -> new_tv_schm sigma (st + st').
Proof.
  induction sigma; intros; try econstructor; eauto.
  inversion H. subst. auto.
  inversion H. subst. eauto.
  Unshelve. apply x.
Qed.

Hint Resolve new_tv_schm_plus:core.

Lemma new_tv_schm_Succ : forall sigma i, new_tv_schm sigma i -> new_tv_schm sigma (S i).
Proof.
  intros.
  induction sigma;
  inversion H; econstructor; auto.
Qed.

Hint Resolve new_tv_schm_Succ:core.

Lemma new_tv_schm_trans : forall st st' sigma,
    new_tv_schm sigma st -> st <= st' -> new_tv_schm sigma st'.
Proof.
  induction sigma; crush.
  inversion H.
  econstructor; crush.
  inverts* H.
Qed.

Hint Resolve new_tv_schm_trans:core.

Lemma new_tv_schm_max_vars : forall sigma, new_tv_schm sigma (S (max_vars_schm sigma)).
Proof.
  induction sigma; crush.
  econstructor; eauto.
  destruct (Max.max_dec (max_vars_schm sigma1) (max_vars_schm sigma2)).
  rewrite e.
  auto.
  rewrite e.
  eapply new_tv_schm_trans; eauto.
  eapply Nat.max_r_iff.
  simpl.
  fequals*.
  destruct (Max.max_dec (max_vars_schm sigma1) (max_vars_schm sigma2)).
  rewrite e.
  eapply new_tv_schm_trans; eauto.
  eapply Nat.max_r_iff.
  simpl.
  fequals*.
  rewrite Max.max_comm.
  auto.
  rewrite e.
  auto.
Qed.

Hint Resolve new_tv_schm_max_vars:core.

Lemma new_tv_schm_apply_subst : forall i tau s sigma,
    new_tv_schm sigma i ->
    apply_subst_schm ((i, tau) :: s) sigma = apply_subst_schm s sigma.
Proof.
  intros.
  induction sigma;
  mysimp.
  cases (find_subst s i0); eauto;
  try inversion H; omega.
  inversion H. subst.
  fequals; eauto.
Qed.

Hint Resolve new_tv_schm_apply_subst:core.

(* Relating new_tv_ty to compute_subst*)
Lemma new_tv_schm_compute_inst_subst :
  forall (sigma : schm) (tau tau' : ty) (s : substitution) (p : nat) (st : id) (x : list ty),
    new_tv_schm sigma st -> max_gen_vars sigma <= p ->
    apply_inst_subst (compute_inst_subst st p) sigma = Some tau ->
    apply_inst_subst x (apply_subst_schm s sigma) = Some tau' ->
    tau' = apply_subst ((compute_subst st x) ++ s) tau.
Proof.
  induction sigma.
  - intros.
    inversion H. subst.
    simpl in H1. inversion H1.
    simpl in H2. fold (apply_subst s (var i)) in H2.
    rewrite apply_subst_inst_to_ty_to_schm in H2.
    inversion H2.
    rewrite find_subst_some_apply_app_compute_subst; eauto.
   - crush.
   - intros.
     simpl in *.
     rewrite nth_error_compute_inst_Some in *; eauto.
     inversion H1. inversion H. subst.
     cases (nth_error x i).
     inversion H2. subst. clear H2 H1.
     erewrite find_subst_some_apply_app; eauto.
     rewrite Nat.add_comm.
     eapply find_subst_id_compute; eauto.
     inversion H2.
   - intros.
     inversion H. subst.
     simpl in H0. rewrite apply_subst_schm_arrow in H2.
     edestruct (exist_arrow_apply_inst_arrow (compute_inst_subst st p)); eauto.
     destruct H3.
     edestruct (exist_arrow_apply_inst_arrow x); eauto.
     destruct H4. subst.
     apply and_arrow_apply_inst_arrow in H1.
     destruct H1.
     apply and_arrow_apply_inst_arrow in H2.
     destruct H2.
     simpl.
     eapply Nat.max_lub_r in H0 as H0r.
     eapply Nat.max_lub_l in H0 as H0l.
     erewrite <- IHsigma1; eauto.
     erewrite <- IHsigma2; eauto.
Qed.

Hint Resolve new_tv_schm_compute_inst_subst:core.

(** * New type variable definition for contexts *)

Inductive new_tv_ctx : ctx -> id -> Prop :=
| new_tv_ctx_nil : forall i : id, new_tv_ctx nil i
| new_tv_ctx_cons : forall (G : ctx) (i x : id) (sigma : schm),
    new_tv_ctx G i ->
    new_tv_schm sigma i ->
    new_tv_ctx ((x, sigma) :: G) i.

Hint Constructors new_tv_ctx:core.

(** ** Lemmas that are only about new type variables for contexts (and simple types and schemes). *)

Lemma new_tv_compose_subst_ctx : forall (s s1 s2 : substitution) (st : id) (G : ctx),
    (forall x : id, x < st -> apply_subst s (var x) = apply_subst s2 (apply_subst s1 (var x))) ->
    new_tv_ctx G st -> apply_subst_ctx s G = apply_subst_ctx s2 (apply_subst_ctx s1 G).
Proof.
  induction G. crush.
  intros.
  destruct a.
  inverts* H0.
  rename s0 into sigma.
  induction sigma.
  - inverts* H6.
    apply H in H1 as H1'.
    assert (apply_subst_ctx s ((i, sc_var i0) :: G) =
            ((i, ty_to_schm (apply_subst s (var i0)))::(apply_subst_ctx s G)) ).
    { reflexivity. }
    rewrite H0.
    erewrite IHG; eauto.
    erewrite H; eauto.
    assert (apply_subst_ctx s2 (apply_subst_ctx s1 ((i, sc_var i0) :: G)) =
            ((i, (apply_subst_schm s2
               (apply_subst_schm s1 (sc_var i0))))::(apply_subst_ctx s2 (apply_subst_ctx s1 G))) ).
    { reflexivity. }
    rewrite H2.
    assert ((apply_subst_schm s1 (sc_var i0)) =
            ty_to_schm (apply_subst s1 (var i0))).
    { reflexivity. }
    rewrite H3.
    rewrite ty_to_subst_schm.
    reflexivity.
  - crush.
  - crush.
  - inverts* H6.
    simpl.
    fequals; eauto.
    fequals; eauto.
    fequals; eauto.
    apply IHsigma1 in H2.
    repeat rewrite <- apply_subst_ctx_eq in H2.
    inversion H2; eauto.
    apply IHsigma2 in H4.
    repeat rewrite <- apply_subst_ctx_eq in H4.
    inversion H4; eauto.
Qed.

Lemma new_tv_ctx_plus : forall G st st', new_tv_ctx G st -> new_tv_ctx G (st + st').
Proof.
  induction G; intros; simpl in *; auto.
  destruct a.
  econstructor; auto.
  inversion H. subst;
  eauto.
  inversion H. subst;
  eauto.
Qed.

Hint Resolve new_tv_ctx_plus:core.

Lemma new_tv_ctx_Succ : forall G i, new_tv_ctx G i -> new_tv_ctx G (S i).
Proof.
  intros.
  induction H; econstructor; eauto.
Qed.

Hint Resolve new_tv_ctx_Succ:core.

Lemma new_tv_ctx_implies_new_tv_schm : forall (G : ctx) (sigma : schm) (st x : id),
    in_ctx x G = Some sigma -> new_tv_ctx G st -> new_tv_schm sigma st.
Proof.
  induction G; crush.
  inverts* H0.
  inverts* H0.
Qed.

Hint Resolve new_tv_ctx_implies_new_tv_schm:core.

Lemma new_tv_ctx_trans : forall st st' G, new_tv_ctx G st -> st <= st' -> new_tv_ctx G st'.
Proof.
  induction G; crush.
  apply Nat.lt_eq_cases in H0.
  destruct H0; crush.
  inverts* H.
  apply Nat.lt_le_incl in H0.
  econstructor; eauto.
Qed.

Hint Resolve new_tv_ctx_trans:core.

Lemma new_tv_ctx_apply_subst_ctx : forall st tau s G,
    new_tv_ctx G st -> apply_subst_ctx ((st, tau) :: s) G = apply_subst_ctx s G.
Proof.
  induction G; crush.
  inverts* H.
  rewrite IHG; eauto.
  fequals.
  fequals.
  eauto.
Qed.

Hint Resolve new_tv_ctx_apply_subst_ctx:core.

Lemma add_subst_add_ctx : forall (G : ctx) (s : substitution) (x : id) (st : id) (tau : ty),
    new_tv_ctx G st ->
    apply_subst_ctx ((st, tau)::s) ((x, sc_var st)::G) =
    (x, (ty_to_schm tau)) :: (apply_subst_ctx s G).
Proof.
  intros;
  mysimp.
  rewrite new_tv_ctx_apply_subst_ctx; auto.
Qed.

Hint Resolve add_subst_add_ctx:core.

Lemma new_tv_ctx_inversion : forall G tau st i,
    new_tv_ctx ((i, tau) :: G) st ->
    new_tv_ctx G st.
Proof.
  induction G; crush.
  inverts* H.
Qed.

Hint Resolve new_tv_ctx_inversion:core.

Lemma new_tv_gen_aux_ty: forall (tau : ty) (G : ctx) (st : id) l,
    new_tv_ty tau st -> new_tv_ctx G st -> new_tv_schm (fst (gen_ty_aux tau G l)) st.
Proof.
  induction tau; crush.
  cases (in_list_id i (FV_ctx G)); crush.
  cases (index_list_id i l); crush.
  inverts* H.
  eapply IHtau1 with (G:= G) (l:=l) in H3; eauto.
  cases (gen_ty_aux tau1 G l); crush.
  eapply IHtau2 with (G:= G) (l:=l0) in H5; eauto.
  cases (gen_ty_aux tau2 G l0); crush.
Qed.

Hint Resolve new_tv_gen_aux_ty:core.

Lemma new_tv_gen_ty: forall (tau : ty) (G : ctx) (st : id),
    new_tv_ty tau st -> new_tv_ctx G st -> new_tv_schm (gen_ty tau G) st.
Proof.
  induction tau; unfold gen_ty; eauto.
Qed.

Hint Resolve new_tv_gen_ty:core.

(** * New type variable definition for substitutions *)

Inductive new_tv_subst : substitution -> id -> Prop :=
| new_tv_subst_intro : forall (i : id) (s : substitution),
                  (forall x : id, in_list_id x (FV_subst s) = true -> x < i) ->
                  new_tv_subst s i.

Hint Constructors new_tv_subst:core.

(** ** Lemmas that are only about new type variables for substitutions
       (and simple types and schemes and contexts). *)

Lemma arrowcons (A:Type) : forall (s1 s2:list A) x, s1 ++ x::s2 = (s1 ++ x::nil) ++ s2.
  intros ; rewrite app_ass ; auto.
Qed.

(** A hard lemma about adding a new element to a substitution. *)
Lemma new_ty_to_cons_new_tv_subst : forall tau i a s,
    a < i -> new_tv_ty tau i -> new_tv_subst s i -> new_tv_subst ((a, tau) :: s) i.
Proof.
  induction tau; intros; simpl in *.
  inversion H0. subst.
  inversion H1.
  econstructor. intros.
  subst.
  simpl in H6.
  destruct (eq_id_dec a x). subst.
  assumption.
  simpl in H6.
  apply in_list_id_append_comm_true in H6.
  unfold img_ids in H6. simpl in H6. destruct (eq_id_dec i x).
  subst. assumption. fold (img_ids s) in H6.
  apply in_list_id_append_comm_true in H6.
  fold (FV_subst s) in H6. auto.
  econstructor. intros.
  simpl in H2.
  destruct (eq_id_dec a x). subst.
  assumption.
  apply in_list_id_append_comm_true in H2.
  unfold img_ids in H2. simpl in H2.
  fold (img_ids s) in H2.
  apply in_list_id_append_comm_true in H2.
  fold (FV_subst s) in H2.
  inversion H1. auto.
  inversion H0. subst.
  econstructor. intros.
  crush.
  apply in_list_id_append_comm_true in H2.
  unfold img_ids in H2. simpl in H2.
  fold (img_ids s) in H2.
  assert (new_tv_subst ((a, tau1) :: s) i). auto.
  assert (new_tv_subst ((a, tau2) :: s) i). auto.
  inversion H3. subst.
  inversion H5. subst.
  specialize H7 with (x:=x).
  specialize H8 with (x:=x).
  simpl in *. destruct (eq_id_dec a x); eauto.
  unfold img_ids in *. simpl in *.
  fold (img_ids s) in *.
  apply in_list_id_append_comm_true in H2.
  rewrite <- app_assoc in H2.
  rewrite app_assoc in H2.
  apply in_list_id_append_comm_true2 in H2.
  rewrite app_assoc in H2.
  apply in_list_id_or_append_inversion in H2.
  destruct H2.
  rewrite <- app_assoc in H2.
  auto.
  auto.
Qed.

Hint Resolve new_ty_to_cons_new_tv_subst:core.

Lemma new_tv_subst_tail : forall a tau s i,
    new_tv_subst ((a, tau) :: s) i -> new_tv_subst s i.
Proof.
  intros.
  econstructor. intros.
  inverts* H. apply H1.
  unfold FV_subst in *.
  unfold img_ids in *.
  specialize H1 with (x:=x).
  induction tau.
  simpl in *. destruct (eq_id_dec a x). eauto.
  rewrite arrowcons.
  rewrite <- app_assoc.
  apply in_list_id_append_comm_true3.
  simpl. destruct (eq_id_dec i0 x); eauto.
  crush.
  crush.
Qed.

Hint Resolve new_tv_subst_tail:core.

Lemma new_tv_subst_arrow_inversion : forall a tau1 tau2 s i,
    new_tv_subst ((a, arrow tau1 tau2) :: s) i ->
    new_tv_subst ((a, tau1)::s) i /\ new_tv_subst ((a, tau2)::s) i.
Proof.
  intros.
  inverts* H.
  split.
  - econstructor.
    intros. apply H0.
    unfold FV_subst in *.
    unfold img_ids in *.
    simpl (concat (map ids_ty (img ((a, arrow tau1 tau2) :: s)))).
    simpl (dom ((a, arrow tau1 tau2) :: s)).
    simpl (dom ((a, tau1) :: s)) in H.
    simpl (concat (map ids_ty (img ((a, tau1) :: s)))) in H.
    rewrite <- app_assoc.
    apply in_list_id_append_comm_true3 in H.
    apply in_list_id_append_comm_true3.
    apply in_list_id_or_append_inversion in H.
    destruct H.
    apply in_list_id_append1; eauto.
    apply in_list_id_append2; eauto.
  - econstructor.
    intros. apply H0.
    unfold FV_subst in *.
    unfold img_ids in *.
    simpl (concat (map ids_ty (img ((a, arrow tau1 tau2) :: s)))).
    simpl (dom ((a, arrow tau1 tau2) :: s)).
    simpl (dom ((a, tau2) :: s)) in H.
    simpl (concat (map ids_ty (img ((a, tau2) :: s)))) in H.
    apply in_list_id_append_comm_true3 in H.
    apply in_list_id_append_comm_true3.
    apply in_list_id_or_append_inversion in H.
    destruct H.
    apply in_list_id_append1; eauto.
    apply in_list_id_append2; eauto.
Qed.

Hint Resolve new_tv_subst_arrow_inversion:core.

Lemma new_tv_subst_cons_new_tv_ty : forall tau s i a,
    new_tv_subst ((a, tau) :: s) i -> new_tv_ty tau i.
Proof.
  induction tau; crush.
  econstructor.
  inversion H. subst.
  apply H0.
  unfold FV_subst.
  unfold img_ids.
  eapply in_list_id_append_comm_true.
  crush.
  apply new_tv_subst_arrow_inversion in H as H'.
  destruct H'.
  eauto.
Qed.

Hint Resolve new_tv_subst_cons_new_tv_ty:core.

Lemma new_tv_apply_subst_var : forall (st st' : id) (s : substitution),
    new_tv_subst s st -> st' < st -> new_tv_ty (apply_subst s (var st')) st.
Proof.
  induction s; crush.
Qed.

Hint Resolve new_tv_apply_subst_var:core.

Lemma new_tv_apply_subst_ty : forall (st : id) (s : substitution) (tau : ty),
    new_tv_ty tau st -> new_tv_subst s st -> new_tv_ty (apply_subst s tau) st.
Proof.
  induction tau; intros.
  inversion H; subst. eauto.
  inverts* H.
  crush.
  inverts* H.
  simpl.
  econstructor; eauto.
Qed.

Hint Resolve new_tv_apply_subst_ty:core.

Lemma new_tv_apply_subst_schm_var : forall  (s : substitution) (st st' : id),
    new_tv_subst s st -> st' < st -> new_tv_schm (apply_subst_schm s (sc_var st')) st.
Proof.
  intros.
  induction s. crush.
  destruct a.
  apply new_tv_subst_cons_new_tv_ty in H as H'.
  apply new_tv_subst_tail in H as H''.
  crush.
  apply new_tv_ty_to_schm.
  auto.
Qed.

Hint Resolve new_tv_apply_subst_schm_var:core.

Lemma new_tv_apply_subst_schm : forall (st : id) (s : substitution) (sigma : schm),
    new_tv_schm sigma st -> new_tv_subst s st -> new_tv_schm (apply_subst_schm s sigma) st.
Proof.
  induction sigma; intros.
  inverts* H.
  crush.
  simpl.
  auto.
  inverts* H.
  simpl.
  econstructor; eauto.
Qed.

Hint Resolve new_tv_apply_subst_schm:core.

Lemma new_tv_subst_list : forall (s1 s2 : substitution) (i : id),
    new_tv_subst s1 i ->
    new_tv_subst s2 i ->
    new_tv_subst (apply_subst_list s1 s2) i.
Proof.
  induction s1; crush.
  inversion H. subst.
  specialize H1 with (x:=a).
  simpl in H1.
  crush.
  apply new_ty_to_cons_new_tv_subst; eauto.
Qed.

Hint Resolve new_tv_subst_list:core.

Lemma new_tv_compose_subst : forall (s1 s2 : substitution) (i : id),
    new_tv_subst s1 i ->
    new_tv_subst s2 i ->
    new_tv_subst (compose_subst s1 s2) i.
Proof.
  induction s1, s2; crush.
  inversion H. inversion H0. subst.
  unfold compose_subst.
  econstructor.
  intros.
  unfold FV_subst in *.
  repeat rewrite dom_dist in H2.
  repeat rewrite img_ids_dist in H2.
  repeat rewrite apply_subst_list_dom in H2.
  repeat rewrite app_assoc in H2.
  assert (in_list_id x (img_ids ((p, t) :: s2) ++ (dom ((p, t) :: s2)) ++
          ((dom ((a, t0) :: s1) ++ img_ids (apply_subst_list ((a, t0) :: s1) ((p, t) :: s2))))) = true).
  { rewrite app_assoc. apply in_list_id_append_comm_true3.
    rewrite <- app_assoc. rewrite app_assoc. apply in_list_id_append_comm_true3.
    rewrite <- app_assoc. apply in_list_id_append_comm_true3.
    rewrite app_assoc. apply in_list_id_append_comm_true2.
    rewrite app_assoc. auto. }
  apply in_list_id_append_comm_true3 in H3.
  rewrite app_assoc in H3.
  apply in_list_id_or_append_inversion in H3.
  destruct H3.
  auto.
  pose proof (new_tv_subst_list  H H0).
  inversion H5. subst.
  unfold FV_subst in H6.
  repeat rewrite apply_subst_list_dom in H6.
  auto.
Qed.

Hint Resolve new_tv_compose_subst:core.

Lemma new_tv_subst_nil : forall st, new_tv_subst nil st.
Proof.
  intros. econstructor; intros ; simpl in *; inversion H.
Qed.

Hint Resolve new_tv_subst_nil:core.

Lemma new_tv_s_ctx : forall (st : id) (s : substitution) (G : ctx),
    new_tv_ctx G st -> new_tv_subst s st -> new_tv_ctx (apply_subst_ctx s G) st.
Proof.
  induction G; crush.
  inverts* H.
Qed.

Hint Resolve new_tv_s_ctx:core.

Lemma new_tv_subst_trans : forall (s : substitution) (i1 i2 : id),
  new_tv_subst s i1 -> i1 <= i2 -> new_tv_subst s i2.
Proof.
  induction s; crush.
  inverts* H.
  econstructor.
  intros.
  specialize H1 with (x:=x).
  assert (x < i1).
  { auto. }
  omega.
Qed.

Hint Resolve new_tv_subst_trans:core.

Lemma new_tv_subst_false : forall st s t, new_tv_subst ((st, t) :: s) st -> False.
Proof.
  intros.
  induction s. inversion H.
  specialize H0 with (x:=st).
  simpl in H0.
  destruct (eq_id_dec st st);
  intuition.
  inversion H.
  simpl in H0.
  specialize H0 with (x:=st).
  destruct (eq_id_dec st st); intuition.
Qed.

Hint Resolve new_tv_subst_false:core.


Require Import Utf8 List Wf Lia.
Import ListNotations.
Require Import CpdtTactics.
Require Import LibLN.
Require Import Lang.Syntax Lang.Bindings.
Local Set Implicit Arguments.

Section section_ktx.
Context (EV HV V L : Set).

(** Use [t] to fill in the hole of [ktx] *)
Fixpoint ktx_plug
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
tm EV HV V L.
Proof.
destruct K as [ | K X | K s | K 𝓔 | K h | K s | K v ].
+ refine t.
+ refine (⇩ X (ktx_plug K t)).
+ refine (tm_let (ktx_plug K t) s).
+ refine (tm_eapp (ktx_plug K t) 𝓔).
+ refine (tm_happ (ktx_plug K t) h).
+ refine (tm_app (ktx_plug K t) s).
+ refine (tm_app v (ktx_plug K t)).
Defined.

(** Compose [outer] and [inner] to form a new evaluation context. *)
Fixpoint ktx_comp
(outer : ktx EV HV V L) (inner : ktx EV HV V L) {struct outer} :
ktx EV HV V L :=
match outer with
| ktx_hole => inner
| ktx_down J X => ktx_down (ktx_comp J inner) X
| ktx_let J s => ktx_let (ktx_comp J inner) s
| ktx_eapp J 𝓔 => ktx_eapp (ktx_comp J inner) 𝓔
| ktx_happ J h => ktx_happ (ktx_comp J inner) h
| ktx_app1 J s => ktx_app1 (ktx_comp J inner) s
| ktx_app2 J v => ktx_app2 (ktx_comp J inner) v
end.

(** Return [True] iff [X] is not bound in [K]. *)
Fixpoint tunnels (X : var) (K : ktx EV HV V L) : Prop :=
match K with
| ktx_hole => True
| ktx_let J _ => tunnels X J
| ktx_eapp J _ => tunnels X J
| ktx_happ J _ => tunnels X J
| ktx_app1 J _ => tunnels X J
| ktx_app2 J _ => tunnels X J
| ktx_down J X' => tunnels X J ∧ ¬ X = X'
end.

End section_ktx.

Inductive config :=
| config_mk : list var → tm0 → config
.

Notation "⟨ ξ , t ⟩" := (config_mk ξ t) : core_scope.

Inductive step : config → config → Prop :=
| step_let :
  ∀ ξ (v : val0) t,
  step ⟨ξ, tm_let v t⟩ ⟨ξ, V_subst_tm v t⟩
| step_eapp :
  ∀ ξ t 𝓔,
  step ⟨ξ, tm_eapp (val_efun t) 𝓔⟩ ⟨ξ, EV_subst_tm 𝓔 t⟩
| step_happ :
  ∀ ξ t h,
  step ⟨ξ, tm_happ (val_hfun t) h⟩ ⟨ξ, HV_subst_tm h t⟩
| step_app :
  ∀ ξ t (v : val0),
  step ⟨ξ, tm_app (val_fun t) v⟩ ⟨ξ, V_subst_tm v t⟩
| step_Down :
  ∀ ξ t X,
  X ∉ from_list ξ → (* this arbitrariness about [X] allows non-determinism *)
  step ⟨ξ, ⬇ t⟩ ⟨X :: ξ, ⇩ X (L_subst_tm (lid_f X) t)⟩
| step_down_val :
  ∀ ξ X (v : val0),
(*   X ∈ from_list ξ → *)
  step ⟨ξ, ⇩ X v⟩ ⟨ξ, v⟩
| step_down_up :
  ∀ ξ X K 𝔽 t (v : val0),
(*   X ∈ from_list ξ → *)
  tunnels X K →
  step
  ⟨ξ, ⇩ X (ktx_plug K (tm_app (⇧ (hd_def 𝔽 (lid_f X) t)) v))⟩
  ⟨ξ,
    let cont := val_fun (⇩ X (ktx_plug (V_open_ktx K) (val_var VZ))) in
    V2_subst_tm v cont t
  ⟩
| step_ktx_down :
  ∀ ξ₁ ξ₂ t₁ t₂ X,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, ⇩ X t₁⟩ ⟨ξ₂, ⇩ X t₂⟩
| step_ktx_let :
  ∀ ξ₁ ξ₂ t₁ t₂ s,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_let t₁ s⟩ ⟨ξ₂, tm_let t₂ s⟩
| step_ktx_app1 :
  ∀ ξ₁ ξ₂ t₁ t₂ s,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_app t₁ s⟩ ⟨ξ₂, tm_app t₂ s⟩
| step_ktx_app2 :
  ∀ ξ₁ ξ₂ (v : val0) t₁ t₂ ,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_app v t₁⟩ ⟨ξ₂, tm_app v t₂⟩
| step_ktx_eapp :
  ∀ ξ₁ ξ₂ t₁ t₂ 𝓔,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_eapp t₁ 𝓔⟩ ⟨ξ₂, tm_eapp t₂ 𝓔⟩
| step_ktx_happ :
  ∀ ξ₁ ξ₂ t₁ t₂ h,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_happ t₁ h⟩ ⟨ξ₂, tm_happ t₂ h⟩
.

(** The transitive closure of the reduction relation. *)
Definition step_tran := @Relation_Operators.clos_trans_1n _ step.

(** The reflexive and transitive closure of the reduction relation. *)
Definition step_refl_tran := @Relation_Operators.clos_refl_trans_1n _ step.

(** Reduction in a given number of steps. *)
Inductive step_n : nat → config → config → Prop :=
| step_n_O : ∀ c, step_n O c c
| step_n_S : ∀ n c₁ c₂ c₃,
    step c₁ c₂ →
    step_n n c₂ c₃ →
    step_n (S n) c₁ c₃
.


Require Import include_frm.
Require Import sep_auto.
Require Import derived_rules.
Require Import hoare_conseq.
Require Import tv_match.
Require Import hoare_tactics.

Open Scope code_scope.

Fixpoint decllen (lst :decllist): nat :=
  match lst with
  | dnil => O
  | dcons _ _ lst' => S (decllen lst')
  end.

Lemma dl_vl_match_dv_same_length :
  forall (dl:decllist) (vl: list val),
    dl_vl_match dl vl = true -> decllen dl = length vl.
Proof.
  intro.
  induction dl.
  intros.
  induction vl.
  reflexivity.
  inversion H.
  intros.
  induction vl.
  inversion H.
  simpl.
  cut (decllen dl = length vl).
  intro.
  rewrite H0.
  reflexivity.
  apply IHdl.
  simpl in H.
  cut (type_val_match t a =true).
  intro.
  rewrite H0 in H.
  assumption.
  remember (type_val_match t a) as Hbool.
  destruct Hbool; tryfalse.
  auto.
Qed.

Lemma len_exist_0 :
  forall (vl: list val),
    length (rev vl) = 0%nat -> vl = nil.
Proof.
  inductions vl; intros; tryfalse; auto.
  rewrite rev_length in H.
  simpl in H; tryfalse.
Qed.

Lemma len_exist_1 :
  forall (vl: list val),
    length (rev vl) = 1%nat ->
    exists v1 , vl = v1 :: nil.
Proof.
  inductions vl; intros; tryfalse; simpl; auto.
  simpl in H.
  rewrite app_length in H.
  simpl in H.
  rewrite plus_comm in H.
  inverts H.
  apply len_exist_0 in H1.
  simpljoin; eauto.
Qed.

Lemma len_exist_2 :
  forall (vl: list val),
    length (rev vl)  = 2%nat ->
    exists v1 v2, vl = v1 :: v2 :: nil.
Proof.
  inductions vl; intros; tryfalse; simpl; auto.
  simpl in H.
  rewrite app_length in H.
  simpl in H.
  rewrite plus_comm in H.
  inverts H.
  apply len_exist_1 in H1.
  simpljoin; eauto.
Qed.

Lemma len_exist_3 :
  forall (vl: list val),
    length (rev vl)  = 3%nat ->
    exists v1 v2 v3, vl = v1 :: v2 :: v3 :: nil.
Proof.
  inductions vl; intros; tryfalse; simpl; auto.
  simpl in H.
  rewrite app_length in H.
  simpl in H.
  rewrite plus_comm in H.
  inverts H.
  apply len_exist_2 in H1.
  simpljoin; eauto.
Qed.

Lemma len_exist_4 :
  forall (vl: list val),
    length (rev vl)  = 4%nat ->
    exists v1 v2 v3 v4, vl = v1 :: v2 :: v3 :: v4 ::  nil.
Proof.
  inductions vl; intros; tryfalse; simpl; auto.
  simpl in  H.
  rewrite app_length in H.
  simpl in H.
  rewrite plus_comm in H.
  inverts H.
  apply len_exist_3 in H1.
  simpljoin; eauto.
Qed.

Lemma len_exist_5 :
  forall (vl: list val),
    length (rev vl)  = 5%nat ->
    exists v1 v2 v3 v4 v5, vl = v1 :: v2 :: v3 :: v4 :: v5 :: nil.
Proof.
  inductions vl; intros; tryfalse; simpl; auto.
  simpl in H.
  rewrite app_length in H.
  rewrite plus_comm in H.
  inverts H.
  apply len_exist_4 in H1.
  simpljoin; eauto.
  do 5 eexists; eauto.
Qed.

Lemma len_exist_6 :
  forall (vl: list val),
    length (rev vl)  = 6%nat ->
    exists v1 v2 v3 v4 v5 v6,
      vl = v1 :: v2 :: v3 :: v4 :: v5 :: v6 :: nil.
Proof.
  inductions vl; intros; tryfalse; simpl; auto.
  simpl in H.
  rewrite app_length in H.
  rewrite plus_comm in H.
  inverts H.
  apply len_exist_5 in H1.
  simpljoin; eauto.
  do 6 eexists; eauto.
Qed.

Lemma dl_vl_match_0:
  forall vl ,
    dl_vl_match  dnil (rev vl) = true ->  vl = nil .
Proof.
  introv Heq.
  lets H100 :  dl_vl_match_dv_same_length  Heq.
  simpl in H100.
  apply sym_eq in H100.
  apply len_exist_0 in H100.
  auto.
Qed.

Lemma dl_vl_match_1:
  forall vl x t ,
    dl_vl_match (dcons x t dnil) (rev vl) = true ->
    exists v, vl = v :: nil /\  type_val_match t  v  = true.
Proof.
  introv Heq.
  lets H100 :  dl_vl_match_dv_same_length  Heq.
  simpl in H100.
  apply sym_eq in H100.
  apply len_exist_1 in H100.
  simpljoin; eexists; split; eauto.
  simpl in Heq.
  remember (type_val_match t x0) as Hbool.
  destruct Hbool; tryfalse; auto.
Qed.

Lemma dl_vl_match_2:
  forall vl x1 t1 x2 t2 ,
    dl_vl_match ⌞x1 @ t1 ; x2 @ t2⌟ (rev vl) = true ->
    exists v1 v2, vl = v1 :: v2 :: nil /\
                  type_val_match t2 v1 = true /\
                  type_val_match t1 v2 = true.
Proof.
  introv Heq.
  lets H100 :  dl_vl_match_dv_same_length  Heq.
  simpl in H100.
  apply sym_eq in H100.
  apply len_exist_2 in H100.
  simpljoin; do 2 eexists; splits; eauto.
  simpl in Heq.
  remember (type_val_match t1 x0) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t2 x) as Hbool.
  destruct Hbool; tryfalse; auto.
  simpl in Heq.
  remember (type_val_match t1 x0) as Hbool.
  destruct Hbool; tryfalse; auto.
Qed.

Lemma dl_vl_match_3: forall vl x1 t1 x2 t2 x3 t3 ,
    dl_vl_match ⌞x1 @ t1 ; x2 @ t2 ;  x3 @ t3⌟ (rev vl) = true ->
    exists v1 v2 v3, vl = v1 :: v2 :: v3 :: nil /\
                     type_val_match t3  v1 = true /\
                     type_val_match t2 v2 = true /\
                     type_val_match t1 v3 = true.
Proof.
  introv Heq.
  lets H100 :  dl_vl_match_dv_same_length  Heq.
  simpl in H100.
  apply sym_eq in H100.
  apply len_exist_3 in H100.
  simpljoin; do 3 eexists; splits; eauto.
  simpl in Heq.
  remember (type_val_match t1 x4) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t2 x0) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t3 x) as Hbool.
  destruct Hbool; tryfalse; auto.
  simpl in Heq.
  remember (type_val_match t1 x4) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t2 x0) as Hbool.
  destruct Hbool; tryfalse; auto.
  simpl in Heq.
  remember (type_val_match t1 x4) as Hbool.
  destruct Hbool; tryfalse; auto.
Qed.

Lemma dl_vl_match_4: forall vl x1 t1 x2 t2 x3 t3 x4 t4 ,
    dl_vl_match  ⌞x1 @ t1 ; x2 @ t2 ;  x3 @ t3 ; x4 @ t4⌟ (rev vl) = true ->
    exists v1 v2 v3 v4, vl = v1 :: v2 :: v3 :: v4 ::  nil /\
                        type_val_match t4 v1 = true /\
                        type_val_match t3 v2 = true /\
                        type_val_match t2 v3 = true /\
                        type_val_match t1 v4 = true.
Proof.
  introv Heq.
  lets H100 :  dl_vl_match_dv_same_length  Heq.
  simpl in H100.
  apply sym_eq in H100.
  apply len_exist_4 in H100.
  simpljoin; do 4 eexists.
  split.
  eauto.
  simpl in Heq.
  remember (type_val_match t1 x6) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t2 x5) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t3 x0) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t4 x) as Hbool.
  destruct Hbool; tryfalse; auto.
Qed.

Lemma dl_vl_match_5: forall vl x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 ,
    dl_vl_match  ⌞x1 @ t1 ; x2 @ t2 ;  x3 @ t3 ; x4 @ t4 ; x5 @ t5⌟ (rev vl) = true ->
    exists v1 v2 v3 v4 v5,
      vl = v1 :: v2 :: v3 :: v4 :: v5 :: nil /\
      type_val_match t5 v1 = true /\
      type_val_match t4 v2 = true /\
      type_val_match t3 v3 = true /\
      type_val_match t2 v4 = true /\
      type_val_match t1 v5 = true.
Proof.
  introv Heq.
  lets H100 :  dl_vl_match_dv_same_length  Heq.
  simpl in H100.
  apply sym_eq in H100.
  apply len_exist_5 in H100.
  simpljoin; do 5 eexists.
  split.
  eauto.
  simpl in Heq.
  remember (type_val_match t1 x8) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t2 x7) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t3 x6) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t4 x0) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t5 x) as Hbool.
  destruct Hbool; tryfalse; auto.
Qed.

Lemma   dl_vl_match_6 :
  forall vl x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 ,
    dl_vl_match  ⌞x1 @ t1 ; x2 @ t2 ;  x3 @ t3 ; x4 @ t4 ; x5 @ t5 ; x6 @ t6⌟ (rev vl) = true ->
    exists v1 v2 v3 v4 v5 v6,
      vl = v1 :: v2 :: v3 :: v4 :: v5 :: v6 :: nil /\
      type_val_match t6 v1 = true /\
      type_val_match t5 v2 = true /\
      type_val_match t4 v3 = true /\
      type_val_match t3 v4 = true /\
      type_val_match t2 v5 = true /\
      type_val_match t1 v6 = true.
Proof.
  introv Heq.
  lets H100 :  dl_vl_match_dv_same_length  Heq.
  simpl in H100.
  apply sym_eq in H100.
  apply len_exist_6 in H100.
  simpljoin; do 6 eexists.
  split.
  eauto.
  simpl in Heq.
  remember (type_val_match t1 x10) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t2 x9) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t3 x8) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t4 x7) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t5 x0) as Hbool.
  destruct Hbool; tryfalse; auto.
  remember (type_val_match t6 x) as Hbool.
  destruct Hbool; tryfalse; auto.
  splits; auto.
Qed.

Ltac unfold_internal_pre :=
  match goal with
    | H:_
      |- context[{|_ , _, _, _,  _ , _|}|- ?ct {{?p}}_ {{_}}] =>
      match p with
        | _  **  (?t _  _  _  ) **  _ =>  try   unfold t
      end
    | _ => idtac
  end.

Ltac unfold_internal_post :=
  match goal with
    | H:_
      |-context[ {|_ , _, _, _,  ?r , _|}|- ?ct {{_}}_ {{_}}] =>
      match r with
        |  context[_  **  (?t  _ _ _  _) ** _ ]  =>
             try unfold t
      end
    | _ => idtac
  end.

Ltac init_retspec :=
  match goal with
    | H : Some _ = BuildRetI _ _ _ _ _ _ |-  _ =>
      unfold BuildRetI in H; simpl in H; inverts H;unfold_internal_post
    | H : Some _ = BuildRetA' _ _ _ _ _ _ _ |-  _ =>
      unfold BuildRetA' in H; simpl in H; inverts H
  end.

Ltac init_prespec  :=
  match goal with
    | H : Some _ = BuildPreI ?x ?y ?z _ _ _ |-  _ =>
      unfold BuildPreI in H;
        let xy:= fresh in
        remember (x y) as xy;
          destruct xy as [ xy | ]; tryfalse;
          let a := fresh in
          destruct xy as [ [ [ ? a ] ] ];
            let b := fresh in
            remember (dl_vl_match a (rev z)) as b;
              destruct b; tryfalse
    | H: Some _ = BuildPreA' ?x ?y _ ?z _ _ _ |- _ =>
      unfold BuildPreA' in H;
        let xy := fresh in
        remember (x y) as xy;
          destruct xy as [ xy | ]; tryfalse;
          let a := fresh in
          destruct xy as [ [ [ ? a ] ] ];
            let b := fresh in
            remember (dl_vl_match a (rev z)) as b;
              destruct b; tryfalse
  end;
  match goal with
    | H :  Some _  =  _ _  |- _ => inverts H
  end;
  match goal with
    | H : true = _ ?l _ |- _ => apply sym_eq in H;
        match listlen l with
          | 0%nat => apply dl_vl_match_0 in H; simpljoin
          | 1%nat => apply dl_vl_match_1 in H; simpljoin
          | 2%nat => apply dl_vl_match_2 in H; simpljoin
          | 3%nat => apply dl_vl_match_3 in H; simpljoin
          | 4%nat => apply dl_vl_match_4 in H; simpljoin
          | 5%nat => apply dl_vl_match_5 in H; simpljoin
          | 6%nat => apply dl_vl_match_6 in H; simpljoin
          | _ => fail
        end
  end;
  match goal with
    | H : Some _ = _ |- _ =>
      simpl in H; inverts H
  end;
  do 4 eexists; split; auto.

(*
Ltac init_spec_api :=
  intros; init_retspec; init_prespec;
  hoare normal pre;
  hoare_split_pure_all;

 (* eapply backward_rule1;
  [ apply Aop_Aop'_eq'
  | idtac ];
  let H := fresh in
  eapply r_conseq_rule;
  [ intros ? ? H; apply Aop_Aop'_eq; exact H
  | intros ? H; exact H
  | idtac ];*)
  type_val_match_elim.
(*
Ltac init_spec_internal :=  intros; init_retspec; init_prespec;
  type_val_match_elim; unfold_internal_pre_post.
*)
*)

Ltac init_spec :=
  intros; init_retspec; init_prespec;
  unfold_internal_pre;
  hoare normal pre;
  hoare_split_pure_all;
  type_val_match_elim.

Tactic Notation "init" "spec" := init_spec.

Close Scope code_scope.