Require Import PeanoNat.
Require List.
Require Import Relations.
Import List.ListNotations.
Open Scope list.
Require Import Equality.
Require Import Eqdep_dec.
Require Import FunctionalExtensionality.

Set Implicit Arguments.

Inductive type :=
  | tree : type
  | arrow : type -> type -> type.
Infix "-->" := arrow (at level 35, right associativity).

Definition type_dec : forall (t1 t2: type), {t1=t2} + {t1<>t2}.
Proof.
  decide equality.
Defined.

Definition mapping := list type.

Implicit Types (Gamma: mapping) (t: type).

Inductive variable : mapping -> type -> Type :=
| var_here : forall Gamma t, variable (t :: Gamma) t
| var_outer : forall Gamma t t', variable Gamma t -> variable (t' :: Gamma) t.

Theorem variable_to_in : forall Gamma t,
    variable Gamma t -> List.In t Gamma.
Proof.
  induction 1; simpl; intros; eauto.
Qed.

Inductive expr (Gamma: mapping) : type -> Type :=
| var : forall t (v: variable Gamma t), expr Gamma t
| nil : expr Gamma tree
| eats : expr Gamma tree -> expr Gamma tree -> expr Gamma tree
| abs : forall t1 t2,
    forall (e: expr (t1 :: Gamma) t2),
      expr Gamma (arrow t1 t2)
| app : forall t1 t2,
    forall (e1: expr Gamma (arrow t1 t2))
      (e2: expr Gamma t1),
      expr Gamma t2
| recur : forall t,
    forall (eleaf: expr Gamma t)
      (enode: expr (t :: t :: Gamma) t)
      (e: expr Gamma tree),
      expr Gamma t.
Arguments nil {Gamma}.
Infix "◁" := eats (at level 15, left associativity).
Infix "@" := app (at level 13, left associativity).
Notation "'lambda' e" := (abs e) (at level 21, right associativity).

Definition renaming Gamma Gamma' :=
  forall t (v: variable Gamma t), variable Gamma' t.

Program Definition renaming_shift
        Gamma Gamma' t
        (gamma: renaming Gamma Gamma') :
  renaming (t :: Gamma) (t :: Gamma') :=
  fun t' v =>
    match v with
      | var_here _ _ => var_here _ _
      | var_outer _ v' => var_outer _ (gamma _ v')
    end.

Definition apply_renaming Gamma Gamma' (gamma: renaming Gamma Gamma')
           t (e: expr Gamma t) : expr Gamma' t.
  intros.
  generalize dependent Gamma'.
  generalize dependent Gamma.
  induction 1; intros; subst.
  - exact (var (gamma _ v)).
  - exact nil.
  - now apply eats; [ apply IHe1 | apply IHe2 ].
  - eapply abs.
    eapply IHe; trivial.
    now apply renaming_shift.
  - now eapply app; [ apply IHe1 | apply IHe2 ].
  - eapply recur.
    now apply IHe1.
    apply IHe2; trivial.
    apply renaming_shift.
    now apply renaming_shift.
    now apply IHe3.
Defined.

Definition var_shift Gamma t' : renaming _ _ := fun t (v: variable Gamma t) => var_outer t' v.

Definition expr_shift Gamma t t' (e: expr Gamma t) : expr (t' :: Gamma) t.
  eapply apply_renaming; eauto.
  exact (var_shift _).
Defined.

Definition substitution Gamma Gamma' :=
  forall t (v: variable Gamma t), expr Gamma' t.

Program Definition substitution_shift
        Gamma Gamma' t
        (gamma: substitution Gamma Gamma') :
  substitution (t :: Gamma) (t :: Gamma') := fun t' v =>
  match v with
    | var_here _ _ => var (var_here _ _)
    | var_outer _ v' => expr_shift t (gamma _ v')
  end.

Program Definition substitution_shift_expr
        Gamma Gamma' t
        (e': expr Gamma' t)
        (gamma: substitution Gamma Gamma') :
  substitution (t :: Gamma) Gamma' :=
  fun t' (v: variable (t :: Gamma) t') =>
    match v with
      | var_here _ _ => e'
      | var_outer _ v' => gamma _ v'
    end.

Definition apply_substitution Gamma Gamma' (gamma: substitution Gamma Gamma')
           t (e: expr Gamma t) : expr Gamma' t.
  intros.
  generalize dependent Gamma'.
  generalize dependent Gamma.
  induction 1; intros; subst.
  - exact (gamma _ v).
  - exact nil.
  - now apply eats; [ apply IHe1 | apply IHe2 ].
  - eapply abs.
    eapply IHe; trivial.
    now apply substitution_shift.
  - now eapply app; [ apply IHe1 | apply IHe2 ].
  - eapply recur.
    now apply IHe1.
    apply IHe2; trivial.
    apply substitution_shift.
    now apply substitution_shift.
    now apply IHe3.
Defined.

Definition compose_ren_ren Gamma Gamma' Gamma''
           (r: renaming Gamma Gamma')
           (r': renaming Gamma' Gamma'') : renaming Gamma Gamma'' :=
  fun t v => r' _ (r t v).

Definition compose_ren_sub Gamma Gamma' Gamma''
           (r: renaming Gamma Gamma')
           (s: substitution Gamma' Gamma'') : substitution Gamma Gamma'' :=
  fun t v => s _ (r t v).

Definition compose_sub_ren Gamma Gamma' Gamma''
           (s: substitution Gamma Gamma')
           (r: renaming Gamma' Gamma'') : substitution Gamma Gamma'' :=
  fun t v => apply_renaming r (s t v).

Definition compose_substitutions Gamma Gamma' Gamma''
           (s: substitution Gamma Gamma')
           (s': substitution Gamma' Gamma'') : substitution Gamma Gamma'' :=
  fun t v => apply_substitution s' (s t v).

Ltac subst_ext :=
  intros;
  let ext := (let t := fresh "t" in
             let v := fresh "v" in
             extensionality t; extensionality v;
             dependent destruction v;
             eauto) in
  match goal with
  | [ |- @eq (renaming _ _) _ _ ] =>
    ext
  | [ |- @eq (substitution _ _) _ _ ] =>
    ext
  end.

Ltac do_rewrites E :=
  intros; simpl; rewrite ?E;
  repeat match goal with [H: context[_=_] |- _] => rewrite H end;
  auto.

Definition noop_substitution : forall {Gamma}, substitution Gamma Gamma.
  intros Gamma t v.
  eapply var; eauto.
Defined.

Lemma noop_substitution_shift : forall Gamma t,
    substitution_shift (t := t) (noop_substitution (Gamma := Gamma)) =
    noop_substitution.
Proof.
  subst_ext.
Qed.

Lemma substitute_noop_substitution :
  forall Gamma t (e: expr Gamma t),
    apply_substitution noop_substitution e = e.
Proof.
  induction e; eauto; simpl; rewrite ?noop_substitution_shift; congruence.
Qed.

Lemma shift_ren_ren :
  forall Gamma Gamma' Gamma'' t
    (r: renaming Gamma Gamma')
    (r': renaming Gamma' Gamma''),
    renaming_shift (t:=t) (compose_ren_ren r r') =
    compose_ren_ren (renaming_shift r) (renaming_shift r').
Proof.
  subst_ext.
Qed.

Lemma apply_ren_ren :
  forall Gamma t (e: expr Gamma t) Gamma' Gamma''
    (r: renaming Gamma Gamma')
    (r': renaming Gamma' Gamma'') ,
    apply_renaming (compose_ren_ren r r') e = apply_renaming r' (apply_renaming r e).
Proof.
  induction e; do_rewrites shift_ren_ren.
Qed.

Lemma shift_ren_sub :
  forall Gamma Gamma' Gamma'' t
    (r: renaming Gamma Gamma')
    (s: substitution Gamma' Gamma''),
    substitution_shift (t:=t) (compose_ren_sub r s) =
    compose_ren_sub (renaming_shift r) (substitution_shift s).
Proof.
  subst_ext.
Qed.

Lemma apply_ren_sub :
  forall Gamma t (e: expr Gamma t) Gamma' Gamma''
    (r: renaming Gamma Gamma')
    (s: substitution Gamma' Gamma'') ,
    apply_substitution (compose_ren_sub r s) e = apply_substitution s (apply_renaming r e).
Proof.
  induction e; do_rewrites shift_ren_sub.
Qed.

Lemma shift_sub_ren :
  forall Gamma Gamma' Gamma'' t
    (s: substitution Gamma Gamma')
    (r: renaming Gamma' Gamma''),
    substitution_shift (t:=t) (compose_sub_ren s r) =
    compose_sub_ren (substitution_shift s) (renaming_shift r).
Proof.
  subst_ext.
  unfold compose_sub_ren; simpl.
  unfold expr_shift; simpl.
  rewrite <- ?apply_ren_ren; auto.
Qed.

Lemma apply_sub_ren :
  forall Gamma t (e: expr Gamma t) Gamma' Gamma''
    (s: substitution Gamma Gamma')
    (r: renaming Gamma' Gamma''),
    apply_substitution (compose_sub_ren s r) e = apply_renaming r (apply_substitution s e).
Proof.
  induction e; do_rewrites shift_sub_ren.
Qed.

Lemma shift_sub_sub :
  forall Gamma Gamma' Gamma'' t
    (s: substitution Gamma Gamma')
    (s': substitution Gamma' Gamma''),
    substitution_shift (t:=t) (compose_substitutions s s') =
    compose_substitutions (substitution_shift s) (substitution_shift s').
Proof.
  subst_ext; simpl.
  unfold compose_substitutions; simpl.
  unfold expr_shift; simpl.
  rewrite <- apply_sub_ren, <- apply_ren_sub; auto.
Qed.

Lemma apply_sub_sub :
  forall Gamma t (e: expr Gamma t) Gamma' Gamma''
    (s: substitution Gamma Gamma')
    (s': substitution Gamma' Gamma''),
    apply_substitution (compose_substitutions s s') e =
    apply_substitution s' (apply_substitution s e).
Proof.
  induction e; do_rewrites shift_sub_sub.
Qed.

Definition subst_expr t' (e': expr [] t') t (e: expr [t'] t) : expr [] t :=
  apply_substitution (substitution_shift_expr e' noop_substitution) e.

Definition subst2_expr t1 t2 (e1: expr [] t1) (e2: expr [] t2) t (e: expr [t1;t2] t) : expr [] t :=
  apply_substitution
    (substitution_shift_expr e1 (substitution_shift_expr e2 noop_substitution)) e.

Inductive val Gamma : forall t, expr Gamma t -> Prop :=
| val_nil : val nil
| val_eats : forall (e1 e2 : expr Gamma tree), val e1 -> val e2 -> val (e1 ◁ e2)
| val_abs : forall t1 t2 (e: expr (t1 :: Gamma) t2), val (abs e).
Hint Constructors val.

Inductive step : forall t, expr [] t -> expr [] t -> Prop :=
| step_eats1 : forall (e1 e1' e2 : expr [] tree),
    step e1 e1' ->
    step (e1 ◁ e2) (e1' ◁ e2)
| step_eats2 : forall (e1 e2 e2': expr [] tree),
    val e1 ->
    step e2 e2' ->
    step (e1 ◁ e2) (e1 ◁ e2')
| step_ap1 : forall t1 t2 (e1 e1': expr [] (arrow t1 t2)) e2,
    step e1 e1' ->
    step (app e1 e2) (app e1' e2)
| step_ap2 : forall t1 t2 (e1: expr [] (arrow t1 t2)) e2 e2',
    val e1 ->
    step e2 e2' ->
    step (app e1 e2) (app e1 e2')
| step_apE : forall t1 t2 (e2: expr [] t1) (e: expr [t1] t2),
    val e2 ->
    step (app (abs e) e2) (subst_expr e2 e)
| step_recur1 : forall t (enil : expr [] t) e v v',
    step v v' ->
    step (recur enil e v) (recur enil e v')
| step_recur2 : forall t (enil : expr [] t) e,
    step (recur enil e nil) enil
| step_recur3 : forall t (enil : expr [] t) e v1 v2,
    val v1 -> val v2 ->
    step (recur enil e (v1 ◁ v2)) (subst2_expr (recur enil e v2) (recur enil e v1) e).

Ltac deex :=
  match goal with
  | [ H: exists (varname:_), _ |- _ ] =>
    let name := fresh varname in
    destruct H as [name ?]
  end;
  repeat match goal with
         | [ H: _ /\ _ |- _ ] => destruct H
         end.

Ltac inj_pair2 :=
  match goal with
  | [ H: @existT type ?P ?p _ = existT ?P ?p _ |- _ ] =>
    apply (inj_pair2_eq_dec type type_dec) in H; subst
  end.

Hint Constructors step val.

Theorem progress : forall t (e: expr [] t),
    val e \/
    exists e', step e e'.
Proof.
  intros.
  dependent induction e; subst; eauto.
  - inversion v.
  - edestruct IHe1; repeat deex; eauto.
    edestruct IHe2; repeat deex; eauto.
  - edestruct IHe1; repeat deex; eauto.
    edestruct IHe2; repeat deex; eauto.
    inversion H; repeat inj_pair2; eauto.
  - edestruct IHe3; repeat deex; eauto.
    inversion H; repeat inj_pair2; eauto.
Qed.

Ltac inv_step :=
  match goal with
  | [ H: step _ _ |- _ ] =>
    inversion H; repeat inj_pair2; clear H
  end.

Arguments step {t} e e'.
Hint Constructors clos_refl_trans_1n.
Arguments clos_refl_trans_1n {A} R _ _.
Infix "|->" := (step) (at level 20).
Infix "|->*" := (clos_refl_trans_1n step) (at level 20).

Lemma rt1n_trans' : forall A (R : A -> A -> Prop) x y z,
    clos_refl_trans_1n R x y ->
    clos_refl_trans_1n R y z ->
    clos_refl_trans_1n R x z.
Proof.
  eauto using clos_rt_rt1n, clos_rt1n_rt, rt_trans.
Qed.

Hint Extern 1 (clos_refl_trans_1n _ _ ?x ?y) =>
match goal with
| _ => is_evar x; fail 1
| _ => is_evar y; fail 1
| _ => eapply rt1n_trans'
end.

Lemma step_from_eats : forall e1 e2 e',
    e1 ◁ e2 |->* e' ->
    exists v1 v2, e' = v1 ◁ v2.
Proof.
  intros.
  remember (e1 ◁ e2) as e0.
  generalize dependent e1.
  generalize dependent e2.
  induction H; intros; subst; eauto.
  inv_step; eauto.
Qed.

Definition terminating t (e: expr [] t) : Prop := exists e', e |->* e' /\ val e'.

Fixpoint hereditary_termination t : expr [] t -> Prop :=
  match t with
  | tree => fun e => terminating e
  | arrow t1 t2 => fun e =>
                    exists e0, e |->* abs e0 /\
                          (forall e1: expr [] t1, hereditary_termination e1 ->
                                             hereditary_termination (subst_expr e1 e0))
  end.

Lemma step_respects_eats_1 : forall e1 e1' e2,
    e1 |->* e1' ->
    e1 ◁ e2 |->* e1' ◁ e2.
Proof.
  induction 1; intros; eauto.
Qed.

Lemma step_respects_eats_2 : forall e1 e2 e2',
    val e1 ->
    e2 |->* e2' ->
    e1 ◁ e2 |->* e1 ◁ e2'.
Proof.
  induction 2; intros; eauto.
Qed.

Hint Resolve step_respects_eats_1 step_respects_eats_2.

Definition HT_context Gamma (gamma: substitution Gamma []) :=
  forall t (v: variable Gamma t), hereditary_termination (gamma _ v).

Lemma hereditary_termination_eats_1' : forall (e1 e2: expr [] tree),
    hereditary_termination (e1 ◁ e2) ->
    hereditary_termination e1.
Proof.
  simpl; unfold terminating; intros.
  deex.

  remember (e1 ◁ e2) as e0.
  generalize dependent e2.
  generalize dependent e1.
  induction H; intros; subst.
  - inversion H0; eauto.
  - inv_step; eauto.
    intuition.
    specialize (H e1' e2); intuition.
    deex; eauto.
Qed.

Lemma hereditary_termination_eats_2' : forall (e1 e2: expr [] tree),
    hereditary_termination (e1 ◁ e2) ->
    hereditary_termination e2.
Proof.
  simpl; unfold terminating; intros.
  deex.

  remember (e1 ◁ e2) as e0.
  generalize dependent e2.
  generalize dependent e1.
  induction H; intros; subst.
  - inversion H0; eauto.
  - inv_step; eauto.
    intuition.
    specialize (H e1 e2'); intuition.
    deex; eauto.
Qed.

Lemma hereditary_termination_eats' : forall (e1 e2: expr [] tree),
    hereditary_termination (e1 ◁ e2) ->
    hereditary_termination e1 /\ hereditary_termination e2.
Proof.
  eauto using hereditary_termination_eats_1', hereditary_termination_eats_2'.
Qed.

Ltac simplify :=
  repeat match goal with
         | [ |- forall _, _ ] => intros
         | _ => progress subst
         | [ H: exists _, _ |- _ ] => deex
         | [ H: ?a = ?a |- _ ] => clear H
         | _ => inj_pair2
         | [ H: @hereditary_termination tree _ |- _ ] =>
           simpl in H
         | [ H: @hereditary_termination (arrow _ _) _ |- _ ] =>
           simpl in H
         | _ => progress simpl
         | _ => progress unfold terminating in *
         end.

Definition deterministic A (R: A -> A -> Prop) :=
  forall a a' a'', R a a' -> R a a'' ->
              a' = a''.

Theorem deterministic_clos_refl_R : forall A (R: A -> A -> Prop),
    deterministic R ->
    forall a a' a'',
      clos_refl_trans_1n R a a'' ->
      (forall a''', ~R a'' a''') ->
      R a a' ->
      clos_refl_trans_1n R a' a''.
Proof.
  intros.
  induction H0.
  - exfalso; intuition eauto.
  - erewrite H; eauto.
Qed.

Lemma val_no_step : forall t (e e': expr [] t),
    val e ->
    ~e |-> e'.
Proof.
  induction 1; simplify;
    inversion 1; simplify; intuition eauto.
Qed.

Definition val_dec : forall t (e: expr [] t), {val e} + {~val e}.
Proof.
  induction e; intuition;
    try solve [ right; inversion 1; intuition ].
Defined.

Theorem step_deterministic : forall t, deterministic (step (t:=t)).
Proof.
  unfold deterministic. intros.
  induction H; simplify;
    inversion H0; simplify;
      try pose proof (IHstep _ ltac:(eauto));
      repeat (intuition eauto || simplify);
      solve [ exfalso; match goal with
                       | [ H: val ?e, H': step ?e ?e' |- _ ] =>
                         apply (val_no_step H H')
                       | [ H: step ?e _ |- _ ] =>
                         let Hval := fresh in
                         assert (val e) as Hval by eauto;
                         apply (val_no_step Hval H)
                       end ].
Qed.

Lemma step_clos_refl_R : forall t (e e' e'': expr [] t),
    val e'' ->
    e |->* e'' ->
    e |-> e' ->
    e' |->* e''.
Proof.
  eauto using step_deterministic, val_no_step, deterministic_clos_refl_R.
Qed.

Hint Resolve step_clos_refl_R.

Lemma HT_respects_step : forall t (e e': expr [] t),
    hereditary_termination e ->
    e |-> e' ->
    hereditary_termination e'.
Proof.
  induction t; simplify; eauto.
Qed.

Hint Resolve HT_respects_step.

Lemma HT_prepend_step : forall t (e e': expr [] t),
    hereditary_termination e' ->
    e |-> e' ->
    hereditary_termination e.
Proof.
  simplify.
  generalize dependent e.
  generalize dependent e'.
  induction t; simplify; eauto.
Qed.

Definition rename_substitution Gamma Gamma' (r: renaming Gamma Gamma') : substitution Gamma Gamma' :=
  fun t e => var (r _ e).

Lemma rename_substitution_shift_commute : forall Gamma Gamma' t (r: renaming Gamma Gamma'),
    rename_substitution (renaming_shift (t:=t) r) =
    substitution_shift (rename_substitution r).
Proof.
  intros; extensionality t'; extensionality e.
  dependent induction e; simplify; eauto.
Qed.

Theorem apply_renaming_as_substitution : forall Gamma Gamma' (r: renaming Gamma Gamma'),
    apply_renaming r = apply_substitution (rename_substitution r).
Proof.
  intros.
  extensionality t; extensionality e.
  generalize dependent Gamma'.
  induction e; simplify; f_equal; eauto.
  erewrite ?IHe,
  ?rename_substitution_shift_commute by eauto;
    auto.
  erewrite ?IHe1, ?IHe2, ?IHe3,
  ?rename_substitution_shift_commute by eauto;
    eauto.
Qed.

Arguments renaming_shift {Gamma Gamma'} t gamma [t0] v.
Arguments substitution_shift {Gamma Gamma'} t gamma [t0] v.

Lemma var_shift_expr_noop : forall Gamma t (e: expr Gamma t) (s: substitution Gamma Gamma),
    compose_substitutions (rename_substitution (var_shift t))
                          (substitution_shift_expr e s) =
    s.
Proof.
  intros.
  extensionality t0; extensionality v.
  dependent destruction v; simplify; eauto.
Qed.

Lemma expr_shift_expr_noop : forall Gamma Gamma' (s: substitution Gamma Gamma')
                             t (e: expr Gamma t)
                             t' (e': expr Gamma' t'),
    apply_substitution (substitution_shift_expr e' s)
                       (expr_shift t' e) = apply_substitution s e.
Proof.
  induction e; simplify; f_equal;
    eauto;
    rewrite ?apply_renaming_as_substitution,
    <- ?apply_sub_sub,
    ?rename_substitution_shift_commute,
    <- ?shift_sub_sub,
    ?noop_substitution_shift,
    ?substitute_noop_substitution;
    auto.
Qed.

Lemma compose_substitutions_assoc : forall Gamma Gamma' Gamma'' Gamma'''
                                      (s1: substitution Gamma Gamma')
                                      (s2: substitution Gamma' Gamma'')
                                      (s3: substitution Gamma'' Gamma'''),
    compose_substitutions s1 (compose_substitutions s2 s3) =
    compose_substitutions (compose_substitutions s1 s2) s3.
Proof.
  intros.
  unfold compose_substitutions at 1 3.
  extensionality t; extensionality v.
  rewrite apply_sub_sub.
  reflexivity.
Qed.

Lemma compose_noop_r : forall Gamma Gamma' (s: substitution Gamma Gamma'),
    compose_substitutions s noop_substitution = s.
Proof.
  intros.
  extensionality t; extensionality v.
  unfold compose_substitutions.
  apply substitute_noop_substitution.
Qed.

Lemma compose_shift_expr : forall Gamma Gamma' Gamma'' t e
                             (gamma1: substitution Gamma Gamma')
                             (gamma2: substitution Gamma' Gamma''),
    compose_substitutions (substitution_shift t gamma1) (substitution_shift_expr e gamma2)
    = substitution_shift_expr e (compose_substitutions gamma1 gamma2).
Proof.
  intros.
  extensionality t0; extensionality v.
  unfold compose_substitutions.
  dependent destruction v; simplify; eauto.
  apply expr_shift_expr_noop.
Qed.

Lemma subst_shift :
  forall Gamma (gamma: substitution Gamma []) t1 t2 (e: expr (t1 :: Gamma) t2) e2,
    apply_substitution (substitution_shift_expr e2 gamma) e =
    subst_expr e2 (apply_substitution (substitution_shift t1 gamma) e).
Proof.
  unfold subst_expr.
  intros.
  rewrite <- ?apply_sub_sub.
  rewrite compose_shift_expr.
  rewrite compose_noop_r.
  reflexivity.
Qed.

Lemma subst2_shift :
  forall Gamma (gamma: substitution Gamma []) t1 t2 (e: expr (t1 :: t2 :: Gamma) t2) e1 e2,
    apply_substitution (substitution_shift_expr e1 (substitution_shift_expr e2 gamma)) e =
    subst2_expr e1 e2 (apply_substitution (substitution_shift t1 (substitution_shift t2 gamma)) e).
Proof.
  unfold subst2_expr.
  intros.
  rewrite <- ?apply_sub_sub.
  rewrite ?compose_shift_expr.
  rewrite compose_noop_r.
  reflexivity.
Qed.

Theorem hereditary_termination_terminating :
  forall t (e: expr [] t),
    hereditary_termination e -> terminating e.
Proof.
  intros.
  destruct t; simplify; eauto.
Qed.

Lemma HT_abs :
  forall t1 t2 (e1: expr [] (arrow t1 t2)) e2,
    hereditary_termination e1 ->
    hereditary_termination e2 ->
    hereditary_termination (app e1 e2).
Proof.
  intros.
  edestruct H.
  intuition.
  generalize H0; intros Ht2.
  apply hereditary_termination_terminating in H0.
  destruct H0.
  intuition.
  remember (abs x).
  induction H2; subst; eauto using HT_prepend_step.
  induction H1; eauto using HT_prepend_step.
Qed.

Lemma hereditary_termination_eats : forall e1 e2,
    hereditary_termination e1 ->
    hereditary_termination e2 ->
    hereditary_termination (e1 ◁ e2).
Proof.
  simplify.
  eauto 7 using rt1n_trans'.
Qed.

Hint Resolve HT_abs.

(* TODO: factor better *)
Lemma HT_recur:
  forall Gamma t e1
    (e2 : expr (t :: t :: Gamma) t) (gamma : substitution Gamma []),
    hereditary_termination (apply_substitution gamma e1) ->
    (forall gamma0 : substitution (t :: t :: Gamma) [],
       HT_context gamma0 ->
       hereditary_termination (apply_substitution gamma0 e2)) ->
    forall e : expr [] tree,
      hereditary_termination e ->
      HT_context gamma ->
      hereditary_termination
        (recur (apply_substitution gamma e1)
              (apply_substitution (substitution_shift t (substitution_shift t gamma)) e2) e).
Proof.
  intros Gamma t e1 e2 gamma IHe1 IHe2 e IHe3 H.
  generalize IHe3; intro Ht3.
  eapply hereditary_termination_terminating in Ht3.
  unfold terminating in Ht3; deex.
  induction H0; eauto using HT_prepend_step.
  dependent induction H1; eauto 3 using HT_prepend_step.
  eapply hereditary_termination_eats' in IHe3; intuition.
  specialize (IHval1 _ H0).
  specialize (IHval2 _ H1).
  eapply HT_prepend_step; try eapply step_recur3; eauto.
  rewrite <- subst2_shift.
  eapply IHe2.
  dependent destruction v; simplify; eauto.
  dependent destruction v; simplify; eauto.
Qed.

Hint Resolve HT_recur.

Theorem HT_context_subst : forall Gamma t (e: expr Gamma t) (gamma: substitution Gamma []),
    HT_context gamma -> hereditary_termination (apply_substitution gamma e).
Proof.
  unfold HT_context.
  intros.
  generalize dependent gamma.
  induction e; simplify; eauto.
  - eapply hereditary_termination_eats; eauto.
  - eexists.
    intuition eauto.
    rewrite <- subst_shift.
    eapply IHe.
    intros.
    dependent destruction v; simplify; eauto.
Qed.

Hint Resolve substitute_noop_substitution.

Theorem exprs_ht :
  forall t (e: expr [] t),
    hereditary_termination e.
Proof.
  intros.
  replace e with (apply_substitution noop_substitution e) by auto.
  eapply HT_context_subst.
  unfold HT_context; intros.
  inversion v.
Qed.

Theorem exprs_terminating :
  forall t (e: expr [] t),
    terminating e.
Proof.
  auto using hereditary_termination_terminating, exprs_ht.
Qed.

Definition eval_context Gamma := substitution Gamma [].

Ltac break_match :=
  match goal with
  | [ |- context[match ?x with _ => _ end] ] => destruct x
  end.

Ltac solve_by_inversion :=
  match goal with
  | [ H : _ |- _ ] => solve [ inversion H ]
  end.

Fixpoint step_fn t (e: expr [] t) : expr [] t + {val e}.
  refine (
      match e with
      | var v => _
      | nil => inright ltac:(auto)
      | e1 ◁ e2 =>
        match step_fn _ e1 with
        | inleft e1' => inleft (e1' ◁ e2)
        | inright e1_val =>
          match step_fn _ e2 with
          | inleft e2' => inleft (e1 ◁ e2')
          | inright e2_val => inright ltac:(auto)
          end
        end
      | abs _ => inright ltac:(auto)
      | ef @ ex =>
        match step_fn _ ef with
        | inleft ef' => inleft (ef' @ ex)
        | inright ef_val =>
          match step_fn _ ex with
          | inleft ex' => inleft (ef @ ex')
          | inright ex_val =>
            match ef with
            | var v => _
            | nil => tt
            | eats _ _ => tt
            | abs e' => fun _ ex _ => inleft (subst_expr ex e')
            | app _ _ => _
            | recur _ _ _ => _
            end ef_val ex ex_val
          end
        end
      | recur ez ef et =>
        match step_fn _ et with
        | inleft et' => inleft (recur ez ef et')
        | inright et_val =>
          match et with
          | var v => _
          | nil => fun _ => inleft ez
          | eats el er => fun _ => inleft (subst2_expr (recur ez ef el) (recur ez ef er) ef)
          | abs _ => tt
          | app _ _ => _
          | recur _ _ _ => _
          end et_val
        end
      end); try abstract (inversion v || break_match; try constructor; exfalso; solve_by_inversion ).
  (* Why does the [refine] not leave these as goals?? *)
  Grab Existential Variables.
  all: clear step_fn; auto.
  abstract (inversion v).
Defined.

Theorem step_fn_val : forall t (e: expr [] t),
    val e ->
    exists Hv, step_fn e = inright Hv.
Proof.
  induction 1; repeat deex; simpl; eexists; try reflexivity.
  - rewrite H2, H1. reflexivity.
Qed.

Theorem step_fn_correct : forall t (e e': expr [] t),
    step e e' -> step_fn e = inleft e'.
Proof.
  dependent induction e; simpl; intros; try solve_by_inversion.
  - dependent destruction H.
    + specialize (IHe1 _ JMeq_refl JMeq_refl _ H).
      rewrite IHe1.
      reflexivity.
    + specialize (IHe2 _ JMeq_refl JMeq_refl _ H0).
      rewrite IHe2.
      destruct (step_fn_val H).
      rewrite H1.
      reflexivity.
  - dependent destruction H.
    (* etc etc *)
Admitted.

Inductive Tree := Nil | Eats (t e: Tree).

Notation "⋅" := Nil.
Infix "△" := Eats (at level 16, left associativity).

Fixpoint type_denote (t: type) : Type :=
  match t with
  | tree => Tree
  | arrow t1 t2 => type_denote t1 -> type_denote t2
  end.

Definition denote_context Gamma :=
  forall t (v: variable Gamma t), type_denote t.

Definition empty_denote_context : denote_context [] :=
  fun t v => match v in (variable m t0) return (match m with
                                             | [] => type_denote t
                                             | _ :: _ => unit
                                             end) with
          | var_here _ _ => tt
          | var_outer _ _ => tt
          end.

Program Definition denote_context_insert
        Gamma t
        (x: type_denote t)
        (c: denote_context Gamma) : denote_context (t :: Gamma) :=
  fun t' (v: variable (t :: Gamma) t') =>
    match v with
      | var_here _ _ => x
      | var_outer _ v' => c _ v'
    end.

Fixpoint Tree_rec_nondep {T: Type} (z: T) (f: T -> T -> T) (t: Tree) : T :=
  match t with
  | ⋅ => z
  | t1 △ t2 => f (Tree_rec_nondep z f t1) (Tree_rec_nondep z f t2)
  end.

Fixpoint expr_denote Gamma (c: denote_context Gamma) t (e: expr Gamma t) : type_denote t :=
  match e with
  | var v => c _ v
  | nil => ⋅
  | eats e1 e2 => expr_denote c e1 △ expr_denote c e2
  | abs e => fun x => expr_denote (denote_context_insert x c) e
  | app e1 e2 => (expr_denote c e1) (expr_denote c e2)
  | @recur _ t ez ef et => Tree_rec_nondep
                            (expr_denote c ez)
                            (fun x1 x2 => (expr_denote
                                          (denote_context_insert x1 (denote_context_insert x2 c))
                                          ef))
                            (expr_denote c et)
  end.

Arguments var_here {_} {_}.
Arguments var_outer {_} {_} {_} _.

Definition x0 {Gamma t0} := @var (t0 :: Gamma) t0 var_here.
Definition x1 {Gamma t0 t1} := @var (t0 :: t1 :: Gamma) t1 (var_outer var_here).
Definition x2 {Gamma t0 t1 t2} := @var (t0 :: t1 :: t2 :: Gamma) t2 (var_outer (var_outer var_here)).

Definition id {Gamma} t := lambda x0 : expr Gamma (t --> t).
Definition K {Gamma} t1 t2 := lambda lambda x1 : expr Gamma (t1 --> t2 --> t1).
Definition flip {Gamma} := lambda recur nil (x1 ◁ x0) x0 : expr Gamma (tree --> tree).

Eval lazy in expr_denote empty_denote_context (id tree).
Eval lazy in expr_denote empty_denote_context (K tree (tree --> tree)).
Eval lazy in expr_denote empty_denote_context flip.
Eval lazy in expr_denote empty_denote_context (flip @ (nil ◁ nil ◁ nil)).

Notation succ := (fun e => e ◁ nil).
Notation _0 := nil.
Notation _1 := (succ _0).
Notation _2 := (succ _1).
Notation _3 := (succ _2).
Notation _4 := (succ _3).

Definition plus := lambda lambda recur x0 (succ x0) x1 : expr [] (tree --> tree --> tree).

Eval lazy in expr_denote empty_denote_context (plus @ _2 @ _1).

Fixpoint encode_var Gamma t (v: variable Gamma t) : Tree :=
  match v with
  | var_here => ⋅
  | var_outer v' => encode_var v' △ ⋅
  end.

Fixpoint encode_expr Gamma t (e: expr Gamma t) : Tree :=
  match e with
  | var v => ⋅ △ encode_var v
  | nil => ⋅
  | eats e1 e2 => (⋅ △ (encode_expr e1 △ encode_expr e2)) △ ⋅
  | abs e' => (⋅ △ ⋅) △ encode_expr e'
  | app e1 e2 => (encode_expr e1 △ encode_expr e2) △ ⋅ △ ⋅
  | recur ez ef et => encode_expr ez △ encode_expr ef △ (⋅ △ ⋅) △ encode_expr et
  end.

Eval lazy in encode_expr (abs (app x0 x1)).
Eval lazy in encode_expr (abs (app x0 x2)).
Definition omega_enc := ⋅ △ ⋅ △ (⋅ △ ⋅ △ (⋅ △ ⋅) △ ⋅ △ ⋅).
Definition Omega_enc := (omega_enc △ omega_enc) △ ⋅ △ ⋅.

Theorem encode_var_injective : forall Gamma t (v1 v2: variable Gamma t),
    encode_var v1 = encode_var v2 -> v1 = v2.
Proof.
  induction v1; intros; dependent destruction v2; try discriminate.
  - auto.
  - simpl in H.
    inversion H.
    f_equal.
    auto.
Qed.
Hint Resolve encode_var_injective.

(*
Theorem encode_expr_injective : forall Gamma t (e1 e2: expr Gamma t),
    encode_expr e1 = encode_expr e2 -> e1 = e2.
Proof.
  induction e1; intros; dependent destruction e2; try discriminate;
    simpl in H; inversion H; f_equal; auto.
  (* Oops, only true for type-erased version... *)
Abort.
*)

Fixpoint encoded_context_lookup (n: Tree) (c: list Tree) : option Tree :=
  match n, c with
  | ⋅, v :: _ => Some v
  | n' △ ⋅, _ :: c' => encoded_context_lookup n' c'
  | _, _ => None
  end.

(* TODO: does our interpreter need type tags at runtime?
   otherwise it can't do most runtime type checking, but maybe it doesn't need to *)
Fixpoint eval_encoded_expr (fuel: nat) (c: list Tree) (e: Tree) {struct fuel} : option Tree :=
  match fuel with
  | O => None
  | S fuel' =>
    match e with
    | (* var v *) ⋅ △ v => encoded_context_lookup v c
    | (* nil *) ⋅ => Some ⋅
    | (* eats e1 e2 *) (⋅ △ (e1 △ e2)) △ ⋅ =>
      match eval_encoded_expr fuel' c e1, eval_encoded_expr fuel' c e2 with
      | Some t1, Some t2 => Some (t1 △ t2)
      | _, _ => None
      end
    | (* abs e' *) (⋅ △ ⋅) △ e' => Some e' (* no type tags -> ambiguous with tree values *)
    | (* app ef ex *) (ef △ ex) △ ⋅ △ ⋅ =>
      match eval_encoded_expr fuel' c ef, eval_encoded_expr fuel' c ex with
      | Some f, Some x => eval_encoded_expr fuel' (x :: c) f
      | _, _ => None
      end
    | (* recur ez f et *) ez △ f △ (⋅ △ ⋅) △ et =>
      match eval_encoded_expr fuel' c et with
      | Some t => Tree_rec_nondep (eval_encoded_expr fuel' c ez)
                                 (fun (t1 t2: option Tree) =>
                                    match t1, t2 with
                                    | Some t1', Some t2' =>
                                      eval_encoded_expr fuel' (t1' :: t2' :: c) f
                                    | _, _ => None
                                    end)
                                 t
      | None => None
      end
    | _ => None
    end
  end.

Eval lazy in expr_denote empty_denote_context (app flip (nil ◁ nil ◁ nil)).
Eval lazy in eval_encoded_expr 4 [] (encode_expr (app flip (nil ◁ nil ◁ nil))).

Lemma val_eats_1 : forall Gamma (e1 e2: expr Gamma tree), val (e1 ◁ e2) -> val e1.
Proof.
  intros.
  inversion H; auto.
Qed.

Lemma val_eats_2 : forall Gamma (e1 e2: expr Gamma tree), val (e1 ◁ e2) -> val e2.
Proof.
  intros.
  inversion H; auto .
Qed.

(*
Definition tree_val (x: expr [] tree) (Hv: val x) : Tree.
  remember tree as t.
  induction x; try abstract solve [ discriminate | exfalso; inversion Hv ].
  - exact Nil.
  - exact (Eats (IHx1 Heqt (val_eats_1 Hv)) (IHx2 Heqt (val_eats_2 Hv))).
Defined.

Theorem tree_val_correct : forall (x: expr [] tree) (Hv: val x),
    tree_val Hv = expr_denote empty_denote_context x.
Proof.
*)

(*
(* see ~/dsrc/coq/Lisp.v see *)
Theorem eval_encoded_expr_S_fuel : forall c e fuel x,
    eval_encoded_expr fuel c e = Some x -> eval_encoded_expr (S fuel) c e = Some x.
Proof.
  induction fuel; simpl; auto; intros; try discriminate.
  destruct e; simpl in *; auto.
  destruct e1; simpl in *; auto.
  destruct e1_1; simpl in *; auto.
    destruct e1_2; simpl in *; auto.
    destruct e2; simpl in *; auto.
    destruct (eval_encoded_expr fuel c e1_2_1) eqn:He121; try discriminate.
    destruct (eval_encoded_expr fuel c e1_2_2) eqn:He122; try discriminate.
    clear IHfuel.
    inversion H; clear H; subst.
Admitted.

Theorem eval_encoded_expr_more_fuel : forall c e fuel fuel' x,
    fuel' >= fuel ->
    eval_encoded_expr fuel c e = Some x -> eval_encoded_expr fuel' c e = Some x.
Proof.
  induction 1; auto using eval_encoded_expr_S_fuel.
Qed.

Hint Resolve Nat.le_max_l Nat.le_max_r.

Definition pop_context Gamma t0 (c: encoding_context (t0 :: Gamma)) : encoding_context Gamma :=
  fun t (v: variable Gamma t) => c _ (var_outer v).

Fixpoint encode_context Gamma : forall (c: encoding_context Gamma), list Tree :=
  match Gamma with
  | [] => fun c => []
  | t :: Gamma' => fun c => encode_expr (c _ var_here) :: encode_context (pop_context c)
  end.

Definition encoding_context_denote Gamma (c: encoding_context Gamma) : denote_context Gamma :=
  fun t (v: variable Gamma t) => expr_denote empty_denote_context (c _ v).

Theorem eval_encoded_complete' : forall Gamma t (c: encoding_context Gamma) (e e': expr Gamma t) fuel,
    apply_substitution c e |->* apply_substitution c e' ->
    eval_encoded_expr fuel (encode_context c) (encode_expr e) = Some (expr_denote (encoding_context_denote c) e').
Proof.

Theorem eval_encoded_complete : forall (e e': expr [] tree),
    e |->* e' ->
    exists fuel, eval_encoded_expr fuel [] (encode_expr e) = Some (expr_denote empty_denote_context e').
Proof.
  induction 1; simpl.
  - dependent induction x; simpl; try solve [ inversion v ].
    + exists 1. auto.
    + specialize (IHx1 x3 JMeq_refl eq_refl JMeq_refl); deex.
      specialize (IHx2 x4 JMeq_refl eq_refl JMeq_refl); deex.
      exists (1 + max fuel fuel0); simpl.
      apply eval_encoded_expr_more_fuel with (fuel' := max fuel fuel0) in H; [ | auto ].
      apply eval_encoded_expr_more_fuel with (fuel' := max fuel fuel0) in H0; [ | auto ].
      rewrite H, H0.
      reflexivity.
    + specialize (IHx1 x3 JMeq_refl eq_refl JMeq_refl); deex.

*)


(* This example (found by coqchk) checks that an inductive cannot be
   polymorphic if its constructors induce upper universe constraints.
   Here: I cannot be polymorphic because its type is less than the
   type of the argument of impl. *)

Definition Type1 := Type.
Definition Type3 : Type1 := Type.                       (* Type3 < Type1 *)
Definition Type4 := Type.
Definition impl (A B:Type3) : Type4 := A->B.           (* Type3 <= Type4 *)
Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B).
    (* Type(6) <= Type(7)     because I contains, via C, elements in B
       Type(7) <=  Type3      because (I B) is argument of impl
       Type(4) <=  Type(7)    because type of C less than I (see remark below)

       where Type(7) is the auxiliary level used to infer the type of I
*)

(* We cannot enforce Type1 < Type(6) while we already have
   Type(6) <= Type(7) < Type3 < Type1 *)
Definition J := I Type1.

(* Open question: should the type of an inductive be the max of the
   types of the _arguments_ of its constructors (here B and Prop,
   after unfolding of impl), or of the max of types of the
   constructors itself (here B -> impl Prop (I B)), as done above. *)


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 Extended
       (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 "tlam" and "tylam" due to a technical limitation.

*)

Lemma ortho_ax_sym : forall A B, OrthoAx A B -> OrthoAx B A.
Proof.
  intros.
  destruct H as [a [b c]].
  unfold OrthoAx.
  auto.
Qed.

Lemma ortho_and_l : forall Gamma t1 t2 t0, Ortho Gamma (And t1 t2) t0 -> Ortho Gamma t1 t0.
Proof.
  intros.
  dependent induction H; auto.
  - inversion H1; subst.
    apply OVarSym with (A := A); auto.
    apply sound_sub in H0.
    destruct H0.
    inversion H0; subst.
    apply complete_sub.
    eexists; apply H7.
    inversion H3.
    inversion H3.
  - orthoax_inv_l.
Qed.

Lemma ortho_and_r : forall Gamma t1 t2 t0, Ortho Gamma (And t1 t2) t0 -> Ortho Gamma t2 t0.
Proof.
  intros.
  dependent induction H; auto.
  - inversion H1; subst.
    apply OVarSym with (A := A); auto.
    apply sound_sub in H0.
    destruct H0.
    inversion H0; subst.
    apply complete_sub.
    eexists; apply H9.
    inversion H3.
    inversion H3.
  - orthoax_inv_l.
Qed.

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).

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.
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.

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.
    apply Ortho_sym.
    apply ortho_and_l with (t2 := t2); auto.
    now apply Ortho_sym.
    apply IHsub2 with (Gamma := Gamma); auto.
    eexists; apply H0.
    apply Ortho_sym.
    apply ortho_and_r with (t1 := t1); auto.
    now apply Ortho_sym.
  - 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.
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.
  - 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.
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.
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.
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.
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.
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.
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.
  - 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.
  - apply_fresh WFForAll as x.
    apply H1.
    not_in_L x.
    auto.
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_Lam as x; auto.
    apply H0; not_in_L x.
  - apply_fresh PTerm_TLam as x.
    apply H1; 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;
    pose (H0 _ Ha) as HInv;
    inversion HInv; auto.
  - pick_fresh x.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H1 in Ha.
    now inversion Ha.
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.
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 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.
  subst; inversion H.
(* Case TLam *)
- inversion H2; subst.
  inversion H3.
  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.
Qed.

Lemma coercions_produce_terms :
  forall E A B, sub A B E -> STTerm E.
Proof.
  intros.
  induction H.
  (* Case SInt *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SFun *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_Lam as y; cbn.
    apply STTerm_App.
    repeat rewrite <- open_rec_term; assumption.
    apply STTerm_App.
    apply STTerm_Var.
    apply STTerm_App; [ repeat rewrite <- open_rec_term; auto | apply STTerm_Var ].
  (* Case SAnd1 *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply STTerm_Pair.
    apply STTerm_App; repeat rewrite <- open_rec_term; auto.
    rewrite <- open_rec_term; auto.
  (* Case SAnd2 *)
  - apply and_coercion_proj1_term with (t0 := t0) (c := c); auto.
    assert (Ha : Sub t1 t0) by (unfold Sub; eauto).
    now apply sub_lc in Ha as [Ha1 Ha2].
  (* Case SAnd3 *)
  - apply and_coercion_proj2_term with (t0 := t0) (c := c); auto.
    assert (Ha : Sub t2 t0) by (unfold Sub; eauto).
    now apply sub_lc in Ha as [Ha1 Ha2].
  (* Case SVar *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SForAll *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_TLam as y; cbn.
    apply STTerm_App; auto.
    assert (Ha : not (In y L)) by (not_in_L y).
    apply H0 in Ha.
    rewrite open_comm_open_typ_term.
    rewrite <- open_rec_term; auto.
  (* Case STop *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
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.
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.
  (* 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.
  (* 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.
Qed.

End Extended.


Require Export XR_R1_neq_R0.
Require Export XR_Rinv_r.
Require Export XR_Rmult_eq_reg_l.
Require Export XR_Rmult_eq_reg_r.
Require Export XR_Rmult_0_l.

Local Open Scope R_scope.

Lemma Rinv_neq_0_compat : forall r, r <> R0 -> / r <> R0.
Proof.
  intros x hneq.
  unfold not.
  intro heq.
  apply hneq.
  pattern x ; rewrite <- Rmult_1_l.
  rewrite <- Rinv_l with x.
  {
    rewrite heq.
    rewrite Rmult_0_l.
    rewrite Rmult_0_l.
    reflexivity.
  }
  { exact hneq. }
Qed.