Require Import UVal.UVal.
Require Import Utlc.LemmasScoping.
Require Import Utlc.SpecSyntax.
Require Import Stlc.SpecSyntax.
Require Import Stlc.Inst.
Require Import Stlc.SpecTyping.
Require Import Stlc.SpecEvaluation.
Require Import Stlc.LemmasTyping.
Require Import Stlc.LemmasEvaluation.
Require Import Stlc.CanForm.
Require Import Db.Lemmas.
Require Import Db.WellScoping.
Require Import LogRel.LR.
Require Import LogRel.LemmasLR.
Require Import LogRel.LemmasIntro.
Require Import LogRel.LemmasInversion.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.PseudoType.

Require Omega.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushRepEmulEmbed;
     repeat crushUtlcSyntaxMatchH;
     repeat crushUtlcScopingMatchH;
     split;
     trivial;
     crushTyping;
     try crushOfType;
     subst*);
  try discriminate; try Omega.omega;
  eauto with eval;
  repeat crushStlcSyntaxMatchH (* remove apTm's again *).

Fixpoint downgrade (n : nat) (d : nat) :=
  abs (UVal (n + d))
      (match n with
         | 0 => unkUVal 0
         | S n =>
           caseUVal (var 0)
                    (unkUVal (S n))
                    (inUnit n (var 0))
                    (inBool n (var 0))
                    (inProd n
                            (pair
                               (app (downgrade n d) (proj₁ (var 0)))
                               (app (downgrade n d) (proj₂ (var 0)))))
                    (inSum n
                           (caseof (var 0)
                                   (inl (app (downgrade n d) (var 0)))
                                   (inr (app (downgrade n d) (var 0)))))
                    (inArr n
                           (abs (UVal n)
                                (app (downgrade n d)
                                     (app (var 1)
                                          (app (upgrade n d) (var 0))))))
       end)
with
upgrade (n : nat) (d : nat) :=
  abs (UVal n)
      (match n with
         | 0 => unkUVal d
         | S n =>
           caseUVal (var 0)
                    (unkUVal (S n + d))
                    (inUnit (n + d) (var 0))
                    (inBool (n + d) (var 0))
                    (inProd (n + d)
                            (pair
                               (app (upgrade n d) (proj₁ (var 0)))
                               (app (upgrade n d) (proj₂ (var 0)))))
                    (inSum (n + d)
                           (caseof (var 0)
                                   (inl (app (upgrade n d) (var 0)))
                                   (inr (app (upgrade n d) (var 0)))))
                    (inArr (n + d)
                           (abs (UVal (n + d))
                                (app (upgrade n d)
                                     (app (var 1)
                                          (app (downgrade n d) (var 0))))))
       end).

Lemma upgrade_T {Γ n d} :
  ⟪ Γ ⊢ upgrade n d : UVal n ⇒ UVal (n + d) ⟫
with
downgrade_T {Γ n d} :
  ⟪ Γ ⊢ downgrade n d : UVal (n + d) ⇒ UVal n ⟫.
Proof.
  (* can I combine eauto and crushTyping somehow? *)
  - induction n; unfold upgrade, downgrade;
    eauto with typing uval_typing.
  - induction n; unfold upgrade, downgrade;
    eauto with typing uval_typing.
Qed.

Lemma upgrade_T1 {Γ n} :
  ⟪ Γ ⊢ upgrade n 1 : UVal n ⇒ UVal (S n) ⟫.
Proof.
  replace (S n) with (n + 1) by Omega.omega.
  eauto using upgrade_T.
Qed.

Lemma downgrade_T1 {Γ n} :
  ⟪ Γ ⊢ downgrade n 1 : UVal (S n) ⇒ UVal n ⟫.
Proof.
  replace (S n) with (n + 1) by Omega.omega.
  eauto using downgrade_T.
Qed.

Hint Resolve upgrade_T1 : uval_typing.
Hint Resolve downgrade_T1 : uval_typing.

Lemma upgrade_closed {n d} :
  ⟨ 0 ⊢ upgrade n d ⟩.
Proof.
  enough (⟪ empty ⊢ upgrade n d : UVal n ⇒ UVal (n + d) ⟫) as ty by eapply (wt_implies_ws ty).
  eapply upgrade_T.
Qed.

Lemma downgrade_closed {n d} :
  ⟨ 0 ⊢ downgrade n d ⟩.
Proof.
  enough (⟪ empty ⊢ downgrade n d : UVal (n + d) ⇒ UVal n ⟫) as ty by eapply (wt_implies_ws ty).
  eapply downgrade_T.
Qed.

Lemma upgrade_sub {n d γ} : (upgrade n d)[γ] = upgrade n d.
Proof.
  apply wsClosed_invariant.
  eapply upgrade_closed.
Qed.

Lemma downgrade_sub {n d γ} : (downgrade n d)[γ] = downgrade n d.
Proof.
  apply wsClosed_invariant.
  eapply downgrade_closed.
Qed.

Lemma downgrade_value {n d} : Value (downgrade n d).
Proof.
  destruct n; simpl; trivial.
Qed.

Lemma upgrade_value {n d} : Value (upgrade n d).
Proof.
  destruct n; simpl; trivial.
Qed.

Lemma downgrade_zero_eval {d v} : Value v → app (downgrade 0 d) v -->* unkUVal 0.
Proof.
  intros vv.
  unfold downgrade.
  eapply evalStepStar. eapply eval₀_to_eval. crush.
  simpl; eauto with eval.
Qed.

Lemma upgrade_zero_eval {d v} : Value v → app (upgrade 0 d) v -->* unkUVal d.
Proof.
  intros vv.
  unfold upgrade.
  eapply evalStepStar. eapply eval₀_to_eval. crush.
  destruct d; simpl; eauto with eval.
Qed.

Lemma downgrade_eval_unk {n d} : app (downgrade n d) (unkUVal (n + d)) -->* unkUVal n.
Proof.
  assert (vv : Value (unkUVal (n + d))) by apply unkUVal_Value.
  destruct n; simpl.
  - eapply evalStepStar. eapply eval₀_to_eval. crush.
    simpl; eauto with eval.
  - change _ with (Value (inl unit)) in vv.
    eapply evalStepStar. eapply eval₀_to_eval. crush.
    rewrite -> ?(caseUVal_sub (beta1 _)); simpl.
    change (inl unit) with (unkUVal (S n)) at 1.
    eapply caseUVal_eval_unk.
Qed.

Lemma upgrade_eval_unk {n d} : app (upgrade n d) (unkUVal n) -->* unkUVal (n + d).
Proof.
  assert (vv : Value (unkUVal n)) by apply unkUVal_Value.
  destruct n; simpl.
  - eapply evalStepStar. eapply eval₀_to_eval. crush.
    destruct d; simpl; eauto with eval.
  - change _ with (Value (inl unit)) in vv.
    eapply evalStepStar. eapply eval₀_to_eval. crush.
    rewrite -> ?(caseUVal_sub (beta1 _)); simpl.
    change (inl unit) with (unkUVal (S n)) at 1.
    eapply caseUVal_eval_unk.
Qed.

Lemma downgrade_eval_inUnit {n d v} :
  Value v → app (downgrade (S n) d) (inUnit (n + d) v) -->* inUnit n v.
Proof.
  intros vv.
  assert (Value (inUnit (n + d) v)) by (simpl; crush).
  unfold downgrade.
  eapply evalStepStar. eapply eval₀_to_eval. crush.
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl.
  eapply evalStepTrans. eapply caseUVal_eval_unit; crush.
  simpl; crush.
Qed.

Lemma upgrade_eval_inUnit {n d v} :
  Value v → app (upgrade (S n) d) (inUnit n v) -->* inUnit (n + d) v.
Proof.
  intros vv.
  assert (Value (inUnit (n + d) v)) by (simpl; crush).
  unfold upgrade.
  eapply evalStepStar. eapply eval₀_to_eval. crush.
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl.
  eapply evalStepTrans. eapply caseUVal_eval_unit; crush.
  simpl; crush.
Qed.

Lemma downgrade_eval_inBool {n d v} :
  Value v → app (downgrade (S n) d) (inBool (n + d) v) -->* inBool n v.
Proof.
  intros vv.
  assert (Value (inBool (n + d) v)) by (simpl; crush).
  unfold downgrade.
  eapply evalStepStar. eapply eval₀_to_eval. crush.
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl.
  eapply evalStepTrans. eapply caseUVal_eval_bool; crush.
  simpl; crush.
Qed.

Lemma upgrade_eval_inBool {n d v} :
  Value v → app (upgrade (S n) d) (inBool n v) -->* inBool (n + d) v.
Proof.
  intros vv.
  assert (Value (inBool (n + d) v)) by (simpl; crush).
  unfold upgrade.
  eapply evalStepStar. eapply eval₀_to_eval. crush.
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl.
  eapply evalStepTrans. eapply caseUVal_eval_bool; crush.
  simpl; crush.
Qed.

Lemma downgrade_eval_inProd {n d v₁ v₂ v₁' v₂'} :
  Value v₁ → Value v₂ → Value v₁' → Value v₂' →
  app (downgrade n d) v₁ -->* v₁' →
  app (downgrade n d) v₂ -->* v₂' →
  app (downgrade (S n) d) (inProd (n + d) (pair v₁ v₂)) -->* inProd n (pair v₁' v₂').
Proof.
  intros vv₁ vv₂ vv₁' vv₂' es₁ es₂.
  assert (Value (inProd (n + d) (pair v₁ v₂))) by (simpl; crush).
  unfold downgrade.
  assert (Value (downgrade n d)) by apply downgrade_value.

  (* beta-reduce *)
  eapply evalStepStar. eapply eval₀_to_eval; crush.
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl; crush.
  rewrite -> ?upgrade_sub, ?downgrade_sub.

  (* evaluate UVal pattern match *)
  eapply evalStepTrans. eapply caseUVal_eval_prod; crush.
  (* downgrade under sub... *)
  simpl; crush.
  rewrite -> ?downgrade_sub.

  (* first projection *)
  eapply evalStepStar.
  assert (ep₁ : proj₁ (pair v₁ v₂) -->₀ v₁) by crush.
  eapply (eval_from_eval₀ ep₁); inferContext; crush; simpl.

  (* recursive call 1 *)
  eapply evalStepTrans. eapply (evalstar_ctx' es₁); inferContext; crush.

  (* second projection *)
  eapply evalStepStar.
  assert (ep₂ : proj₂ (pair v₁ v₂) -->₀ v₂) by crush.
  eapply (eval_from_eval₀ ep₂); inferContext; crush; simpl.

  (* recursive call 2 *)
  eapply evalStepTrans. eapply (evalstar_ctx' es₂); inferContext; crush.

  (* ... and we're done. *)
  simpl; crush.
Qed.

Lemma upgrade_eval_inProd {n d v₁ v₂ v₁' v₂'} :
  Value v₁ → Value v₂ → Value v₁' → Value v₂' →
  app (upgrade n d) v₁ -->* v₁' →
  app (upgrade n d) v₂ -->* v₂' →
  app (upgrade (S n) d) (inProd n (pair v₁ v₂)) -->* inProd (n + d) (pair v₁' v₂').
Proof.
  intros vv₁ vv₂ vv₁' vv₂' es₁ es₂.
  assert (Value (inProd (n + d) (pair v₁ v₂))) by (simpl; crush).
  unfold upgrade.
  assert (Value (upgrade n d)) by apply upgrade_value.

  (* beta-reduce *)
  eapply evalStepStar. eapply eval₀_to_eval; crush.
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl; crush.
  rewrite -> ?upgrade_sub, ?upgrade_sub.

  (* evaluate UVal pattern match *)
  eapply evalStepTrans. eapply caseUVal_eval_prod; crush.
  (* upgrade under sub... *)
  simpl; crush.
  rewrite -> ?upgrade_sub.

  (* first projection *)
  eapply evalStepStar.
  assert (ep₁ : proj₁ (pair v₁ v₂) -->₀ v₁) by crush.
  eapply (eval_from_eval₀ ep₁); inferContext; crush; simpl.

  (* recursive call 1 *)
  eapply evalStepTrans. eapply (evalstar_ctx' es₁); inferContext; crush.

  (* second projection *)
  eapply evalStepStar.
  assert (ep₂ : proj₂ (pair v₁ v₂) -->₀ v₂) by crush.
  eapply (eval_from_eval₀ ep₂); inferContext; crush; simpl.

  (* recursive call 2 *)
  eapply evalStepTrans. eapply (evalstar_ctx' es₂); inferContext; crush.

  (* ... and we're done. *)
  simpl; crush.
Qed.

Lemma downgrade_eval_inSum {n d v v' va va'} :
  Value v → Value v' →
  (va = inl v ∧ va' = inl v') ∨ (va = inr v ∧ va' = inr v') →
  app (downgrade n d) v -->* v' →
  app (downgrade (S n) d) (inSum (n + d) va) -->* inSum n va'.
Proof.
  intros vv vv' eqs es.

  unfold downgrade.
  destruct eqs as [(? & ?)|(? & ?)]; subst;
  (* beta-reduce *)
  (eapply evalStepStar; [eapply eval₀_to_eval; crush|]);
    rewrite -> ?(caseUVal_sub (beta1 _)); simpl; crush;
    rewrite -> ?upgrade_sub, ?downgrade_sub;

    (* evaluate UVal pattern match *)
    (eapply evalStepTrans; [eapply caseUVal_eval_sum; crush|]);
    (* downgrade under sub... *)
    simpl; crush;
    rewrite -> ?downgrade_sub;

    (* caseof *)
    [assert (ec : caseof (inl v) (inl (app (downgrade n d) (var 0))) (inr (app (downgrade n d) (var 0))) -->₀ ((inl (app (downgrade n d) (var 0))) [beta1 v])) by crush
    |assert (ec : caseof (inr v) (inl (app (downgrade n d) (var 0))) (inr (app (downgrade n d) (var 0))) -->₀ ((inr (app (downgrade n d) (var 0))) [beta1 v])) by crush
    ];
    (eapply evalStepStar;
     [eapply (eval_from_eval₀ ec); inferContext; crush|]);
    crushStlcSyntaxMatchH (* why is this needed? *);
    rewrite -> ?downgrade_sub;

    (* recursive call *)
    (eapply evalStepTrans; [eapply (evalstar_ctx' es); inferContext; crush|]);

    (* ... and we're done. *)
    simpl; crush.
Qed.

Lemma upgrade_eval_inSum {n d v v' va va'} :
  Value v → Value v' →
  (va = inl v ∧ va' = inl v') ∨ (va = inr v ∧ va' = inr v') →
  app (upgrade n d) v -->* v' →
  app (upgrade (S n) d) (inSum n va) -->* inSum (n + d) va'.
Proof.
  intros vv vv' eqs es.

  unfold upgrade.
  destruct eqs as [(? & ?)|(? & ?)]; subst;
  (* beta-reduce *)
  (eapply evalStepStar; [eapply eval₀_to_eval; crush|]);
    rewrite -> ?(caseUVal_sub (beta1 _)); simpl; crush;
    rewrite -> ?upgrade_sub, ?upgrade_sub;

    (* evaluate UVal pattern match *)
    (eapply evalStepTrans; [eapply caseUVal_eval_sum; crush|]);
    (* upgrade under sub... *)
    simpl; crush;
    rewrite -> ?upgrade_sub;

    (* caseof *)
    [assert (ec : caseof (inl v) (inl (app (upgrade n d) (var 0))) (inr (app (upgrade n d) (var 0))) -->₀ ((inl (app (upgrade n d) (var 0))) [beta1 v])) by crush
    |assert (ec : caseof (inr v) (inl (app (upgrade n d) (var 0))) (inr (app (upgrade n d) (var 0))) -->₀ ((inr (app (upgrade n d) (var 0))) [beta1 v])) by crush
    ];
    (eapply evalStepStar;
     [eapply (eval_from_eval₀ ec); inferContext; crush|]);
    crushStlcSyntaxMatchH (* why is this needed? *);
    rewrite -> ?upgrade_sub;

    (* recursive call *)
    (eapply evalStepTrans; [eapply (evalstar_ctx' es); inferContext; crush|]);

    (* ... and we're done. *)
    simpl; crush.
Qed.

Lemma downgrade_eval_inArr {n d v} :
  Value v →
  app (downgrade (S n) d) (inArr (n + d) v) -->*
      inArr n (abs (UVal n) (app (downgrade n d) (app (v[wk]) (app (upgrade n d) (var 0))))).
Proof.
  intros vv.
  unfold downgrade.

  (* beta-reduce *)
  (eapply evalStepStar; [eapply eval₀_to_eval; crush|]);
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl; crush;
  rewrite -> ?upgrade_sub, ?downgrade_sub.

  (* evaluate UVal pattern match *)
  (eapply evalStepTrans; [eapply caseUVal_eval_arr; crush|]);
    (* downgrade under sub... *)
    simpl; crush;
    rewrite -> ?downgrade_sub, ?upgrade_sub.

  change (wk 0) with 1; simpl.
  eauto with eval.
Qed.

Lemma upgrade_eval_inArr {n d v} :
  Value v →
  app (upgrade (S n) d) (inArr n v) -->*
      inArr (n + d) (abs (UVal (n + d)) (app (upgrade n d) (app (v[wk]) (app (downgrade n d) (var 0))))).
Proof.
  intros vv.
  unfold upgrade; simpl.

  (* beta-reduce *)
  (eapply evalStepStar; [eapply eval₀_to_eval; crush|]).
  rewrite -> ?(caseUVal_sub (beta1 _)); simpl; crush;
  rewrite -> ?upgrade_sub, ?downgrade_sub.

  (* evaluate UVal pattern match *)
  (eapply evalStepTrans; [eapply caseUVal_eval_arr; crush|]);
    (* upgrade under sub... *)
    simpl; crush;
    rewrite -> ?upgrade_sub, ?downgrade_sub.

  change (wk 0) with 1; simpl.
  eauto with eval.
Qed.

Lemma downgrade_reduces {n d v} :
  ⟪ empty ⊢ v : UVal (n + d) ⟫ → Value v →
  exists v', Value v' ∧ ⟪ empty ⊢ v' : UVal n ⟫ ∧
             app (downgrade n d) v -->* v'.
Proof.
  revert v; induction n;
  intros v ty vv.
  - exists (unkUVal 0).
    eauto using unkUVal_Value, unkUValT, downgrade_zero_eval.
  - change (S n + d) with (S (n + d)) in ty.
    canonUVal.
    + exists (unkUVal (S n)).
      change (S (n + d)) with (S n + d).
      eauto using unkUVal_Value, unkUValT, downgrade_eval_unk.
    + exists (inUnit n x).
      eauto using inUnit_Value, inUnitT, downgrade_eval_inUnit.
    + exists (inBool n x).
      eauto using inBool_Value, inBoolT, downgrade_eval_inBool.
    + stlcCanForm.
      destruct H0 as (vx0 & vx1).
      destruct (IHn _ H2 vx0) as (x0' & vx0' & ty0 & evalx0).
      destruct (IHn _ H3 vx1) as (x1' & vx1' & ty1 & evalx1).
      exists (inProd n (pair x0' x1')).
      assert (Value (pair x0' x1')) by crush.
      eauto using inProd_Value, inProd_T, downgrade_eval_inProd with typing.

    + stlcCanForm;
      [ destruct (IHn _ H2 H0) as (vf & vvf & tyf & ex);
        exists (inSum n (inl vf))
      | destruct (IHn _ H2 H0) as (vf & vvf & tyf & ex);
        exists (inSum n (inr vf))];
      repeat split;
      eauto using inSum_Value, inSum_T, downgrade_eval_inSum with typing.
    + exists (inArr n (abs (UVal n) (app (downgrade n d) (app (x[wk]) (app (upgrade n d) (var 0)))))).
      assert (Value (abs (UVal n) (app (downgrade n d) (app (x[wk]) (app (upgrade n d) (var 0)))))) by crush.
      repeat split;
      eauto using inArr_Value, downgrade_eval_inArr, inArr_T,
            downgrade_T, upgrade_T with typing.
Qed.

Lemma upgrade_reduces {n v} d :
  ⟪ empty ⊢ v : UVal n ⟫ → Value v →
  exists v', Value v' ∧ ⟪ empty ⊢ v' : UVal (n + d) ⟫ ∧
             app (upgrade n d) v -->* v'.
Proof.
  revert v; induction n;
  intros v ty vv.
  - exists (unkUVal d).
    eauto using unkUVal_Value, unkUValT, upgrade_zero_eval.
  - canonUVal.
    + exists (unkUVal (S (n + d))).
      change (S (n + d)) with (S n + d).
      eauto using unkUVal_Value, unkUValT, upgrade_eval_unk.
    + exists (inUnit (n + d) x).
      eauto using inUnit_Value, inUnitT, upgrade_eval_inUnit.
    + exists (inBool (n + d) x).
      eauto using inBool_Value, inBoolT, upgrade_eval_inBool.
    + stlcCanForm.
      destruct H0 as (vx0 & vx1).
      destruct (IHn _ H2 vx0) as (x0' & vx0' & ty0 & evalx0).
      destruct (IHn _ H3 vx1) as (x1' & vx1' & ty1 & evalx1).
      exists (inProd (n + d) (pair x0' x1')).
      assert (Value (pair x0' x1')) by crush.
      change (S n + d) with (S (n + d)).
      eauto using inProd_Value, inProd_T, upgrade_eval_inProd with typing.
    + stlcCanForm;
      [ destruct (IHn _ H2 H0) as (vf & vvf & tyf & ex);
        exists (inSum (n + d) (inl vf))
      | destruct (IHn _ H2 H0) as (vf & vvf & tyf & ex);
        exists (inSum (n + d) (inr vf))];
      repeat split;
      eauto using inSum_Value, inSum_T, upgrade_eval_inSum with typing.
    + exists (inArr (n + d) (abs (UVal (n + d)) (app (upgrade n d) (app (x[wk]) (app (downgrade n d) (var 0)))))).
      assert (Value (abs (UVal (n + d)) (app (upgrade n d) (app (x[wk]) (app (downgrade n d) (var 0)))))) by crush.
      repeat split;
      eauto using inArr_Value, upgrade_eval_inArr, inArr_T,
            upgrade_T, downgrade_T with typing.
Qed.

Definition dir_world_prec (n : nat) (w : World) (d : Direction) (p : Prec) : Prop :=
  (lev w < n ∧ p = precise) ∨ (d = dir_lt ∧ p = imprecise).

Arguments dir_world_prec n w d p : simpl never.

Lemma dwp_zero {w d p} : dir_world_prec 0 w d p → p = imprecise ∧ d = dir_lt.
Proof.
  destruct 1 as [[? ?]|[? ?]].
  - depind H.
  - auto.
Qed.

Lemma dwp_precise {n d w} : lev w < n → dir_world_prec n w d precise.
Proof.
  left; auto.
Qed.

Lemma dwp_imprecise {n w} : dir_world_prec n w dir_lt imprecise.
Proof.
  right; auto.
Qed.

Lemma dwp_invert_imprecise {n w d} : dir_world_prec n w d imprecise → d = dir_lt.
Proof.
  destruct 1 as [[? ?]|[? ?]].
  - inversion H0.
  - auto.
Qed.

Lemma dwp_invert_S {w d p n} : dir_world_prec (S n) (S w) d p → dir_world_prec n w d p.
Proof.
  destruct 1 as [[? ?]|[? ?]]; [left|right];
  eauto with arith.
Qed.

Lemma dwp_invert_S' {w d p n} :
  dir_world_prec (S n) w d p →
  forall w', w' < w → dir_world_prec n w' d p.
Proof.
  destruct 1 as [[? ?]|[? ?]]; [left|right];
  eauto with arith.
Qed.

Lemma dwp_mono {w d p n} :
  dir_world_prec n w d p →
  forall w', w' ≤ w → dir_world_prec n w' d p.
Proof.
  destruct 1 as [[? ?]|[? ?]]; [left|right];
  eauto with arith.
Qed.

Lemma downgrade_inProd_works {n d w dir p vs vu} :
  valrel dir w (pEmulDV (S (n + d)) p) (inProd (n + d) vs) vu →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV (n + d) p) vs₁ vu₁ →
              ∃ vs₁', app (downgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV n p) vs₁' vu₁) →
  exists v',
    app (downgrade (S n) d) (inProd (n + d) vs) -->* v' ∧
    valrel dir w (pEmulDV (S n) p) v' vu.
Proof.
  intros vr ih.
  destruct (valrel_implies_OfType vr) as [[? ?] ?].
  destruct (invert_valrel_pEmulDV_inProd' vr) as (vs₁ & vs₂ & vu₁ & vu₂ & ? & ? & vr₁ & vr₂); subst.
  destruct w.
  * (* w = 0 *)
    destruct H1 as (wsPair & vpair).
    simpl in H0.
    canonUVal; crush.
    stlcCanForm.
    inversion H1; subst; clear H1.
    destruct_conjs; destruct H2 as [vx vx0].
    destruct (downgrade_reduces H4 vx) as (vs₁' & vvs₁' & ty₁' & es₁).
    destruct (downgrade_reduces H6 vx0) as (vs₂' & vvs₂' & ty₂' & es₂).
    exists (inProd n (S.pair vs₁' vs₂')).
    assert (forall w', w' < 0 → valrel dir w' (pEmulDV n p) vs₁' vu₁) by (intros; exfalso; Omega.omega).
    assert (forall w', w' < 0 → valrel dir w' (pEmulDV n p) vs₂' vu₂) by (intros; exfalso; Omega.omega).
    split.
    eapply downgrade_eval_inProd; crush.
    eapply valrel_inProd; crush.
  * (* w = S w *)
    assert (wlt : w < S w) by eauto with arith.
    assert (h1 := ih w vs₁ vu₁ wlt (vr₁ w wlt)).
    assert (h2 := ih w vs₂ vu₂ wlt (vr₂ w wlt)).
    destruct h1 as (vs₁' & es₁ & vr₁').
    destruct h2 as (vs₂' & es₂ & vr₂').
    destruct (valrel_implies_Value vr₁').
    destruct (valrel_implies_Value vr₂').
    exists (inProd n (S.pair vs₁' vs₂')).
    destruct H.
    eauto using downgrade_eval_inProd, valrel_inProd'.
Qed.

Lemma upgrade_inProd_works {n d w dir p vs vu} :
  valrel dir w (pEmulDV (S n) p) (inProd n vs) vu →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV n p) vs₁ vu₁ →
              ∃ vs₁', app (upgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV (n + d) p) vs₁' vu₁) →
  exists v',
    app (upgrade (S n) d) (inProd n vs) -->* v' ∧
    valrel dir w (pEmulDV (S (n + d)) p) v' vu.
Proof.
  intros vr ih.
  destruct (valrel_implies_OfType vr) as [[? ?] ?].
  destruct (invert_valrel_pEmulDV_inProd' vr) as (vs₁ & vs₂ & vu₁ & vu₂ & ? & ? & vr₁ & vr₂); subst.
  destruct w.
  * (* w = 0 *)
    destruct H1 as (wsPair & vpair).
    simpl in H0.
    canonUVal; crush.
    stlcCanForm.
    inversion H1; subst; clear H1.
    destruct_conjs; destruct H2 as [vx vx0].
    destruct (upgrade_reduces d H4 vx) as (vs₁' & vvs₁' & ty₁' & es₁).
    destruct (upgrade_reduces d H6 vx0) as (vs₂' & vvs₂' & ty₂' & es₂).
    exists (inProd (n + d) (S.pair vs₁' vs₂')).
    assert (forall w', w' < 0 → valrel dir w' (pEmulDV (n + d) p) vs₁' vu₁) by (intros; exfalso; Omega.omega).
    assert (forall w', w' < 0 → valrel dir w' (pEmulDV (n + d) p) vs₂' vu₂) by (intros; exfalso; Omega.omega).
    split.
    eapply upgrade_eval_inProd; trivial.
    eapply valrel_inProd; trivial; crush.
  * (* w = S w *)
    assert (wlt : w < S w) by eauto with arith.
    assert (h1 := ih w vs₁ vu₁ wlt (vr₁ w wlt)).
    assert (h2 := ih w vs₂ vu₂ wlt (vr₂ w wlt)).
    destruct h1 as (vs₁' & es₁ & vr₁').
    destruct h2 as (vs₂' & es₂ & vr₂').
    destruct (valrel_implies_Value vr₁').
    destruct (valrel_implies_Value vr₂').
    exists (inProd (n + d) (S.pair vs₁' vs₂')).
    destruct H.
    eauto using upgrade_eval_inProd, valrel_inProd'.
Qed.

Lemma downgrade_inSum_works {n d w dir p vs vu} :
  valrel dir w (pEmulDV (S (n + d)) p) (inSum (n + d) vs) vu →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV (n + d) p) vs₁ vu₁ →
              ∃ vs₁', app (downgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV n p) vs₁' vu₁) →
  exists v',
    app (downgrade (S n) d) (inSum (n + d) vs) -->* v' ∧
    valrel dir w (pEmulDV (S n) p) v' vu.
Proof.
  intros vr ih.
  destruct (valrel_implies_OfType vr) as [[? ?] ?].
  destruct (invert_valrel_pEmulDV_inSum' vr) as (vs' & vu' & ? & vr'); subst.
  destruct w.
  + (* w = 0 *)
    unfold repEmul in H0; canonUVal;
    inversion H3; subst; clear H3.
    stlcCanForm;
      destruct (downgrade_reduces H6 H4) as (vs'' & vvs'' & ty' & es');
      assert (forall w', w' < 0 → valrel dir w' (pEmulDV n p) vs'' vu') by (intros; exfalso; Omega.omega);
      [exists (inSum n (inl vs''))|exists (inSum n (inr vs''))];
      destruct H2 as [[eq1 eq2] | [eq1 eq2]];
      inversion eq1; inversion eq2; subst; clear eq1;
      destruct H1 as (closed_vu & vvu);
      (split;
       [refine (downgrade_eval_inSum _ _ _ es'); crush|
        assert (ot' : OfType (pEmulDV n p) vs'' vu') by crush;
          eapply (valrel_inSum ot'); eauto]).
    + (* w = S w *)
      assert (wlt : w < S w) by eauto with arith.
      specialize (vr' w wlt).
      destruct (ih w _ _ wlt vr') as (vs'' & es' & vr'').
      destruct (valrel_implies_Value vr'').
      destruct H2 as [[eq1 eq2] | [eq1 eq2]];
        subst;
        [exists (inSum n (S.inl vs'')) |exists (inSum n (S.inr vs''))];
        (split; [refine (downgrade_eval_inSum _ _ _ es'); crush
                | eapply (valrel_inSum' vr''); crush]).
Qed.

Lemma upgrade_inSum_works {n d w dir p vs vu} :
  valrel dir w (pEmulDV (S n) p) (inSum n vs) vu →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV n p) vs₁ vu₁ →
              ∃ vs₁', app (upgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV (n + d) p) vs₁' vu₁) →
  exists v',
    app (upgrade (S n) d) (inSum n vs) -->* v' ∧
    valrel dir w (pEmulDV (S (n + d)) p) v' vu.
Proof.
  intros vr ih.
  destruct (valrel_implies_OfType vr) as [[? ?] ?].
  destruct (invert_valrel_pEmulDV_inSum' vr) as (vs' & vu' & ? & vr'); subst.
  destruct w.
  + (* w = 0 *)
    unfold repEmul in H0; canonUVal;
    inversion H3; subst; clear H3.
    stlcCanForm;
      destruct (upgrade_reduces d H6 H4) as (vs'' & vvs'' & ty' & es');
      assert (forall w', w' < 0 → valrel dir w' (pEmulDV (n + d) p) vs'' vu') by (intros; exfalso; Omega.omega);
      [exists (inSum n (inl vs''))|exists (inSum n (inr vs''))];
      destruct H2 as [[eq1 eq2] | [eq1 eq2]];
      inversion eq1; inversion eq2; subst; clear eq1;
      destruct H1 as (closed_vu & value_vu);
      (split;
       [refine (upgrade_eval_inSum _ _ _ es'); crush|
        assert (ot' : OfType (pEmulDV (n + d) p) vs'' vu') by crush;
          eapply (valrel_inSum ot'); eauto]).
    + (* w = S w *)
      assert (wlt : w < S w) by eauto with arith.
      specialize (vr' w wlt).
      destruct (ih w _ _ wlt vr') as (vs'' & es' & vr'').
      destruct (valrel_implies_Value vr'').
      destruct H2 as [[eq1 eq2] | [eq1 eq2]];
        subst;
        [exists (inSum (n + d) (S.inl vs'')) |exists (inSum (n + d) (S.inr vs''))];
        (split; [refine (upgrade_eval_inSum _ _ _ es'); crush
                | eapply (valrel_inSum' vr''); crush]).
Qed.

Lemma downgrade_inArr_works {n d w dir p vs vu} :
  valrel dir w (pEmulDV (S (n + d)) p) (inArr (n + d) vs) vu →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV (n + d) p) vs₁ vu₁ →
              ∃ vs₁', app (downgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV n p) vs₁' vu₁) →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV n p) vs₁ vu₁ →
              ∃ vs₁', app (upgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV (n + d) p) vs₁' vu₁) →
  exists v',
    app (downgrade (S n) d) (inArr (n + d) vs) -->* v' ∧
    valrel dir w (pEmulDV (S n) p) v' vu.
Proof.
  intros vr ihd ihu.
  destruct (valrel_implies_OfType vr) as [[vv ty] otu].
  exists (inArr n (abs (UVal n) (app (downgrade n d) (app (vs[wk]) (app (upgrade n d) (var 0)))))).
  split.
  - eapply downgrade_eval_inArr; crush.
  - eapply valrel_inArr.
    apply invert_valrel_pEmulDV_inArr in vr.
    simpl in vv.
    apply valrel_ptarr_inversion in vr; destruct_conjs; subst.
    simpl in *.

    (* unfold the valrel-ptarr *)
    change (abs (UVal n)) with (abs (repEmul (pEmulDV n p))).
    apply valrel_lambda; crushOfType; crushTyping;
    eauto using downgrade_T, upgrade_T.
    rewrite -> ?upgrade_sub, ?downgrade_sub.

    rewrite <- ap_liftSub; rewrite <- up_liftSub;
    rewrite -> liftSub_wkm; rewrite (apply_wkm_beta1_up_cancel vr vs).

    (* first execute the upgrade *)
    specialize (ihu w' _ _ H0 H1).
    destruct ihu as (vs' & eups & vr').
    enough (termrel dir w' (pEmulDV n p)
                    (app (downgrade n d) (app (abs (UVal (n + d)) vr) vs')) (H [beta1 vu])) as tr'
        by (refine (termrel_antired_star_left (evalstar_ctx' eups _ _ _) tr');
            inferContext; crush; eauto using downgrade_value).

    (* now beta-reduce *)
    enough (termrel dir w' (pEmulDV n p)
                    (app (downgrade n d) (vr[beta1 vs']))
                    H[beta1 vu]) as tr'
    by (refine (termrel_antired_star_left _ tr'); simpl; eauto with eval;
        apply evalToStar;
        destruct (valrel_implies_Value vr') as [? _];
        assert (e₀ : app (abs (UVal (n + d)) vr) vs' -->₀ vr[beta1 vs']) by (eauto with eval);
        eapply (eval_from_eval₀ e₀); inferContext; crush; eauto using downgrade_value).

    (* now execute the application *)
    specialize (H4 w' _ _ H0 vr').
    eapply (termrel_ectx' H4); S.inferContext; U.inferContext; crush;
    eauto using downgrade_value.

    (* now execute the downgrade *)
    assert (wlt0 : w'0 < w) by Omega.omega.
    specialize (ihd w'0 _ _ wlt0 H21).
    destruct ihd as (vs'' & edowns & vr'').
    enough (termrel dir w'0 (pEmulDV n p)
                    vs'' vu0) as tr'
        by (refine (termrel_antired_star_left (evalstar_ctx' edowns _ _ _) tr');
            inferContext; crush; eauto using downgrade_value).

    (* conclude *)
    apply valrel_in_termrel.
    assumption.
Qed.

Lemma upgrade_inArr_works {n d w dir p vs vu} :
  valrel dir w (pEmulDV (S n) p) (inArr n vs) vu →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV (n + d) p) vs₁ vu₁ →
              ∃ vs₁', app (downgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV n p) vs₁' vu₁) →
  (forall w' vs₁ vu₁, w' < w →
              valrel dir w' (pEmulDV n p) vs₁ vu₁ →
              ∃ vs₁', app (upgrade n d) vs₁ -->* vs₁' ∧
                      valrel dir w' (pEmulDV (n + d) p) vs₁' vu₁) →
  exists v',
    app (upgrade (S n) d) (inArr n vs) -->* v' ∧
    valrel dir w (pEmulDV (S (n + d)) p) v' vu.
Proof.
  intros vr ihd ihu.
  destruct (valrel_implies_OfType vr) as [[vv ty] otu].
  exists (inArr (n + d) (abs (UVal (n + d)) (app (upgrade n d) (app (vs[wk]) (app (downgrade n d) (var 0)))))).
  split.
  - eapply upgrade_eval_inArr; crush.
  - eapply valrel_inArr.
    apply invert_valrel_pEmulDV_inArr in vr.
    simpl in vv.
    apply valrel_ptarr_inversion in vr; destruct_conjs; subst.
    simpl in *.

    (* unfold the valrel-ptarr *)
    change (abs (UVal (n + d))) with (abs (repEmul (pEmulDV (n + d) p))).
    apply valrel_lambda; crushOfType; crushTyping;
    eauto using upgrade_T, downgrade_T.
    rewrite -> ?upgrade_sub, ?downgrade_sub.

    (* sigh... *)
    rewrite <- ap_liftSub; rewrite <- up_liftSub;
    rewrite -> liftSub_wkm; rewrite (apply_wkm_beta1_up_cancel vr vs).

    (* first execute the upgrade *)
    specialize (ihd w' _ _ H0 H1).
    destruct ihd as (vs' & edowns & vr').
    enough (termrel dir w' (pEmulDV (n + d) p)
                    (app (upgrade n d) (app (abs (UVal n) vr) vs')) (H [beta1 vu])) as tr'
        by (refine (termrel_antired_star_left (evalstar_ctx' edowns _ _ _) tr');
            inferContext; crush; eauto using upgrade_value).

    (* now beta-reduce *)
    enough (termrel dir w' (pEmulDV (n + d) p)
                    (app (upgrade n d) (vr[beta1 vs']))
                    H[beta1 vu]) as tr'
    by (refine (termrel_antired_star_left _ tr');
        apply evalToStar;
        destruct (valrel_implies_Value vr') as [? _];
        assert (e₀ : app (abs (UVal n) vr) vs' -->₀ vr[beta1 vs']) by (eauto with eval);
        eapply (eval_from_eval₀ e₀); inferContext; crush; eauto using upgrade_value).

    (* now execute the application *)
    specialize (H4 w' _ _ H0 vr').
    eapply (termrel_ectx' H4); S.inferContext; U.inferContext; crush;
    eauto using upgrade_value.

    (* now execute the upgrade *)
    assert (wlt0 : w'0 < w) by Omega.omega.
    specialize (ihu w'0 _ _ wlt0 H21).
    destruct ihu as (vs'' & eups & vr'').
    enough (termrel dir w'0 (pEmulDV (n + d) p)
                    vs'' vu0) as tr'
        by (refine (termrel_antired_star_left (evalstar_ctx' eups _ _ _) tr');
            inferContext; crush; eauto using upgrade_value).

    (* conclude *)
    repeat crushLRMatch.
Qed.

Lemma downgrade_zero_works {d v vu dir w p} :
  dir_world_prec 0 w dir p →
  valrel dir w (pEmulDV d p) v vu →
  exists v',
    app (downgrade 0 d) v -->* v' ∧
    valrel dir w (pEmulDV 0 p) v' vu.
Proof.
  intros dwp vr;
  destruct (valrel_implies_OfType vr) as [[vv ty] otu];
  exists (unkUVal 0).
  destruct (dwp_zero dwp).
  destruct otu as (closed_vu & vvu); unfold OfTypeUtlc' in vvu.
  eauto using downgrade_zero_eval, valrel_unk.
Qed.

Lemma downgrade_S_works {n d v vu dir w p} :
  dir_world_prec (S n) w dir p →
  valrel dir w (pEmulDV (S (n + d)) p) v vu →
  (forall v vu w', dir_world_prec n w' dir p → valrel dir w' (pEmulDV (n + d) p) v vu →
                   exists v',
                     app (downgrade n d) v -->* v' ∧ valrel dir w' (pEmulDV n p) v' vu) →
  (forall v vu w', dir_world_prec n w' dir p → valrel dir w' (pEmulDV n p) v vu →
                   exists v',
                     app (upgrade n d) v -->* v' ∧ valrel dir w' (pEmulDV (n + d) p) v' vu) →
  exists v',
    app (downgrade (S n) d) v -->* v' ∧
    valrel dir w (pEmulDV (S n) p) v' vu.
Proof.
  intros dwp vr IHdown IHup.
  destruct (valrel_implies_Value vr);
  destruct (valrel_implies_OfType vr) as [[vv ty] [closed_vu otu]];
   unfold repEmul in ty.
  canonUVal.
  - (* unkUVal *)
    exists (unkUVal (S n)).
    change (S (n + d)) with (S n + d).
    eauto using downgrade_eval_unk, valrel_unk, invert_valrel_pEmulDV_unk.
  - (* inUnit *)
    exists (inUnit n x).
    eauto using downgrade_eval_inUnit, invert_valrel_pEmulDV_inUnit', valrel_inUnit.
  - (* inBool *)
    exists (inBool n x).
    eauto using downgrade_eval_inBool, invert_valrel_pEmulDV_inBool', valrel_inBool.
  - (* inProd *)
    eapply (downgrade_inProd_works vr); crush;
    eapply IHdown; try assumption; eapply dwp_invert_S'; crush.
  - (* inSum *)
    eapply (downgrade_inSum_works vr); crush;
    eapply IHdown; try assumption; eapply dwp_invert_S'; crush.
  - (* inArr *)
    eapply (downgrade_inArr_works vr); crush.
    + eapply IHdown; try assumption; eapply dwp_invert_S'; crush.
    + eapply IHup; try assumption; eapply dwp_invert_S'; crush.
Qed.

Lemma upgrade_zero_works {d v vu dir w p} :
  dir_world_prec 0 w dir p →
  valrel dir w (pEmulDV 0 p) v vu →
  exists v',
    app (upgrade 0 d) v -->* v' ∧
    valrel dir w (pEmulDV d p) v' vu.
Proof.
  intros dwp vr;
  destruct (valrel_implies_OfType vr) as [[vv ty] [closed_vu otu]];
  exists (unkUVal d).
  destruct (dwp_zero dwp).
  eauto using upgrade_zero_eval, valrel_unk, dwp_zero.
Qed.

Lemma upgrade_S_works {n d v vu dir w p} :
  dir_world_prec (S n) w dir p →
  valrel dir w (pEmulDV (S n) p) v vu →
  (forall v vu w', dir_world_prec n w' dir p → valrel dir w' (pEmulDV (n + d) p) v vu →
                   exists v',
                     app (downgrade n d) v -->* v' ∧ valrel dir w' (pEmulDV n p) v' vu) →
  (forall v vu w', dir_world_prec n w' dir p → valrel dir w' (pEmulDV n p) v vu →
                   exists v',
                     app (upgrade n d) v -->* v' ∧ valrel dir w' (pEmulDV (n + d) p) v' vu) →
  exists v',
    app (upgrade (S n) d) v -->* v' ∧
    valrel dir w (pEmulDV (S n + d) p) v' vu.
Proof.
  change (S n + d) with (S (n + d)).
  intros dwp vr IHdown IHup.
  destruct (valrel_implies_Value vr);
  destruct (valrel_implies_OfType vr) as [[vv ty] [closed_vu otu]];
   unfold repEmul in ty.
  canonUVal.
  - (* unkUVal *)
    exists (unkUVal (S n + d)).
    eauto using upgrade_eval_unk, valrel_unk, invert_valrel_pEmulDV_unk.
  - (* inUnit *)
    exists (inUnit (n + d) x).
    eauto using upgrade_eval_inUnit, invert_valrel_pEmulDV_inUnit', valrel_inUnit.
  - (* inBool *)
    exists (inBool (n + d) x).
    eauto using upgrade_eval_inBool, invert_valrel_pEmulDV_inBool', valrel_inBool.
  - (* inProd *)
    eapply (upgrade_inProd_works vr); crush;
    eapply IHup; try assumption; eapply dwp_invert_S'; crush.
  - (* inSum *)
    eapply (upgrade_inSum_works vr); crush;
    eapply IHup; try assumption; eapply dwp_invert_S'; crush.
  - (* inArr *)
    eapply (upgrade_inArr_works vr); crush.
    + eapply IHdown; try assumption; eapply dwp_invert_S'; crush.
    + eapply IHup; try assumption; eapply dwp_invert_S'; crush.
Qed.

Lemma downgrade_works {n d v vu dir w p} :
  dir_world_prec n w dir p →
  valrel dir w (pEmulDV (n + d) p) v vu →
  exists v',
    app (downgrade n d) v -->* v' ∧
    valrel dir w (pEmulDV n p) v' vu
with upgrade_works {n v vu dir w p} d :
       dir_world_prec n w dir p →
       valrel dir w (pEmulDV n p) v vu →
       exists v',
         app (upgrade n d) v -->* v' ∧
         valrel dir w (pEmulDV (n + d) p) v' vu.
Proof.
  (* the following is easier, but cheats by using the inductive hypotheses
  immediately *)
  (* auto using downgrade_zero_works, downgrade_S_works, upgrade_zero_works, upgrade_S_works. *)

  - destruct n.
    + intros; apply downgrade_zero_works; trivial.
    + specialize (downgrade_works n).
      specialize (upgrade_works n).
      auto using downgrade_S_works.
  - destruct n.
    + intros; apply upgrade_zero_works; trivial.
    + specialize (downgrade_works n).
      specialize (upgrade_works n).
      auto using upgrade_S_works.
Qed.

Lemma downgrade_works' {n d v vu dir w p} :
  dir_world_prec n w dir p →
  valrel dir w (pEmulDV (n + d) p) v vu →
  termrel dir w (pEmulDV n p) (app (downgrade n d) v) vu.
Proof.
  intros dwp vr.
  destruct (downgrade_works dwp vr) as (v' & es & vr').
  apply valrel_in_termrel in vr'.
  refine (termrel_antired_star_left es vr').
Qed.

Lemma downgrade_works'' {n d v vu dir w p} :
  dir_world_prec n w dir p →
  valrel dir w (pEmulDV (n + d) p) v vu →
  termrel₀ dir w (pEmulDV n p) (app (downgrade n d) v) vu.
Proof.
  intros dwp vr.
  destruct (downgrade_works dwp vr) as (v' & es & vr').
  apply valrel_in_termrel₀ in vr'.
  refine (termrel₀_antired_star_left es vr').
Qed.

Lemma upgrade_works' {n v vu dir w p} d :
  dir_world_prec n w dir p →
  valrel dir w (pEmulDV n p) v vu →
  termrel dir w (pEmulDV (n + d) p) (app (upgrade n d) v) vu.
Proof.
  intros dwp vr.
  destruct (upgrade_works d dwp vr) as (v' & es & vr').
  apply valrel_in_termrel in vr'.
  refine (termrel_antired_star_left es vr').
Qed.

Lemma upgrade_works'' {n v vu dir w p} d :
  dir_world_prec n w dir p →
  valrel dir w (pEmulDV n p) v vu →
  termrel₀ dir w (pEmulDV (n + d) p) (app (upgrade n d) v) vu.
Proof.
  intros dwp vr.
  destruct (upgrade_works d dwp vr) as (v' & es & vr').
  apply valrel_in_termrel₀ in vr'.
  refine (termrel₀_antired_star_left es vr').
Qed.

Lemma compat_upgrade {Γ ts dir m tu n p} d :
  dir_world_prec n m dir p →
  ⟪ Γ ⊩ ts ⟦ dir , m ⟧ tu : pEmulDV n p ⟫ →
  ⟪ Γ ⊩ app (upgrade n d) ts ⟦ dir , m ⟧ tu : pEmulDV (n + d) p ⟫.
Proof.
  intros.
  repeat crushLRMatch.
  - eauto using upgrade_T with typing.
  - crushUtlcScoping.
  - intros.
    specialize (H2 w H3 _ _ H4).
    simpl; repeat crushStlcSyntaxMatchH.
    rewrite upgrade_sub.
    eapply (termrel_ectx' H2); S.inferContext; U.inferContext; crush;
    eauto using upgrade_value.
    simpl.
    eauto using upgrade_works', dwp_mono.
Qed.

Lemma compat_downgrade {Γ ts dir m tu n p d} :
  dir_world_prec n m dir p →
  ⟪ Γ ⊩ ts ⟦ dir , m ⟧ tu : pEmulDV (n + d) p ⟫ →
  ⟪ Γ ⊩ app (downgrade n d) ts ⟦ dir , m ⟧ tu : pEmulDV n p ⟫.
Proof.
  intros.
  repeat crushLRMatch.
  - eauto using downgrade_T with typing.
  - crushUtlcScoping.
  - intros.
    specialize (H2 w H3 _ _ H4).
    simpl; repeat crushStlcSyntaxMatchH.
    rewrite downgrade_sub.
    eapply (termrel_ectx' H2); S.inferContext; U.inferContext; crush;
    eauto using downgrade_value.
    simpl.
    eauto using downgrade_works', dwp_mono.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Syntax.
Import ListNotations.
From Coq.ssr Require Import ssreflect.
Require Automaton.
Require Import Alphabet Grammar Validator_safe.

Module Make(Import A:Automaton.T).
Module Import ValidSafe := Validator_safe.Make A.

(** A few helpers for dependent types. *)

(** Decidable propositions. *)
Class Decidable (P : Prop) := decide : {P} + {~P}.
Arguments decide _ {_}.

(** A [Comparable] type has decidable equality. *)
Instance comparable_decidable_eq T `{ComparableLeibnizEq T} (x y : T) :
  Decidable (x = y).
Proof.
  unfold Decidable.
  destruct (compare x y) eqn:EQ; [left; apply compare_eq; intuition | ..];
    right; intros ->; by rewrite compare_refl in EQ.
Defined.

Instance list_decidable_eq T :
  (forall x y : T, Decidable (x = y)) ->
  (forall l1 l2 : list T, Decidable (l1 = l2)).
Proof. unfold Decidable. decide equality. Defined.

Ltac subst_existT :=
  repeat
    match goal with
    | _ => progress subst
    | H : @existT ?A ?P ?x ?y1 = @existT ?A ?P ?x ?y2 |- _ =>
      let DEC := fresh in
      assert (DEC : forall u1 u2 : A, Decidable (u1 = u2)) by apply _;
      apply Eqdep_dec.inj_pair2_eq_dec in H; [|by apply DEC];
      clear DEC
    end.

(** The interpreter is written using dependent types. In order to
  avoid reducing proof terms while executing the parser, we thunk all
  the propositions behind an arrow.
  Note that thunkP is still in Prop so that it is erased by
  extraction.
 *)
Definition thunkP (P : Prop) : Prop := True -> P.

(** Sometimes, we actually need a reduced proof in a program (for
  example when using an equality to cast a value). In that case,
  instead of reducing the proof we already have, we reprove the
  assertion by using decidability. *)
Definition reprove {P} `{Decidable P} (p : thunkP P) : P :=
  match decide P with
  | left p => p
  | right np => False_ind _ (np (p I))
  end.

(** Combination of reprove with eq_rect. *)
Definition cast {T : Type} (F : T -> Type) {x y : T} (eq : thunkP (x = y))
                {DEC : unit -> Decidable (x = y)}:
                F x -> F y :=
  fun a => eq_rect x F a y (@reprove _ (DEC ()) eq).

Lemma cast_eq T F (x : T) (eq : thunkP (x = x)) `{forall x y, Decidable (x = y)} a :
  cast F eq a = a.
Proof. by rewrite /cast -Eqdep_dec.eq_rect_eq_dec. Qed.

(** Input buffers and operations on them. **)
CoInductive buffer : Type :=
  Buf_cons { buf_head : token; buf_tail : buffer }.

Delimit Scope buffer_scope with buf.
Bind Scope buffer_scope with buffer.

Infix "::" := Buf_cons (at level 60, right associativity) : buffer_scope.

(** Concatenation of a list and an input buffer **)
Fixpoint app_buf (l:list token) (buf:buffer) :=
  match l with
    | nil => buf
    | cons t q => (t :: app_buf q buf)%buf
  end.
Infix "++" := app_buf (at level 60, right associativity) : buffer_scope.

Lemma app_buf_assoc (l1 l2:list token) (buf:buffer) :
  (l1 ++ (l2 ++ buf) = (l1 ++ l2) ++ buf)%buf.
Proof. induction l1 as [|?? IH]=>//=. rewrite IH //. Qed.

(** The type of a non initial state: the type of semantic values associated
   with the last symbol of this state. *)
Definition noninitstate_type state :=
  symbol_semantic_type (last_symb_of_non_init_state state).

(** The stack of the automaton : it can be either nil or contains a non
    initial state, a semantic value for the symbol associted with this state,
    and a nested stack. **)
Definition stack := list (sigT noninitstate_type). (* eg. list {state & state_type state} *)

Section Interpreter.

Hypothesis safe: safe.

(* Properties of the automaton deduced from safety validation. *)
Proposition shift_head_symbs: shift_head_symbs.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition goto_head_symbs: goto_head_symbs.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition shift_past_state: shift_past_state.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition goto_past_state: goto_past_state.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
Proposition reduce_ok: reduce_ok.
Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.

Variable init : initstate.

(** The top state of a stack **)
Definition state_of_stack (stack:stack): state :=
  match stack with
    | [] => init
    | existT _ s _::_ => s
  end.

(** The stack of states of an automaton stack **)
Definition state_stack_of_stack (stack:stack) :=
  (List.map
    (fun cell:sigT noninitstate_type => singleton_state_pred (projT1 cell))
    stack ++ [singleton_state_pred init])%list.

(** The stack of symbols of an automaton stack **)
Definition symb_stack_of_stack (stack:stack) :=
  List.map
    (fun cell:sigT noninitstate_type => last_symb_of_non_init_state (projT1 cell))
    stack.

(** The stack invariant : it basically states that the assumptions on the
    states are true. **)
Inductive stack_invariant: stack -> Prop :=
  | stack_invariant_constr:
    forall stack,
      prefix      (head_symbs_of_state (state_of_stack stack))
                  (symb_stack_of_stack stack) ->
      prefix_pred (head_states_of_state (state_of_stack stack))
                  (state_stack_of_stack stack) ->
      stack_invariant_next stack ->
      stack_invariant stack
with stack_invariant_next: stack -> Prop :=
  | stack_invariant_next_nil:
      stack_invariant_next []
  | stack_invariant_next_cons:
    forall state_cur st stack_rec,
      stack_invariant stack_rec ->
      stack_invariant_next (existT _ state_cur st::stack_rec).

(** [pop] pops some symbols from the stack. It returns the popped semantic
    values using [sem_popped] as an accumulator and discards the popped
    states.**)
Fixpoint pop (symbols_to_pop:list symbol) {A:Type} (stk:stack) :
  thunkP (prefix symbols_to_pop (symb_stack_of_stack stk)) ->
  forall (action:arrows_right A (map symbol_semantic_type symbols_to_pop)),
    stack * A.
unshelve refine
  (match symbols_to_pop
      return
         (thunkP (prefix symbols_to_pop (symb_stack_of_stack stk))) ->
         forall (action:arrows_right A (map _ symbols_to_pop)), stack * A
   with
     | [] => fun _ action => (stk, action)
     | t::q => fun Hp action =>
       match stk
          return thunkP (prefix (t::q) (symb_stack_of_stack stk)) -> stack * A
       with
         | existT _ state_cur sem::stack_rec => fun Hp =>
           let sem_conv := cast symbol_semantic_type _ sem in
           pop q _ stack_rec _ (action sem_conv)
         | [] => fun Hp => False_rect _ _
       end Hp
   end).
Proof.
  - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp).
  - clear -Hp. abstract (specialize (Hp I); now inversion Hp).
  - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp).
Defined.

(* Equivalent declarative specification for pop, so that we avoid
   (part of) the dependent types nightmare. *)
Inductive pop_spec {A:Type} :
    forall (symbols_to_pop:list symbol) (stk : stack)
           (action : arrows_right A (map symbol_semantic_type symbols_to_pop))
           (stk' : stack) (sem : A),
      Prop :=
  | Nil_pop_spec stk sem : pop_spec [] stk sem stk sem
  | Cons_pop_spec symbols_to_pop st stk action sem stk' res :
      pop_spec symbols_to_pop stk (action sem) stk' res ->
      pop_spec (last_symb_of_non_init_state st::symbols_to_pop)
               (existT _ st sem :: stk) action stk' res.

Lemma pop_spec_ok {A:Type} symbols_to_pop stk Hp action stk' res:
  pop symbols_to_pop stk Hp action = (stk', res) <->
  pop_spec (A:=A) symbols_to_pop stk action stk' res.
Proof.
  revert stk Hp action.
  induction symbols_to_pop as [|t symbols_to_pop IH]=>stk Hp action /=.
  - split.
    + intros [= <- <-]. constructor.
    + intros H. inversion H. by subst_existT.
  - destruct stk as [|[st sem]]=>/=; [by destruct pop_subproof0|].
    remember (pop_subproof t symbols_to_pop stk st Hp) as EQ eqn:eq. clear eq.
    generalize EQ. revert Hp action. rewrite <-(EQ I)=>Hp action ?.
    rewrite cast_eq. rewrite IH. split.
    + intros. by constructor.
    + intros H. inversion H. by subst_existT.
Qed.

Lemma pop_preserves_invariant symbols_to_pop stk Hp A action :
  stack_invariant stk ->
  stack_invariant (fst (pop symbols_to_pop stk Hp (A:=A) action)).
Proof.
  revert stk Hp A action. induction symbols_to_pop as [|t q IH]=>//=.
  intros stk Hp A action Hi.
  destruct Hi as [stack Hp' Hpp [|state st stk']].
  - destruct pop_subproof0.
  - now apply IH.
Qed.

Lemma pop_state_valid symbols_to_pop stk Hp A action lpred :
  prefix_pred lpred (state_stack_of_stack stk) ->
  let stk' := fst (pop symbols_to_pop stk Hp (A:=A) action) in
  state_valid_after_pop (state_of_stack stk') symbols_to_pop lpred.
Proof.
  revert stk Hp A action lpred. induction symbols_to_pop as [|t q IH]=>/=.
  - intros stk Hp A a lpred Hpp. destruct lpred as [|pred lpred]; constructor.
    inversion Hpp as [|? lpred' ? pred' Himpl Hpp' eq1 eq2]; subst.
    specialize (Himpl (state_of_stack stk)).
    destruct (pred' (state_of_stack stk)) as [] eqn:Heqpred'=>//.
    destruct stk as [|[]]; simpl in *.
    + inversion eq2; subst; clear eq2.
      unfold singleton_state_pred in Heqpred'.
      now rewrite compare_refl in Heqpred'; discriminate.
    + inversion eq2; subst; clear eq2.
      unfold singleton_state_pred in Heqpred'.
      now rewrite compare_refl in Heqpred'; discriminate.
  - intros stk Hp A a lpred Hpp. destruct stk as [|[] stk]=>//=.
    + destruct pop_subproof0.
    + destruct lpred as [|pred lpred]; [by constructor|].
      constructor. apply IH. by inversion Hpp.
Qed.

(** [step_result] represents the result of one step of the automaton : it can
    fail, accept or progress. [Fail_sr] means that the input is incorrect.
    [Accept_sr] means that this is the last step of the automaton, and it
    returns the semantic value of the input word. [Progress_sr] means that
    some progress has been made, but new steps are needed in order to accept
    a word.

    For [Accept_sr] and [Progress_sr], the result contains the new input buffer.

    [Fail_sr] means that the input word is rejected by the automaton. It is
    different to [Err] (from the error monad), which mean that the automaton is
    bogus and has perfomed a forbidden action. **)
Inductive step_result :=
  | Fail_sr: step_result
  | Accept_sr: symbol_semantic_type (NT (start_nt init)) -> buffer -> step_result
  | Progress_sr: stack -> buffer -> step_result.

(** [reduce_step] does a reduce action :
   - pops some elements from the stack
   - execute the action of the production
   - follows the goto for the produced non terminal symbol **)
Definition reduce_step stk prod (buffer : buffer)
        (Hval : thunkP (valid_for_reduce (state_of_stack stk) prod))
        (Hi : thunkP (stack_invariant stk))
  : step_result.
refine
  ((let '(stk', sem) as ss := pop (prod_rhs_rev prod) stk _ (prod_action prod)
      return thunkP (state_valid_after_pop (state_of_stack (fst ss)) _
                               (head_states_of_state (state_of_stack stk))) -> _
    in fun Hval' =>
    match goto_table (state_of_stack stk') (prod_lhs prod) as goto
      return (thunkP (goto = None ->
                      match state_of_stack stk' with
                      | Init i => prod_lhs prod = start_nt i
                      | Ninit _ => False
                      end)) -> _
    with
    | Some (exist _ state_new e) => fun _ =>
      let sem := eq_rect _ _ sem _ e in
      Progress_sr (existT noninitstate_type state_new sem::stk') buffer
    | None => fun Hval =>
      let sem := cast symbol_semantic_type _ sem in
      Accept_sr sem buffer
    end (fun _ => _))
   (fun _ => pop_state_valid _ _ _ _ _ _ _)).
Proof.
  - clear -Hi Hval.
    abstract (intros _; destruct Hi=>//; eapply prefix_trans; [by apply Hval|eassumption]).
  - clear -Hval.
    abstract (intros _; f_equal; specialize (Hval I eq_refl); destruct stk' as [|[]]=>//).
  - simpl in Hval'. clear -Hval Hval'.
    abstract (move : Hval => /(_ I) [_ /(_ _ (Hval' I))] Hval2 Hgoto; by rewrite Hgoto in Hval2).
  - clear -Hi. abstract by destruct Hi.
Defined.

Lemma reduce_step_stack_invariant_preserved stk prod buffer Hv Hi stk' buffer':
  reduce_step stk prod buffer Hv Hi = Progress_sr stk' buffer' ->
  stack_invariant stk'.
Proof.
  unfold reduce_step.
  match goal with
  | |- context [pop ?symbols_to_pop stk ?Hp ?action] =>
    assert (Hi':=pop_preserves_invariant symbols_to_pop stk Hp _ action (Hi I));
    generalize (pop_state_valid symbols_to_pop stk Hp _ action)
  end.
  destruct pop as [stk0 sem]=>/=. simpl in Hi'. intros Hv'.
  assert (Hgoto1:=goto_head_symbs (state_of_stack stk0) (prod_lhs prod)).
  assert (Hgoto2:=goto_past_state (state_of_stack stk0) (prod_lhs prod)).
  match goal with | |- context [fun _ : True => ?X] => generalize X end.
  destruct goto_table as [[state_new e]|] eqn:EQgoto=>//.
  intros _ [= <- <-]. constructor=>/=.
  - constructor. eapply prefix_trans. apply Hgoto1. by destruct Hi'.
  - unfold state_stack_of_stack; simpl; constructor.
    + intros ?. by destruct singleton_state_pred.
    + eapply prefix_pred_trans. apply Hgoto2. by destruct Hi'.
  - by constructor.
Qed.

(** One step of parsing. **)
Definition step stk buffer (Hi : thunkP (stack_invariant stk)): step_result :=
  match action_table (state_of_stack stk) as a return
    thunkP
      match a return Prop with
      | Default_reduce_act prod => _
      | Lookahead_act awt => forall t : terminal,
        match awt t with
        | Reduce_act p => _
        | _ => True
        end
      end -> _
  with
  | Default_reduce_act prod => fun Hv =>
    reduce_step stk prod buffer Hv Hi
  | Lookahead_act awt => fun Hv =>
    match buf_head buffer with
    | tok =>
      match awt (token_term tok) as a return
        thunkP match a return Prop with Reduce_act p => _ | _ => _ end -> _
      with
      | Shift_act state_new e => fun _ =>
        let sem_conv := eq_rect _ symbol_semantic_type (token_sem tok) _ e in
        Progress_sr (existT noninitstate_type state_new sem_conv::stk)
                    (buf_tail buffer)
      | Reduce_act prod => fun Hv =>
        reduce_step stk prod buffer Hv Hi
      | Fail_act => fun _ =>
        Fail_sr
      end (fun _ => Hv I (token_term tok))
    end
  end (fun _ => reduce_ok _).

Lemma step_stack_invariant_preserved stk buffer Hi stk' buffer':
  step stk buffer Hi = Progress_sr stk' buffer' ->
  stack_invariant stk'.
Proof.
  unfold step.
  generalize (reduce_ok (state_of_stack stk))=>Hred.
  assert (Hshift1 := shift_head_symbs (state_of_stack stk)).
  assert (Hshift2 := shift_past_state (state_of_stack stk)).
  destruct action_table as [prod|awt]=>/=.
  - eauto using reduce_step_stack_invariant_preserved.
  - set (term := token_term (buf_head buffer)).
    generalize (Hred term). clear Hred. intros Hred.
    specialize (Hshift1 term). specialize (Hshift2 term).
    destruct (awt term) as [state_new e|prod|]=>//.
    + intros [= <- <-]. constructor=>/=.
      * constructor. eapply prefix_trans. apply Hshift1. by destruct Hi.
      * unfold state_stack_of_stack; simpl; constructor.
        -- intros ?. by destruct singleton_state_pred.
        -- eapply prefix_pred_trans. apply Hshift2. by destruct Hi.
      * constructor; by apply Hi.
    + eauto using reduce_step_stack_invariant_preserved.
Qed.

(** The parsing use a [nat] fuel parameter [log_n_steps], so that we
    do not have to prove terminaison, which is difficult.

    Note that [log_n_steps] is *not* the fuel in the conventionnal
    sense: this parameter contains the logarithm (in base 2) of the
    number of steps to perform. Hence, a value of, e.g., 50 will
    usually be enough to ensure termination. *)
Fixpoint parse_fix stk buffer (log_n_steps : nat) (Hi : thunkP (stack_invariant stk)):
  { sr : step_result |
    forall stk' buffer', sr = Progress_sr stk' buffer' -> stack_invariant stk' } :=
  match log_n_steps with
  | O => exist _ (step stk buffer Hi)
                 (step_stack_invariant_preserved _ _ Hi)
  | S log_n_steps =>
    match parse_fix stk buffer log_n_steps Hi with
    | exist _ (Progress_sr stk buffer) Hi' =>
      parse_fix stk buffer log_n_steps (fun _ => Hi' _ buffer eq_refl)
    | sr => sr
    end
  end.

(** The final result of a parsing is either a failure (the automaton
    has rejected the input word), either a timeout (the automaton has
    spent all the given [2^log_n_steps]), either a parsed semantic value
    with a rest of the input buffer.

    Note that we do not make parse_result depend on start_nt for the
    result type, so that this inductive is extracted without the use
    of Obj.t in OCaml.  **)
Inductive parse_result {A : Type} :=
  | Fail_pr: parse_result
  | Timeout_pr: parse_result
  | Parsed_pr: A -> buffer -> parse_result.
Global Arguments parse_result _ : clear implicits.

Definition parse (buffer : buffer) (log_n_steps : nat):
  parse_result (symbol_semantic_type (NT (start_nt init))).
refine (match proj1_sig (parse_fix [] buffer log_n_steps _) with
        | Fail_sr => Fail_pr
        | Accept_sr sem buffer' => Parsed_pr sem buffer'
        | Progress_sr _ _ => Timeout_pr
        end).
Proof.
  abstract (repeat constructor; intros; by destruct singleton_state_pred).
Defined.

End Interpreter.

Arguments Fail_sr {init}.
Arguments Accept_sr {init} _ _.
Arguments Progress_sr {init} _ _.

End Make.

Module Type T(A:Automaton.T).
  Include (Make A).
End T.


Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program.
Require Export Coq.Classes.RelationPairs.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Common.
Require Import Fiat.Common.SetoidInstances.
Require Import Fiat.Common.Enumerable.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {HEC : Enumerable Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.

  Context (G : grammar Char).

  (**
<<
pbh' ch n "" = (n == 0)
pbh' ch n (ch :: s) = n > 0 && pbh' ch n s
pbh' ch n ('(' :: s) = pbh' ch (n + 1) s
pbh' ch n (')' :: s) = n > 0 && pbh' ch (n - 1) s
pbh' ch n (_ :: s) = pbh' ch n s

pbh = pbh' '+' 0
>>
*)

  Definition pbh_check_level (ch : Char) (start_level : nat) : bool
    := pb_check_level true ch start_level.

  Definition pbh_new_level (ch : Char) (start_level : nat) : nat
    := pb_new_level ch start_level.

  Definition pbh_check_level_fun (P : Char -> bool) (start_level : nat) : bool
    := pb_check_level_fun true P start_level.

  Definition pbh_new_level_fun (P : Char -> bool) (start_level : nat) : list nat
    := pb_new_level_fun P start_level.

  Definition pbh_check_level_fun_correct P start_level
  : pbh_check_level_fun P start_level
    <-> (forall ch, P ch -> pbh_check_level ch start_level)
    := pb_check_level_fun_correct _ _ _.

  Section generic.
    Context (transform_valid : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT)
            (valid0 : nonterminals_listT).

    Inductive generic_pbh'_productions : nonterminals_listT -> productions Char -> Type :=
    | PBHNil : forall valid,
                 generic_pbh'_productions valid nil
    | PBHCons : forall valid pat pats,
                  generic_pbh'_production valid 0 pat
                  -> generic_pbh'_productions valid pats
                  -> generic_pbh'_productions valid (pat::pats)
    with generic_pbh'_production : nonterminals_listT -> nat -> production Char -> Type :=
    | PBHProductionNil : forall valid,
                           generic_pbh'_production valid 0 nil
    | PBHProductionConsNonTerminal0 : forall valid nt its,
                                        is_valid_nonterminal valid (of_nonterminal nt)
                                        -> generic_pbh'_productions (transform_valid valid (of_nonterminal nt)) (Lookup G nt)
                                        -> generic_pbh'_production valid 0 its
                                        -> generic_pbh'_production valid 0 (NonTerminal nt :: its)
    | PBHProductionConsNonTerminalS : forall valid start_level nt its,
                                        pb'_production G valid0 0 (NonTerminal nt :: nil)
                                        -> generic_pbh'_production valid (S start_level) its
                                        -> generic_pbh'_production valid (S start_level) (NonTerminal nt :: its)
    | PBHProductionConsTerminal : forall valid start_level new_level P its,
                                   (forall ch, is_true (P ch) -> pbh_check_level ch start_level)
                                   -> (forall ch, is_true (P ch) -> pbh_new_level ch start_level = new_level)
                                    -> generic_pbh'_production valid new_level its
                                    -> generic_pbh'_production valid start_level (Terminal P :: its).
  End generic.

  Definition minimal_pbh'_productions := generic_pbh'_productions remove_nonterminal.
  Definition minimal_pbh'_production := generic_pbh'_production remove_nonterminal.

  Definition pbh'_productions := generic_pbh'_productions (fun valid _ => valid).
  Definition pbh'_production := generic_pbh'_production (fun valid _ => valid).
End cfg.


Require Import VST.floyd.proofauto.
Require Import Iterative.floatlib.
From Iterative.sparse Require Import sparse sparse_model spec_sparse.
Require Import vcfloat.VCFloat.
Require Import vcfloat.FPCompCert.
Require Import VSTlib.spec_math.

Set Bullet Behavior "Strict Subproofs".

Open Scope logic.

Definition Gprog: funspecs := SparseASI ++ MathASI.

Definition the_loop_body : statement.
let c := constr:(f_crs_matrix_vector_multiply) in
let c := eval red in c in
match c with context [Sloop (Ssequence _ ?body)] =>
 exact body
end.
Defined.

Lemma crs_multiply_loop_body:
 forall (Espec : OracleKind)  (sh1 sh2 sh3 : share)
   (m : val) (mval : matrix Tdouble)
   (v : val) (vval : vector Tdouble)
   (p : val) (partial_result: list val)
  (SH : readable_share sh1)
  (SH0 : readable_share sh2)
  (SH1 : writable_share sh3)
  (H : matrix_cols mval (Zlength vval))
  (H0 : matrix_rows mval < Int.max_unsigned)
  (H1 : Zlength vval < Int.max_unsigned)
  (H2 : Forall (Forall finite) mval)
  (FINvval: Forall finite vval)
  (H3 : 0 <= matrix_rows mval)
  (vp ci rp : val)
  (cols : Z)
  (vals : list (ftype Tdouble))
  (col_ind row_ptr : list Z)
  (H4 : crs_rep_aux mval cols vals col_ind row_ptr)
  (FRAME: mpred)
  (H5 : 0 <= 0 < Zlength row_ptr)
  (i : Z)
  (H6 : 0 <= i < matrix_rows mval),
semax (func_tycontext f_crs_matrix_vector_multiply Vprog Gprog [])
  (PROP ( )
   LOCAL (temp _i (Vint (Int.repr i));
   temp _next (Vint (Int.repr (Znth i row_ptr)));
   temp _row_ptr rp; temp _col_ind ci; temp _val vp;
   temp _rows (Vint (Int.repr (matrix_rows mval)));
   temp _m m; temp _v v; temp _p p)
   SEP (FRAME;
   data_at sh1 (tarray tdouble (Zlength col_ind)) (map Vfloat vals) vp;
   data_at sh1 (tarray tuint (Zlength col_ind))
     (map Vint (map Int.repr col_ind)) ci;
   data_at sh1 (tarray tuint (matrix_rows mval + 1))
     (map Vint (map Int.repr row_ptr)) rp;
   data_at sh2 (tarray tdouble (Zlength vval)) (map Vfloat vval) v;
   data_at sh3 (tarray tdouble (matrix_rows mval)) partial_result p))
      the_loop_body
  (normal_ret_assert
    (EX r: ftype Tdouble,
     (PROP (feq r (dotprod (Znth i mval) vval))
      LOCAL (temp _i (Vint (Int.repr i));
      temp _next (Vint (Int.repr (Znth (i + 1) row_ptr)));
      temp _row_ptr rp; temp _col_ind ci; temp _val vp;
      temp _rows (Vint (Int.repr (matrix_rows mval)));
      temp _m m; temp _v v; temp _p p)
      SEP (FRAME;
      data_at sh1 (tarray tdouble (Zlength col_ind)) (map Vfloat vals) vp;
      data_at sh1 (tarray tuint (Zlength col_ind))
        (map Vint (map Int.repr col_ind)) ci;
      data_at sh1 (tarray tuint (matrix_rows mval + 1))
        (map Vint (map Int.repr row_ptr)) rp;
      data_at sh2 (tarray tdouble (Zlength vval)) (map Vfloat vval) v;
      data_at sh3 (tarray tdouble (matrix_rows mval))
                   (upd_Znth i partial_result (Vfloat r)) p)))).
Proof.
intros.
unfold the_loop_body.
abbreviate_semax.
assert (CRS := H4).
assert (COLS := crs_rep_matrix_cols _ _ _ _ _ H4).
destruct H4 as [? [? [? [? ?]]]].
forward.
forward.
assert(0 <= i + 1 < Zlength row_ptr)
  by (rewrite H4; unfold matrix_rows in H6; lia).
forward.

forward_loop
  (EX h:Z, (PROP (Znth i row_ptr <= h <= Znth (i+1) row_ptr )
   LOCAL (
   temp _s (Vfloat (partial_row i h vals col_ind row_ptr vval));
   temp _i (Vint (Int.repr i));
   temp _h (Vint  (Int.repr h));
   temp _next (Vint (Int.repr (Znth (i+1) row_ptr)));
   temp _row_ptr rp; temp _col_ind ci; temp _val vp;
   temp _rows (Vint (Int.repr (matrix_rows mval)));
   temp _m m; temp _v v; temp _p p)
   SEP (FRAME;
   data_at sh1 (tarray tdouble (Zlength col_ind)) (map Vfloat vals) vp;
   data_at sh1 (tarray tuint (Zlength col_ind))
     (map Vint (map Int.repr col_ind)) ci;
   data_at sh1 (tarray tuint (matrix_rows mval + 1))
     (map Vint (map Int.repr row_ptr)) rp;
   data_at sh2 (tarray tdouble (Zlength vval)) (map Vfloat vval) v;
   data_at sh3 (tarray tdouble (matrix_rows mval)) partial_result p)))
  break:
  (EX r: ftype Tdouble,
   PROP (feq r (dotprod (Znth i mval) vval))
   LOCAL (
   temp _s (Vfloat r);
   temp _i (Vint (Int.repr i));
   temp _next (Vint (Int.repr (Znth (i+1) row_ptr)));
   temp _row_ptr rp; temp _col_ind ci; temp _val vp;
   temp _rows (Vint (Int.repr (matrix_rows mval)));
   temp _m m; temp _v v; temp _p p)
   SEP (FRAME;
   data_at sh1 (tarray tdouble (Zlength col_ind)) (map Vfloat vals) vp;
   data_at sh1 (tarray tuint (Zlength col_ind))
     (map Vint (map Int.repr col_ind)) ci;
   data_at sh1 (tarray tuint (matrix_rows mval + 1))
     (map Vint (map Int.repr row_ptr)) rp;
   data_at sh2 (tarray tdouble (Zlength vval)) (map Vfloat vval) v;
   data_at sh3 (tarray tdouble (matrix_rows mval)) partial_result p)).
-
EExists. entailer!.
split.
clear - H6 H11 H9. list_solve.
 erewrite partial_row_start; try eassumption. reflexivity.
-
Intros h.
 assert (Znth (i+1) row_ptr <= Int.max_unsigned) by list_solve.
forward_if.
 +
  assert (0 <= Znth i row_ptr) by list_solve.
  rewrite Int.unsigned_repr in H14 by list_solve.
  rewrite Int.unsigned_repr in H14
     by (clear - H4 H6 H9; unfold matrix_rows in H6; list_solve).
  forward.
  apply prop_right. rewrite H8. unfold matrix_rows in *; list_solve.
  entailer!.
   change float with (ftype Tdouble) in *.
   unfold matrix_rows in *.
   rewrite Znth_map. hnf; auto.
   clear - H7 H14 H12 H6 H9 H4. list_solve.
  assert (0 <= h < Zlength col_ind)
    by (rewrite H8; clear - H7 H14 H12 H6 H9 H4; unfold matrix_rows in *;  list_solve).
  forward.
  assert (0 <= Znth h col_ind < Zlength vval). {
     assert (Znth i row_ptr <= h < Znth (i+1) row_ptr) by lia.
     assert (Znth (i+1) row_ptr <= Zlength col_ind) by list_solve.
     clear - COLS H H17 H14 H6 H10 H15 H18.
      specialize (H10 _ H6).
      replace (Znth h col_ind) with
              (Znth (h-Znth i row_ptr) (sublist (Znth i row_ptr) (Znth (i+1) row_ptr) col_ind))
         by list_solve.

  pose proof (crs_row_rep_col_range _ _ _ _ H10).
  specialize (H0 (h - Znth i row_ptr)).
  autorewrite with sublist in H0. autorewrite with sublist.
  rewrite <- (sublist.Forall_Znth _ _ _ H6 H), (sublist.Forall_Znth _ _ _ H6 COLS).
  apply H0. list_solve.
  }
  forward.
  change float with (ftype Tdouble) in *.
  rewrite (@Znth_map (ftype Tdouble) _ _ _ h Vfloat) by rep_lia.
  rewrite (@Znth_map (ftype Tdouble) _ _ _ (Znth h col_ind)) by rep_lia.
  forward_call (Znth h vals, Znth (Znth h col_ind) vval, partial_row i h vals col_ind row_ptr vval).
  forward.
  Exists (h+1).
  entailer!.
  f_equal.
  change (Binary.Bfma _ _ _ _ _ _ _ _ _) with
   (@BFMA _ Tdouble (Znth h vals) (Znth (Znth h col_ind) vval)
     (partial_row i h vals col_ind row_ptr vval)
  ).
  eapply partial_row_next; try eassumption; lia.
+
 forward.
 Exists (partial_row i h vals col_ind row_ptr vval).
 entailer!.
 replace h with (Znth (i+1) row_ptr).
 erewrite partial_row_end; try eassumption.
 unfold matrix_vector_mult.
 rewrite Znth_map by lia. reflexivity.
  rewrite <- (sublist.Forall_Znth _ _ _ H6 H), (sublist.Forall_Znth _ _ _ H6 COLS); auto.
 clear - H14 H13 H12 H9 H4 H0 H10 H6.
 specialize (H10 i H6).
 unfold matrix_rows in *.
  rewrite Int.unsigned_repr in H14 by list_solve.
  rewrite Int.unsigned_repr in H14
     by (clear - H4 H6 H9; unfold matrix_rows in H6; list_solve).
 lia.
-
Intros r.
forward.
Exists r.
entailer!.
Qed.

Lemma body_crs_matrix_vector_multiply: semax_body Vprog Gprog f_crs_matrix_vector_multiply crs_matrix_vector_multiply_spec.
Proof.
start_function.
rename H3 into FINmval.
assert (0 <= matrix_rows mval) by (unfold matrix_rows; rep_lia).
forward.
forward.
forward.
forward.
freeze FR1 := (data_at sh1 _ _ _).
rename v0 into vp.
assert_PROP (0 <= 0 < Zlength row_ptr)
  by (entailer!; rewrite !Zlength_map in H12; rewrite H12; clear -H3; lia).
forward.
forward_for_simple_bound (matrix_rows mval)
  (EX i:Z, EX result: list (ftype Tdouble),
   PROP(Forall2 feq result (sublist 0 i (matrix_vector_mult mval vval)))
   LOCAL (temp _next (Vint (Int.repr (Znth i row_ptr)));
   temp _row_ptr rp; temp _col_ind ci; temp _val vp;
(*   temp _cols (Vint (Int.repr cols));*)
   temp _rows (Vint (Int.repr (matrix_rows mval)));
   temp _m m; temp _v v; temp _p p)
   SEP (FRZL FR1;
   data_at sh1 (tarray tdouble (Zlength col_ind)) (map Vfloat vals) vp;
   data_at sh1 (tarray tuint (Zlength col_ind))
     (map Vint (map Int.repr col_ind)) ci;
   data_at sh1 (tarray tuint (matrix_rows mval + 1))
     (map Vint (map Int.repr row_ptr)) rp;
   data_at sh2 (tarray tdouble (Zlength vval)) (map Vfloat vval) v;
   data_at sh3 (tarray tdouble (matrix_rows mval))
      (map Vfloat result ++ Zrepeat Vundef (matrix_rows mval - i)) p))%assert.
-
Exists (@nil (ftype Tdouble)). simpl app.
entailer!.
apply derives_refl.
-
Intros.
eapply semax_post_flipped'.
eapply crs_multiply_loop_body; eassumption; auto.
Intros r.
Exists (result ++ [r]).
entailer!.
clear - H7 H8 H6.
assert (matrix_rows mval = Zlength (matrix_vector_mult mval vval)). {
 unfold matrix_vector_mult. rewrite Zlength_map. reflexivity.
}
rewrite (sublist_split 0 i (i+1)) by list_solve.
rewrite sublist_len_1 by list_solve.
apply Forall2_app; auto.
constructor; auto.
unfold matrix_rows in H6.
unfold matrix_vector_mult. rewrite Znth_map by auto. auto.
apply derives_refl'. f_equal.
assert (Zlength result = i).
 apply Forall2_Zlength in H7.
 clear - H7 H6. unfold matrix_rows, matrix_vector_mult in *. list_solve.
clear - H24 H6.
unfold matrix_rows in *.
rewrite upd_Znth_app2
 by list_solve.
rewrite !map_app.
rewrite <- app_assoc.
f_equal.
list_solve.
-
Intros result.
Exists result.
rewrite Z.sub_diag, Zrepeat_0, app_nil_r.
thaw FR1.
entailer!.
clear - H6.
unfold matrix_rows, matrix_vector_mult in *.
rewrite sublist_same in H6 by list_solve. auto.
unfold crs_rep.
Exists vp ci rp cols vals col_ind row_ptr.
rewrite prop_true_andp by auto.
cancel.
Qed.


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

(**********************************************************************)
(*                      occurs.v                                      *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega Max Bool List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Abstraction_Terms.
Require Import IntensionalLib.Tree_calculus.Abstraction_Reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Normal.
Require Import IntensionalLib.Tree_calculus.Tree_Closed.
Require Import IntensionalLib.Tree_calculus.Substitution.
Require Import IntensionalLib.Tree_calculus.Tree_Eval.
Require Import IntensionalLib.Tree_calculus.Star.
Require Import IntensionalLib.Tree_calculus.Wait.
Require Import IntensionalLib.Tree_calculus.Fixpoints.
Require Import IntensionalLib.Tree_calculus.Wave_Factor.
Require Import IntensionalLib.Tree_calculus.Wave_Factor2.
Require Import IntensionalLib.Tree_calculus.Equal.
Require Import IntensionalLib.Tree_calculus.Case.
Require Import IntensionalLib.Tree_calculus.Extensions.
Require Import IntensionalLib.Tree_calculus.Wait2.

Lemma occurs_subst : forall M k, occurs k (subst_rec M (Op Node) 0) = occurs (S k) M.
Proof.
induction M; intros.
case n; intros;  simpl; auto.
cbv; auto.
simpl. rewrite IHM1. rewrite IHM2. auto.
Qed.

Lemma occurs_star_opt : forall M k, occurs k (star_opt M) = occurs (S k) M.
Proof.
induction M; intros; unfold star_opt; fold star_opt.
(* 3 *)
case n; intros; unfold_op; simpl; auto.
(* 2 *)
cbv; auto.
(* 1 *)
case (occurs 0 M1).
all: cycle 1.
intro.
simpl. rewrite IHM1. rewrite IHM2. omega.
(* 1 *)
gen_case IHM2 M2.
(* 3 *)
gen_case IHM2 n; unfold subst; rewrite occurs_subst; omega.
rewrite occurs_subst; omega.
(* 1 *)
gen_case IHM2 (occurs 0 t).
gen_case IHM2 (occurs 0 t0).
rewrite ! occurs_subst. auto.
rewrite IHM2. rewrite IHM1. omega.
rewrite IHM2. rewrite IHM1. omega.
Qed.

Lemma occurs_lift: forall M k n, occurs (k +n) (lift n M) = occurs k M.
Proof.
induction M; intros; unfold lift; simpl. 2: auto.
relocate_lt. replace (k+n0) with (n0+k) by omega.
generalize k; clear k. induction n0; intros.
simpl; auto.
replace (S n0 + n) with (S(n0 + n)) by omega.
replace (S n0 + k) with (S(n0+ k)) by omega.
unfold eqnat; fold eqnat.
eapply2 IHn0.
unfold lift in *.
rewrite IHM1. rewrite IHM2. auto.
Qed.

Lemma occurs_case :
forall P M k, occurs k (case P M) = occurs (k+ pattern_size P) M.
Proof.
induction P; intros; unfold case; fold case.
rewrite occurs_star_opt. simpl.
replace (k+1) with (S k) by omega. auto.
rewrite occurs_star_opt.
unfold swap, pattern_size; unfold_op; rewrite ! occurs_app.
rewrite ! occurs_op.
rewrite occurs_closed.
2: eapply2 Fop_closed.
unfold occurs at 1. unfold eqnat.
unfold occurs; fold occurs. unfold eqnat.
replace (k+0) with k by omega.
replace (S k) with (k+1) by omega. rewrite occurs_lift.
omega.
(* 1 *)
assert(is_program (App P1 P2) = true \/ is_program (App P1 P2) <> true) by decide equality.
inversion H. rewrite H0.
rewrite occurs_star_opt.
unfold swap. unfold_op.
rewrite ! occurs_app.
rewrite occurs_closed.
2: eapply2 equal_comb_closed.
simpl.
assert (program (App P1 P2)) by eapply2 program_is_program.
inversion H1. simpl in H3; max_out.
rewrite occurs_closed. 2: auto.
rewrite occurs_closed. 2: auto.
rewrite ! pattern_size_closed.
replace (k+ (0+0)) with k by omega.
all: auto.
simpl; auto.
replace (S k) with (k+1) by omega.
rewrite occurs_lift. omega.
(* 1 *)
assert(is_program (App P1 P2) = false).
gen_case H0 (is_program (App P1 P2)). congruence.
rewrite H1.
unfold case_app.
rewrite occurs_star_opt.
rewrite ! occurs_app.
rewrite occurs_closed.
2: eapply2 Fop_closed.
replace (S k) with (k+1) by omega.
unfold occurs; fold occurs.
unfold eqnat. replace (k+1) with (S k) at 1 by omega.
replace (S k) with (k+1) by omega. rewrite occurs_lift.
rewrite ! occurs_star_opt.
rewrite occurs_closed. 2: cbv; auto.
rewrite ! occurs_app.
replace (S (S k)) with (k+2) by omega.
rewrite ! occurs_lift.
rewrite IHP1. rewrite IHP2.
unfold_op; simpl. replace (k+2) with (S (S k)) by omega.
replace (k+1) with (S k) by omega.
replace (k+ (pattern_size P1 + pattern_size P2)) with
(k + (pattern_size P1) + (pattern_size P2)) by omega.
omega.
Qed.

Lemma occurs_false_1 : forall M, occurs 0 M = 0 -> maxvar M <= 1 -> maxvar M = 0.
Proof.
induction M; intros.
gen2_case H H0 n. omega.
auto.
simpl in *.
rewrite IHM1. rewrite IHM2. auto.
omega.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
omega.
omega.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
omega.
Qed.

Lemma occurs_extension :
forall k P M N, occurs k (extension P M N) = occurs k N + occurs (k+ pattern_size P) M.
Proof.
intros; unfold extension.  unfold_op.
rewrite ! occurs_app. rewrite ! occurs_op. simpl.
rewrite occurs_case. auto.
Qed.

Lemma star_mono2: forall M N, M <> N -> star M <> star N.
Proof. intros. intro. assert(M = N) by eapply2 star_mono. eapply2 H. Qed.

Lemma app_comb_mono2: forall M1 M2 N1 N2, M1 <> N1 -> app_comb M1 M2 <> app_comb N1 N2.
Proof. intros. intro. inversion H0. eapply2 H. Qed.

Lemma app_comb_vs_I : forall M N, matchfail (app_comb M N) i_op.
Proof. intros. unfold_op. eapply2 matchfail_compound_l. Qed.

(* restore as needed

Lemma star_opt_app_comb1:
  forall M N, maxvar M = 0 -> occurs 0 N >0 ->
              star_opt (app_comb M  N) =
              App
    (App (Op Node)
       (App (Op Node)
          (App (App (Op Node) (App (Op Node) (App k_op (App k_op M))))
             (App
                (App (Op Node)
                   (App (Op Node)
                      (App (App (Op Node) (App (Op Node) (star_opt (App k_op N))))
                         (App k_op (Op Node))))) (App k_op (Op Node))))))
    (App k_op (App (Op Node) (App (Op Node) i_op))).
Proof.
  intros.
  unfold app_comb.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto. 2: congruence.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto. 2: congruence.
  rewrite star_opt_closed.
  2: cbv; auto.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto. 2: congruence.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto. 2: congruence.
  rewrite (star_opt_closed  (App (Op Node) (App (Op Node) i_op))).
  2: cbv; auto.
  rewrite ! (star_opt_closed (Op Node)).
  2: cbv; auto. auto.
Qed.

Lemma subst_star_opt:
  forall M N1 N2,  occurs 1 M = true -> subst(star_opt M) N1 = subst(star_opt M) N2 -> N1 = N2.
Proof.
  induction M; split_all.
  gen2_case H H0 n.   discriminate.
  gen2_case H H0 n0.
  unfold subst in *; simpl in *. inversion H0. generalize H2; insert_Ref_out; auto.
  unfold lift; rewrite ! lift_rec_null; auto.
  discriminate.
  (* 1 *)
gen2_case IHM1 H (occurs 1 M1).
gen2_case IHM1 H (occurs 1 M1).

  unfold eqnat in *.

Lemma size_subst_star_opt : forall M N,  size (subst (star_opt M) N) = size M + size N.
Proof.
  intros. unfold subst; rewrite subst_rec_preserves_star_opt.
  induction M; intros; auto.
case n; intros; simpl; auto.

  Lemma A_k_size :
  forall k, size (A_k (S (S (S k)))) =
            size (star_opt (star_opt (app_comb (Ref 2) (app_comb (Ref 1) (Ref 0))))) +
            size (A_k (S (S k)))
.
Proof.
  intros. rewrite <- A_k_alt at 1.

       cbv.

  forall k, A_k (S (S (S k))) = k_op.
Proof.
  intros. rewrite <- A_k_alt.
  unfold app_comb; unfold_op.
  unfold star_opt at 2. unfold_op; unfold occurs; fold occurs.
  rewrite ! orb_false_l. unfold eqnat; fold eqnat.
  rewrite ! orb_true_l.
  unfold subst; rewrite ! subst_rec_preserves_star_opt. subst_tac. subst_tac.

  simpl.
  ; fold star_opt. unfold_op.

Lemma size_A_k : forall k,  size (A_k (S(S(S k)))) = size (A_k (S(S k))) + 142.
Proof.
  intros. unfold A_k; fold A_k. case k.
  (* 2 *)
  cbv; auto. intro. case n. cbv. auto. intro. unfold plus. intro.

Lemma  A_k_vs_A_k_3: forall k n, A_k (S (S (S k))) <> A_k (S (S (S (S k)) +n)).
Proof.
induction k; intros.
(* 2 *)
unfold A_k; fold A_k. unfold plus.
rewrite ! star_opt_app_comb.
2: apply A_k_closed.
2: cbv; auto. 2: cbv; auto. 2: cbv; auto.
rewrite ! (star_opt_occurs_true k_op).
2: cbv; auto. 2: discriminate.

rewrite ! star_opt_app_comb.
2: cbv; auto. 2: cbv; auto. 2: cbv; auto.

2: cbv; auto. 2: cbv; auto.

intro. inversion H; subst.
assert(

unfold app_comb at 1.
rewrite star_opt_occurs_true.
rewrite (star_opt_occurs_true (App (Op Node) (App (Op Node) (App k_op (app_comb (Ref 1) (Ref 0)))))).
2: cbv; auto.  2: congruence.
2: cbv; auto. 2: congruence.
rewrite star_opt_occurs_true.
2: cbv; auto.  2: simpl; congruence.
rewrite (star_opt_closed (App (Op Node) (App (Op Node) i_op))).
2: cbv; auto.
rewrite (star_opt_closed (App k_op (App (Op Node) (App (Op Node) i_op)))).
2: cbv; auto.
rewrite star_opt_occurs_true.
2: cbv; auto.
2: congruence.
rewrite (star_opt_closed (App k_op a_op)).
2: cbv; auto.
rewrite star_opt_closed.
unfold app_comb at 1.

unfold star_opt at 1.
2: cbv; auto.
unfold_op.

unfold app_comb at 2.

at 2.
unfold star_opt at 1 2.

repeat eapply2 star_mono2.
eapply2 app_comb_mono2.
Qed.

Lemma A_k_vs_A_k : forall k n, A_k (S k) <> A_k (S (S (k+n))).
Proof.
induction k; intros.
unfold plus, A_k; fold A_k.
case n; intros. discriminate.
unfold app_comb at 1; unfold star; fold star. discriminate .
clear; case k; intros.
unfold plus, A_k; fold A_k.
unfold app_comb, star; fold star. discriminate .
eapply A_k_vs_A_k_3.
Qed.

Lemma omega_k_vs_omega_k_aux:
forall M N,  maxvar M = 0 -> maxvar N = 0 -> M <> N ->
star_opt
  (star_opt
     (App (Ref 0)
        (app_comb (app_comb (app_comb M (Ref 1)) (Ref 1)) (Ref 0)))) <>
star_opt
  (star_opt
     (App (Ref 0)
        (app_comb (app_comb (app_comb N (Ref 1)) (Ref 1))
           (Ref 0)))).
Proof.
intros.
rewrite star_opt_occurs_true.
2: simpl; auto. 2: discriminate.
unfold  app_comb at 1.
rewrite (star_opt_occurs_true (App (Op Node) (App (Op Node) i_op))).
2: simpl; auto. 2: discriminate.
rewrite (star_opt_occurs_true (App (Op Node) (App (Op Node) (App k_op (Ref 0))))).
2: simpl; auto. 2: discriminate.
rewrite (star_opt_occurs_false (App k_op _)).
all: cycle 1.
unfold app_comb.
rewrite ! occurs_app.
simpl; auto. rewrite occurs_closed; auto.
(* 1 *)
rewrite (star_opt_occurs_true).
2: simpl; auto. 2: discriminate.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
(* 1 *)
rewrite star_opt_occurs_true.
2: simpl; auto. 2: discriminate.
unfold  app_comb at 1.
rewrite (star_opt_occurs_true (App (Op Node) (App (Op Node) i_op))).
2: simpl; auto. 2: discriminate.
rewrite (star_opt_occurs_true (App (Op Node) (App (Op Node) (App k_op (Ref 0))))).
2: simpl; auto. 2: discriminate.
rewrite (star_opt_occurs_false (App k_op _)) at 1.
all: cycle 1.
unfold app_comb. rewrite ! occurs_app.
simpl. rewrite occurs_closed; auto.
rewrite subst_rec_app.
rewrite ! subst_rec_preserves_app_comb.
rewrite (subst_rec_closed k_op).
2: cbv; auto.
rewrite ! subst_rec_ref. insert_Ref_out.
rewrite subst_rec_closed. 2: rewrite H0; auto.
rewrite (star_opt_occurs_true).
2: simpl; auto. 2: discriminate.
(* 1 *)
match goal with
| |- App (App (Op Node) (App (Op Node) (star_opt (star_opt (Ref 0))))) ?M <>
App (App (Op Node) (App (Op Node) (star_opt (star_opt (Ref 0))))) ?N =>
assert(M<>N)
end.
all: cycle 1.
congruence .
(* 1 *)
rewrite star_opt_occurs_true.
2: simpl; auto.  2: congruence.
rewrite star_opt_occurs_true.
2: simpl; auto.  2: congruence.
rewrite star_opt_occurs_true.
2: simpl; auto.  2: cbv; congruence.
unfold star_opt at 2. unfold occurs.
unfold_op. rewrite ! orb_false_l.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
(* 1 *)
rewrite star_opt_occurs_true.
2: simpl; auto.  2: congruence.
rewrite star_opt_occurs_true.
2: simpl; auto.  2: congruence.
rewrite star_opt_occurs_true.
2: simpl; auto.  2: cbv; congruence.
unfold star_opt at 2. unfold occurs.
unfold_op. rewrite ! orb_false_l.
match goal with
| |- App ?M1 ?M <> App ?N1 ?M =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: cbv; congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: cbv; congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.
all: cycle 1.
unfold subst_rec; congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
unfold subst_rec; fold subst_rec.
rewrite subst_rec_closed.
2: rewrite H; auto.
insert_Ref_out.
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- ?M <> ?N =>
assert(N <> M)
end.
all: cycle 1.
intro. apply H2. apply  (eq_sym H3).
rewrite star_opt_occurs_true.
2: cbv; auto.  2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M1 <> N1) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
rewrite ! star_opt_closed.
2: rewrite ! maxvar_app. 2: rewrite H0. 2: auto.
2: rewrite ! maxvar_app. 2: rewrite H. 2: auto.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
match goal with
| |- App ?M1 ?M2 <> App ?N1 ?N2 =>  assert(M2 <> N2) end.
2: congruence.
(* 1 *)
auto.
Qed.

Lemma omega_k_vs_omega_k : forall k n, omega_k k <> omega_k (S (k+n)).
Proof.
induction k; intros.
(* 2 *)
unfold plus, omega_k; fold omega_k.
eapply2 omega_k_vs_omega_k_aux.
replace n with (0+n) by auto.
eapply2 A_k_vs_A_k.
(* 1 *)
unfold omega_k; fold omega_k.
eapply2 omega_k_vs_omega_k_aux. eapply2 A_k_vs_A_k.
Qed.

*)