Require Import Common.Common.
Require Import UValFI.UVal.
Require Import LogRelFI.LemmasPseudoType.
Require Import LogRelFI.PseudoType.
Require Import LogRelFI.LR.
Require Import StlcFix.SpecSyntax.
Require Import StlcFix.SpecEvaluation.
Require Import StlcFix.LemmasEvaluation.
Require Import StlcFix.LemmasTyping.
Require Import StlcFix.SpecTyping.
Require Import StlcFix.Size.
Require Import StlcIso.SpecSyntax.
Require Import StlcIso.SpecEvaluation.
Require Import StlcIso.LemmasEvaluation.
(* Require Import StlcIso.LemmasScoping. *)
Require Import StlcIso.Inst.
Require Import StlcIso.Size.

Require Import Lia.
Require Import Min.

Lemma lev_lateri {i W} : lev (lateri i W) = lev W - i.
Proof.
  induction i; unfold lev in *; simpl in *; eauto with arith.
  rewrite IHi. lia.
Qed.

Section Obs.
  Lemma obs_zero {d ts tu} : Obs d 0 ts tu.
  Proof.
    destruct d; simpl; intuition.
  Qed.

  Lemma S_Observe_Terminating_value {n ts} :
    F.Value ts → Observe (S n) (F.TerminatingN ts).
  Proof.
    intros vts. simpl. eauto using F.values_terminateN.
  Qed.

  Lemma U_Observe_Terminating_value {n tu} :
    I.Value tu → Observe (S n) (I.TerminatingN tu).
  Proof.
    intros vtu. simpl. eauto using I.values_terminateN.
  Qed.

  Lemma obs_value {d n ts tu} :
    F.Value ts → I.Value tu → Obs d n ts tu.
  Proof.
    intros vs vu.
    destruct d; simpl; intros _;
    eauto using F.values_terminate, I.values_terminate.
  Qed.

  Lemma obs_mono {d W' W ts tu} :
    lev W' ≤ lev W →
    Obs d W ts tu →
    Obs d W' ts tu.
  Proof.
    intros fw obs.
    destruct d; destruct W';
    simpl in *; intuition;
    destruct (S_le fw) as [W'' [eq fw']];
    replace (lev W) with (S W'') in *; simpl in *;
    eauto using F.TermHor_lt, I.TermHor_lt.
  Qed.

  Lemma S_ObserveTerminatingN_xor_evaln {t t' n} :
    F.evaln t t' n → False ↔ Observe n (F.TerminatingN t).
  Proof.
    destruct n; simpl in *; intuition; eauto using F.TerminatingN_xor_evaln.
  Qed.

  Lemma S_Observe_TerminatingN_evaln {t t' n } n' :
    F.evaln t t' n → Observe n' (F.TerminatingN t') ↔ Observe (n + n') (F.TerminatingN t).
  Proof.
    destruct n';
      [ replace (n + 0) with n by lia
      | replace (n + S n') with (S n + n') by lia ];
    simpl in *; eauto using F.TerminatingN_evaln, S_ObserveTerminatingN_xor_evaln.
  Qed.

  Lemma S_ObserveTermHor_xor_evaln {t t' n} :
    F.evaln t t' n → False ↔ Observe n (F.TermHor t).
  Proof.
    destruct n; cbn; intuition. eauto using F.TermHor_xor_evaln.
  Qed.

  Lemma S_Observe_TermHor_evaln {t t' n } n' :
    F.evaln t t' n → Observe (n + n') (F.TermHor t) -> Observe n' (F.TermHor t').
  Proof.
    destruct n'; cbn; intros evals.
    - replace (n + 0) with n by lia.
      now rewrite <- (S_ObserveTermHor_xor_evaln evals).
    - replace (n + S n') with (S (n + n')) by lia.
      cbn.
      eauto using F.TermHor_evaln.
  Qed.

  Lemma S_Observe_TerminatingN_lt {t n n'} :
    n ≤ n' → Observe n (F.TerminatingN t) → Observe n' (F.TerminatingN t).
  Proof.
    intros ineq obs.
    destruct n; simpl; intuition.
    destruct (S_le ineq) as [n'' [eq ineq']]; subst; simpl in *.
    eauto using F.TerminatingN_lt.
  Qed.

  Lemma S_Observe_TermHor_lt {t n n'} :
    n ≤ n' → Observe n (F.TermHor t) → Observe n' (F.TermHor t).
  Proof.
    intros ineq obs.
    destruct n; simpl in *; [contradiction|].
    destruct (S_le ineq) as [n'' [-> ineq']]; cbn.
    eauto using F.TermHor_lt.
  Qed.

  Lemma U_Observe_TermHor_lt {t n n'} :
    n ≤ n' → Observe n (I.TermHor t) → Observe n' (I.TermHor t).
  Proof.
    intros ineq obs.
    destruct n; simpl in *; [contradiction|].
    destruct (S_le ineq) as [n'' [-> ineq']]; cbn.
    eauto using I.TermHor_lt.
  Qed.

  Lemma U_ObserveTerminatingN_xor_evaln {t t' n} :
    I.evaln t t' n → False ↔ Observe n (I.TerminatingN t).
  Proof.
    destruct n; simpl in *; intuition; eauto using I.TerminatingN_xor_evaln.
  Qed.

  Lemma U_Observe_TerminatingN_evaln {t t' n } n' :
    I.evaln t t' n → Observe n' (I.TerminatingN t') ↔ Observe (n + n') (I.TerminatingN t).
  Proof.
    destruct n';
      [ replace (n + 0) with n by lia
      | replace (n + S n') with (S n + n') by lia ];
    simpl in *; eauto using I.TerminatingN_evaln, U_ObserveTerminatingN_xor_evaln.
  Qed.

  Lemma U_Observe_TerminatingN_lt {t n n'} :
    n ≤ n' → Observe n (I.TerminatingN t) → Observe n' (I.TerminatingN t).
  Proof.
    intros ineq obs.
    destruct n; simpl; intuition.
    destruct (S_le ineq) as [n'' [eq ineq']]; subst; simpl; simpl in obs.
    eauto using I.TerminatingN_lt.
  Qed.

  Lemma U_ObserveTermHor_xor_evaln {t t' n} :
    I.evaln t t' n → False ↔ Observe n (I.TermHor t).
  Proof.
    destruct n; simpl in *; intuition; eauto using I.TermHor_xor_evaln.
  Qed.

  Lemma U_Observe_TermHor_evaln {t t' n } n' :
    I.evaln t t' n → Observe (n + n') (I.TermHor t) -> Observe n' (I.TermHor t').
  Proof.
    destruct n'; cbn; intros evals.
    - replace (n + 0) with n by lia.
      now rewrite <- (U_ObserveTermHor_xor_evaln evals).
    - replace (n + S n') with (S (n + n')) by lia.
      cbn.
      eauto using I.TermHor_evaln.
  Qed.

  Lemma obs_antired {ts ts' tu tu' W' W d i j} :
    F.evaln ts ts' i →
    I.evaln tu tu' j →
    (* W' ≤ W → *)
    lev W' + min i j ≥ lev W →
    Obs d W' ts' tu' →
    Obs d W ts tu.
  Proof.
    intros es eu (* fw *) sge obs.
    destruct d; destruct W; simpl; simpl in obs; intuition.
    - cut (tu'⇓).
      + refine (I.termination_closed_under_antireductionStar _).
        eauto using I.evaln_to_evalStar.
      + apply obs; clear obs.
        eapply (S_Observe_TermHor_evaln (lev W') es).
        assert (obs : Observe (S W) (F.TermHor ts)) by (simpl; intuition).
        refine (S_Observe_TermHor_lt _ obs).
        unfold lev in *.
        enough (min i j ≤ i) by lia.
        auto using le_min_l.
    - refine (F.termination_closed_under_antireductionStar _ _).
      + refine (stepRel_to_evalStar es).
      + apply obs; clear obs.
        assert (obs : Observe (S W) (I.TermHor tu)) by (simpl; intuition).
        apply (U_Observe_TermHor_evaln (lev W') eu).
        refine (U_Observe_TermHor_lt _ obs).
        unfold lev in *.
        lia.
  Qed.

  Lemma obs_antired_star {ts ts' tu tu' W d} :
    F.evalStar ts ts' →
    tu -->* tu' →
    Obs d W ts' tu' →
    Obs d W ts tu.
  Proof.
    intros es eu obs.
    destruct d.
    - intros term.
      destruct W; [contradiction|].
      eapply (F.TermHor_closed_under_reduction_star es) in term.
      eauto using I.termination_closed_under_antireductionStar.
    - intros term.
      destruct W; [contradiction|].
      cbn in term.
      eapply (I.TermHor_closed_under_reduction_star eu) in term.
      eauto using F.termination_closed_under_antireductionStar.
  Qed.

  (* Lemma obs_red {ts ts' tu tu' W' W d i j} : *)
  (*   F.evaln ts' ts i → *)
  (*   I.evaln tu' tu j → *)
  (*   lev W  + max i j <= lev W' → *)
  (*   Obs d W' ts' tu' → *)
  (*   Obs d W ts tu. *)
  (* Proof. *)
  (*   intros es eu sge obs. *)
  (*   destruct d; simpl; simpl in obs; intuition. *)
  (*   - eapply evaln_to_evalStar in eu. *)
  (*     eapply (termination_closed_under_evalstar eu). *)
  (*     eapply obs. *)
  (*     assert (i + lev W <= lev W') as sgei by lia. *)
  (*     eapply (S_Observe_TermHor_lt sgei). *)
  (*     now eapply (S_Observe_TermHor_evaln (lev W) es). *)
  (*   - eapply F.evaln_to_evalStar in es. *)
  (*     eapply (F.termination_closed_under_evalstar es). *)
  (*     eapply obs. *)
  (*     assert (j + lev W <= lev W') as sgej by lia. *)
  (*     eapply (U_Observe_TerminatingN_lt sgej). *)
  (*     now eapply (U_Observe_TerminatingN_evaln (lev W) eu). *)
  (* Qed. *)

  Lemma S_ObserveTerminating_Value {w vs} :
    F.Value vs →
    Observe (S w) (F.TerminatingN vs).
  Proof.
    intros vvs; simpl.
    apply F.values_terminateN; trivial.
  Qed.

  Lemma Diverge_Obs_lt {w ts tu} : not (F.Terminating ts) → Obs dir_lt w ts tu.
  Proof.
    intros div termobs.
    destruct w; try contradiction.
    apply F.TermHor_Terminating in termobs.
    exfalso; eauto.
  Qed.

  Lemma Diverge_Wrong_Obs {d w ts tu} :
    not (F.Terminating ts) →
    not (I.Terminating tu) →
    Obs d w ts tu.
  Proof.
    intros div divw.
    destruct d; intros termobs.
    - destruct w; try contradiction.
      apply F.TermHor_Terminating in termobs.
      exfalso; eauto.
    - destruct w; try contradiction.
      apply I.TermHor_Terminating in termobs.
      exfalso. eauto.
  Qed.

End Obs.

Section ClosedLR.
  Lemma valrel_implies_OfType {d W τ ts tu} :
    valrel d W τ ts tu → OfType τ ts tu.
  Proof.
    rewrite -> valrel_fixp. unfold valrel'. intuition.
  Qed.

  Lemma envrel_triv {d w γs γu} :
    envrel d w pempty γs γu.
  Proof.
    unfold envrel.
    intros i τ i_τ.
    depind i_τ.
  Qed.

  Lemma envrel_implies_WtSub {d W Γ γs γu} :
    envrel d W Γ γs γu → WtSub (repEmulCtx Γ) F.empty γs.
  Proof.
    intros er i τ vi_τ.
    destruct (getevar_repEmulCtx vi_τ) as [pτ [vi_pτ ?]].
    assert (vr : valrel d W pτ (γs i) (γu i)) by refine (er _ _ vi_pτ).
    destruct (valrel_implies_OfType vr) as [[_ ots] _].
    unfold OfTypeStlcFix in ots.
    subst. exact ots.
  Qed.

  Lemma envrel_implies_WtSub_iso {d W Γ γs γu} :
    envrel d W Γ γs γu → I.WtSub (fxToIsCtx Γ) I.empty γu.
  Proof.
    intros er i τ vu_τ.
    destruct (getevar_fxToIsCtx vu_τ) as [pτ [vu_pτ ?]].
    assert (vr : valrel d W pτ (γs i) (γu i)) by refine (er _ _ vu_pτ).
    destruct (valrel_implies_OfType vr) as [_ [_ ots]].
    subst. exact ots.
  Qed.

  (* Lemma envrel_implies_WsSub {d W Γ γs γu}: *)
  (*   envrel d W Γ γs γu → WsSub (pdom Γ) 0 γu. *)
  (* Proof. *)
  (*   intros er i wsi. *)
  (*   destruct (pdom_works_inv wsi) as (τ & τinΓ). *)
  (*   specialize (er i τ τinΓ). *)
  (*   destruct (valrel_implies_OfType er) as (_ & ws & _). *)
  (*   exact ws. *)
  (* Qed. *)

  Local Ltac crush :=
    crushOfType;
    repeat
      (cbn in *;
       subst*;
       repeat F.crushStlcSyntaxMatchH;
       repeat I.crushStlcSyntaxMatchH;
       destruct_conjs);
       eauto 20 using lt_le with arith.

  Lemma valrel_mono {d W τ ts tu W'} :
    W' ≤ W → valrel d W τ ts tu → valrel d W' τ ts tu.
  Proof with subst; intuition.
    rewrite -> ?valrel_fixp.
    revert ts tu W' W.
    induction τ;  unfold valrel';
    intros ts tu W' W fw [ot hyp];
    split; eauto; cbn in *.
    - (* ptarr _ _ *)
      destruct hyp as (tsb & tub & τ₁' & τ₂' & -> & -> & hyp).
      exists tsb, tub, τ₁', τ₂'.
      repeat split; try reflexivity.
      intros W'' fw'.
      apply hyp; lia.
    - (* ptprod *)
      crush.
    - (* ptsum *)
      crush.
      destruct H0 as [(-> & -> & ot')|[ (-> & -> )|[( -> & -> )|( -> & -> & ot')]]]; crush.
    - (* pEmulDV n p *)
      destruct n; [ assumption | idtac ].
      destruct hyp as [[eqs eqp]|[ts' hyp]];
        [ now left
        | right; exists ts'].
      destruct τ.
      + (* tarr *)
        destruct hyp as (-> & tsb & tub & τ₁' & τ₂' & -> & -> & hyp).
        split; [reflexivity|].
        exists tsb, tub, τ₁', τ₂'.
        crush.
      + (* tunit *)
        assumption.
      + (* tbool *)
        assumption.
      + (* tprod *)
        intuition.
        destruct ts'; crush.
        destruct tu; crush.
      + (* tsum *)
        intuition.
        destruct ts'; crush.
        destruct tu; crush.
        unfold sum_rel in *.
        destruct tu; crush.
      + (* trec *)
        crush.
      + (* tvar *)
        assumption.
  Qed.

  Lemma envrel_mono {d W Γ γs γu W'} :
    W' ≤ W → envrel d W Γ γs γu → envrel d W' Γ γs γu.
  Proof.
    intros fw er i τ viτ.
    refine (valrel_mono fw _).
    apply er; auto.
  Qed.

  Lemma contrel_mono {d W τ Cs Cu W'} :
    W' ≤ W → contrel d W τ Cs Cu → contrel d W' τ Cs Cu.
  Proof.
    intros fw cr. simpl.
    intros W'' fw' vs vu vr.
    apply cr; eauto with arith.
  Qed.

  Lemma termrel_zero {d τ ts tu} : termrel d 0 τ ts tu.
  Proof.
    intros Cs Cu cr eCs eCu. eauto using obs_zero.
  Qed.

  Lemma termrel_antired_step {ts ts' tu tu' W d τ} :
    F.eval ts ts' →
    I.eval tu tu' →
    (forall W', W = S W' -> termrel d W' τ ts' tu') →
    termrel d W τ ts tu.
  Proof.
    intros es eu tr.
    unfold termrel, termrel'.
    intros Cs Cu ecs ecu cr.
    destruct W.
    - eapply obs_zero.
    - refine (obs_antired (W' := W) _ _ _ _).
      eapply stepRel_step.
      refine (F.eval_ctx Cs _ _ ecs es).
      eapply stepRel_zero.
      eapply stepRel_step.
      refine (I.eval_ctx Cu _ _ ecu eu).
      eapply stepRel_zero.
      unfold lev; lia.
      apply tr; auto.
      refine (contrel_mono _ cr).
      lia.
  Qed.

  Lemma termrel_antired {ts ts' tu tu' W d τ i j} W' :
    F.evaln ts ts' i →
    I.evaln tu tu' j →
    W' ≤ W →
    lev W' + min i j ≥ lev W →
    termrel d W' τ ts' tu' →
    termrel d W τ ts tu.
  Proof.
    intros es eu fw sge tr.
    unfold termrel, termrel'.
    intros Cs Cu ecs ecu cr.
    refine (obs_antired _ _ sge _); eauto using F.evaln_ctx, I.evaln_ctx.
    apply tr; auto.
    refine (contrel_mono fw cr).
  Qed.

  Lemma termrel_antired_star {ts ts' tu tu' W d τ} :
    clos_refl_trans_1n F.Tm F.eval ts ts' →
    tu -->* tu' →
    termrel d W τ ts' tu' →
    termrel d W τ ts tu.
  Proof.
    intros es eu tr.
    destruct (evalTrans_to_stepRel es) as [i esi].
    destruct (evalTrans_to_stepRel eu) as [j euj].
    refine (termrel_antired W esi euj _ _ tr); lia.
  Qed.

  Lemma termrel_antired_star_left {ts ts' tu W d τ} :
    clos_refl_trans_1n F.Tm F.eval ts ts' →
    termrel d W τ ts' tu →
    termrel d W τ ts tu.
  Proof.
    assert (tu -->* tu) by (eauto with eval).
    eauto using termrel_antired_star.
  Qed.

  Lemma termrel_antired_eval_left {ts ts' tu W d τ} :
    F.eval ts ts' →
    termrel d W τ ts' tu →
    termrel d W τ ts tu.
  Proof.
    eauto using termrel_antired_star_left with eval.
  Qed.

  (* Lemma termrel_antired' {ts ts' tu tu' W d τ i j} W' : *)
  (*   S.evaln ts ts' i → *)
  (*   U.evaln tu tu' j →  *)
  (*   tu' ≠ wrong → *)
  (*   W' ≤ W → *)
  (*   lev W' + min i j ≥ lev W → *)
  (*   termrel d W' τ ts' tu' → *)
  (*   termrel d W τ ts tu. *)
  (* Proof. *)
  (*   intros es eu nw. *)
  (*   apply termrel_antired; try assumption. *)
  (*   induction eu; eauto using evaln; econstructor; eauto using evaln. *)
  (*   apply eval_ctx; try assumption. *)
  (*   intro eq; depind eu; intuition. *)
  (*   destruct H0 as [C'|C' eq']; destruct C'; simpl in eq; destruct H0; inversion eq; intuition. *)
  (* Qed. *)

  Lemma valrel_in_termrel {ts tu W d τ} :
    valrel d W τ ts tu → termrel d W τ ts tu.
  Proof.
    intros vr Cs Cu eCs eCu contrel.
    apply contrel; auto.
  Qed.

  Lemma valrel_implies_Value {d w τ ts tu} :
    valrel d w τ ts tu →
    F.Value ts ∧ I.Value tu.
  Proof.
    intros vr.
    rewrite -> valrel_fixp in vr.
    destruct vr as [ot _].
    exact (OfType_implies_Value ot).
  Qed.

  Lemma contrel_triv {d w τ} :
    contrel d w τ F.phole I.phole.
  Proof.
    unfold contrel, contrel'; intros w' fw ts tu vr; simpl.
    destruct (valrel_implies_Value vr).
    apply obs_value; trivial.
  Qed.

  Lemma extend_envrel {d w Γ γs γu τ ts tu} :
    valrel d w τ ts tu →
    envrel d w Γ γs γu →
    envrel d w (Γ p▻ τ) (γs↑ >=> beta1 ts) (γu↑ >=> beta1 tu).
  Proof.
    intros vr er x τ' xτ'.
    depind xτ'; intuition.
    replace ((γs↑ >=> beta1 ts) (S i)) with (γs i).
    replace ((γu↑ >=> beta1 tu) (S i)) with (γu i).
    now refine (er _ _ xτ').
    + cbn; rewrite <- ap_liftSub;
      rewrite -> liftSub_wkm;
      rewrite -> apply_wkm_beta1_cancel; intuition.
    + cbn; rewrite <- ap_liftSub;
      rewrite -> liftSub_wkm;
      rewrite -> apply_wkm_beta1_cancel; intuition.
  Qed.

  Lemma termrel_adequacy_lt {w m ts tu τ} :
    termrel dir_lt w τ ts tu →
    F.TermHor ts m →
    lev w > m →
    I.Terminating tu.
  Proof.
    intros tr term ineq.
    specialize (tr F.phole I.phole I I contrel_triv).
    simpl in tr. unfold lev in *.
    destruct (le_inv_plus ineq) as [r eq]; subst.
    apply tr.
    change (S m + r) with (S (m + r)) in *.
    apply (F.TermHor_lt term); lia.
  Qed.

  Lemma termrel_adequacy_gt {w m tu ts τ} :
    termrel dir_gt w τ ts tu →
    I.TermHor tu m →
    lev w > m →
    F.Terminating ts.
  Proof.
    intros tr term ineq.
    specialize (tr F.phole I.phole I I contrel_triv).
    simpl in tr. unfold lev in *.
    destruct (le_inv_plus ineq) as [r eq]; subst.
    apply tr.
    change (S m + r) with (S (m + r)) in *.
    apply (I.TermHor_lt term); lia.
  Qed.

  Lemma termrel_div_lt {w τ ts tu} : not (F.Terminating ts) → termrel dir_lt w τ ts tu.
  Proof.
    intros div Cs Cu eCs eCu contrel.
    eauto using Diverge_Obs_lt, F.divergence_closed_under_evalcontext.
  Qed.

  Lemma termrel_div_wrong {d w τ ts tu} :
    not (F.Terminating ts) →
    not (I.Terminating tu) →
    termrel d w τ ts tu.
  Proof.
    intros div divw Cs Cu eCs eCu _.
    eauto using Diverge_Wrong_Obs, F.divergence_closed_under_evalcontext.
    eapply Diverge_Wrong_Obs.
    - eauto using F.divergence_closed_under_evalcontext.
    - eapply I.divergence_closed_under_evalcontext; assumption.
  Qed.

  Lemma termrel_size_left {w τ ts tu} :
    (S (F.size ts) <= w -> termrel dir_lt w τ ts tu) -> termrel dir_lt w τ ts tu.
  Proof.
    intros hyp Cs Cu eCs eCu Cr.
    destruct w; try (cbn; contradiction).
    intros term.
    pose proof (sz := F.TermHor_size term).
    eapply F.size_ectx' in sz; [|assumption].
    eapply hyp; eauto.
    lia.
  Qed.

  Lemma termrel_size_right {w τ ts tu} :
    (S (I.size tu) <= w -> termrel dir_gt w τ ts tu) -> termrel dir_gt w τ ts tu.
  Proof.
    intros hyp Cs Cu eCs eCu Cr.
    destruct w; try (cbn; contradiction).
    intros term.
    pose proof (sz := I.TermHor_size term).
    eapply I.size_ectx' in sz; [|assumption].
    eapply hyp; eauto.
    lia.
  Qed.

  Lemma termrel_size_right' {d w τ ts tu} :
    ((d = dir_gt -> S (I.size tu) <= w) -> termrel d w τ ts tu) -> termrel d w τ ts tu.
  Proof.
    destruct d.
    - intros hyp. apply hyp. intros [=].
    - eauto using termrel_size_right.
  Qed.

End ClosedLR.

Section OpenLR.

  Lemma compat_var {Γ d n τ i} :
    ⟪ i : τ p∈ Γ ⟫ →
    ⟪ Γ ⊩ F.var i ⟦ d , n ⟧ I.var i : τ ⟫.
  Proof.
    intros iτ. unfold OpenLRN.
    split;[|split].
    - crushTyping.
      eauto using repEmulCtx_works.
    - I.crushTyping.
      eauto using fxToIsCtx_works.
    - intros ? _ ? ? er.
      apply valrel_in_termrel.
      refine (er _ _ iτ).
  Qed.

  Lemma adequacy_lt {n m ts tu τ} :
    ⟪ pempty ⊩ ts ⟦ dir_lt , n ⟧ tu : τ ⟫ →
    F.TermHor ts m →
    n > m →
    I.Terminating tu.
  Proof.
    intros lr term ineq.
    destruct lr as (tsty & tuscp & lr).
    set (w := n).
    assert (le_w : lev w ≤ n) by (unfold lev, w; lia).
    assert (er : envrel dir_lt w pempty (idm F.Tm) (idm I.Tm)) by apply envrel_triv.
    pose proof (lr w le_w (idm F.Tm) (idm I.Tm) er) as tr.
    rewrite -> ?ap_id in tr.
    eapply (termrel_adequacy_lt tr term); trivial.
  Qed.

  Lemma adequacy_gt {n m tu ts τ} :
    ⟪ pempty ⊩ ts ⟦ dir_gt , n ⟧ tu : τ ⟫ →
    I.TermHor tu m →
    n > m →
    F.Terminating ts.
  Proof.
    intros lr term ineq.
    destruct lr as (tsty & tuscp & lr).
    set (w := n).
    assert (le_w : lev w ≤ n) by (unfold lev, w; lia).
    assert (er : envrel dir_gt w pempty (idm F.Tm) (idm I.Tm)) by apply envrel_triv.
    (* assert (er : envrel dir_lt w pempty (idm F.Tm) (idm I.Tm)) by apply envrel_triv. *)
    pose proof (lr w le_w (idm F.Tm) (idm I.Tm) er) as tr.
    (* pose proof (lr w le_w (idm F.Tm) (idm I.Tm) er) as tr. *)
    rewrite -> ?ap_id in tr.
    eapply (termrel_adequacy_gt tr term); trivial.
  Qed.

End OpenLR.

Section TermRelZero.

  Lemma valrel_in_termreli₀ {d dfc w τ ts tu} :
    valrel d w τ ts tu → termreli₀ d dfc w τ ts tu.
  Proof.
    intros vr.
    destruct (valrel_implies_OfType vr) as [[? ?] ?].
    unfold termrel₀. simpl.
    left. exists ts, tu.
    (* why isn't this enough? *)
    (* eauto using clos_refl_trans_1n with eval. *)
    split; [|split]; eauto using clos_refl_trans_1n with eval; constructor.
  Qed.

  Lemma valrel_in_termrel₀ {d w τ ts tu} :
    valrel d w τ ts tu → termrel₀ d  w τ ts tu.
  Proof.
    unfold termrel₀.
    eauto using valrel_in_termreli₀.
  Qed.

  Lemma termrel₀_in_termrel {d w τ ts tu} :
    termrel₀ d w τ ts tu → termrel d w τ ts tu.
  Proof.
    destruct 1 as [(vs & vu & ess & esu & vr)|div].
    - eauto using termrel_antired_star, valrel_in_termrel.
    - unfold termrel, termrel'; eauto.
  Qed.

  Lemma termreli₀_antired {ts ts' tu tu' W d dfc τ i j} dfc' :
    dfc' + min i j ≥ dfc  →
    F.evaln ts ts' i →
    I.evaln tu tu' j →
    termreli₀ d dfc W τ ts' tu' →
    termreli₀ d dfc' W τ ts tu.
  Proof.
    intros ineq es eu tzi.
    destruct tzi as [(vs & vu & es' & eu' & vr)|?].
    - left. exists vs, vu.
      eapply stepRel_to_evalStar in es.
      eapply stepRel_to_evalStar in eu.
      eauto using evalStepTrans with eval.
    - right. intros Cs Cu eCs eCu.
      specialize (H Cs Cu eCs eCu).

      pose proof (evaln_ctx eCu eu) as eu'.
      pose proof (F.evaln_ctx eCs es) as es'.
      enough (lev (lateri dfc W) + Nat.min i j ≥ lev (lateri dfc' W)) as ineq' by
          eapply (obs_antired es' eu' ineq' H).
      rewrite ?lev_lateri; unfold lev.
      lia.
  Qed.

  Lemma termreli₀_antired_star {ts ts' tu tu' W d dfc τ} :
    clos_refl_trans_1n F.Tm F.eval ts ts' →
    tu -->* tu' →
    termreli₀ d dfc W τ ts' tu' →
    termreli₀ d dfc W τ ts tu.
  Proof.
    intros es eu tr.
    destruct tr as [(vs & vu & ess & esu & vr)|div].
    - left; exists vs, vu.
      simpl in *.
      eauto using evalStepTrans.
    - right. intros Cs Cu eCs eCu.
      destruct (evalTrans_to_stepRel (F.evalstar_ctx Cs eCs es)) as (? & es').
      destruct (evalTrans_to_stepRel eu) as (? & eu').
      pose proof (evaln_ctx eCu eu') as eu''.
      specialize (div Cs Cu eCs eCu).
      eapply (obs_antired (W' := (lateri dfc W)) es' eu''); try assumption.
      rewrite ?lev_lateri.
      lia.
  Qed.

  Lemma termreli₀_div_lt {w dfc τ ts tu} : not (F.Terminating ts) → termreli₀ dir_lt dfc w τ ts tu.
  Proof.
    intros div. right. intros  Cs Cu eCs eCu.
    eauto using Diverge_Obs_lt, F.divergence_closed_under_evalcontext.
  Qed.

  Lemma termreli₀_div_wrong {d dfc w τ ts tu} :
    not (F.Terminating ts) →
    not (I.Terminating tu) →
    termreli₀ d dfc w τ ts tu.
  Proof.
    intros div divw. right. intros Cs Cu eCs eCu.
    eauto using Diverge_Wrong_Obs, F.divergence_closed_under_evalcontext.
    eapply Diverge_Wrong_Obs.
    - eauto using F.divergence_closed_under_evalcontext.
    - eapply I.divergence_closed_under_evalcontext; assumption.
  Qed.
  Lemma termrel₀_antired_star {ts ts' tu tu' W d τ} :
    clos_refl_trans_1n F.Tm F.eval ts ts' →
    tu -->* tu' →
    termrel₀ d W τ ts' tu' →
    termrel₀ d W τ ts tu.
  Proof.
    eapply termreli₀_antired_star.
  Qed.

  Lemma termrel₀_antired_star_left {ts ts' tu W d τ} :
    clos_refl_trans_1n F.Tm F.eval ts ts' →
    termrel₀ d W τ ts' tu →
    termrel₀ d W τ ts tu.
  Proof.
    assert (tu -->* tu) by (simpl; eauto with eval).
    eauto using termrel₀_antired_star.
  Qed.

  Lemma termrel₀_ectx {d dfc w τ₁ τ₂ ts Cs tu Cu} (eCs : F.ECtx Cs) (eCu : I.ECtx Cu) :
    termreli₀ d dfc w τ₁ ts tu →
    (∀ vs vu, valrel d w τ₁ vs vu → termreli₀ d dfc w τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    termreli₀ d dfc w τ₂ (F.pctx_app ts Cs) (I.pctx_app tu Cu).
  Proof.
    intros trtm trcont.
    destruct trtm as [(vs & vu & ess & esu & vr)|div].
    - specialize (trcont vs vu vr).
      refine (termreli₀_antired_star _ _ trcont);
        eauto using F.evalstar_ctx, evalstar_ctx.
    - right.
      intros Cs' Cu' eCs' eC'.
      rewrite <- F.pctx_cat_app.
      rewrite <- I.pctx_cat_app.
      eauto using F.ectx_cat, I.ectx_cat.
  Qed.

  Lemma termrel₀_ectx' {d dfc w τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termreli₀ d dfc w τ₁ ts tu →
    (∀ vs vu, valrel d w τ₁ vs vu → termreli₀ d dfc w τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    ts' = F.pctx_app ts Cs →
    tu' = I.pctx_app tu Cu →
    F.ECtx Cs → I.ECtx Cu →
    termreli₀ d dfc w τ₂ ts' tu'.
  Proof.
    intros. subst.
    eauto using termrel₀_ectx.
  Qed.

  Lemma termrel₀_zero {d τ ts tu} :
    termrel₀ d 0 τ ts tu.
  Proof.
    right.
    intros Cs Cu eCs eCu.
    eapply obs_zero.
  Qed.

  Lemma termrel₀_ectx'' {d w' w τ₁ τ₂ ts Cs tu Cu} (eCs : F.ECtx Cs) (eCu : I.ECtx Cu) :
    termrel₀ d w' τ₁ ts tu →
    (∀ vs vu, valrel d w' τ₁ vs vu → termrel₀ d w τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    w ≤ w' →
    termrel₀ d w τ₂ (F.pctx_app ts Cs) (I.pctx_app tu Cu).
  Proof.
    intros trtm trcont ineq.
    destruct trtm as [(vs & vu & ess & esu & vr)|div].
    - specialize (trcont vs vu vr).
      refine (termrel₀_antired_star _ _ trcont);
        eauto using F.evalstar_ctx, evalstar_ctx.
    - right.
      intros Cs' Cu' eCs' eC'.
      rewrite <- F.pctx_cat_app.
      rewrite <- I.pctx_cat_app.
      eauto using F.ectx_cat, I.ectx_cat, obs_mono.
  Qed.

  Lemma termrel₀_ectx''' {d w w' τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termrel₀ d w' τ₁ ts tu →
    (∀ vs vu, valrel d w' τ₁ vs vu → termrel₀ d w τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    ts' = F.pctx_app ts Cs →
    tu' = I.pctx_app tu Cu →
    F.ECtx Cs → I.ECtx Cu →
    w ≤ w' →
    termrel₀ d w τ₂ ts' tu'.
  Proof.
    intros. subst.
    eauto using termrel₀_ectx''.
  Qed.

  Lemma termreli₀_dfc_mono {d dfc dfc' w τ ts tu}:
    termreli₀ d dfc w τ ts tu →
    dfc ≤ dfc' →
    termreli₀ d dfc' w τ ts tu.
  Proof.
    destruct 1 as [(vs & vu & ess & esu & vr)|div]; intros ineq.
    - left. exists vs, vu. eauto.
    - right. intros Cs Cu eCs eCu.
      specialize (div Cs Cu eCs eCu).
      refine (obs_mono _ div).
      rewrite ?lev_lateri.
      lia.
  Qed.

  Lemma termreli₀_ectx {d dfc w τ₁ τ₂ ts Cs tu Cu} (eCs : F.ECtx Cs) (eCu : I.ECtx Cu) :
    termrel₀ d (lateri dfc w) τ₁ ts tu →
    lev w ≥ dfc →
    (∀ vs vu, valrel d (lateri dfc w) τ₁ vs vu → termreli₀ d dfc w τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    termreli₀ d dfc w τ₂ (F.pctx_app ts Cs) (I.pctx_app tu Cu).
  Proof.
    intros trtm ineq trcont.
    destruct trtm as [(vs & vu & ess & esu & vr)|div].
    - specialize (trcont vs vu vr).
      eapply termreli₀_antired_star in trcont;
        eauto using F.evalstar_ctx, evalstar_ctx.
    - right.
      intros Cs' Cu' eCs' eC'.
      rewrite <- F.pctx_cat_app.
      rewrite <- I.pctx_cat_app.
      eauto using F.ectx_cat, I.ectx_cat.
  Qed.

  Lemma termreli₀_ectx' {d dfc w τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termrel₀ d (lateri dfc w) τ₁ ts tu →
    lev w ≥ dfc →
    (∀ vs vu, valrel d (lateri dfc w) τ₁ vs vu → termreli₀ d dfc w τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    ts' = F.pctx_app ts Cs →
    tu' = I.pctx_app tu Cu →
    F.ECtx Cs → I.ECtx Cu →
    termreli₀ d dfc w τ₂ ts' tu'.
  Proof.
    intros. subst.
    eauto using termreli₀_ectx.
  Qed.

End TermRelZero.

Section TermRelZeroNoDiv.
  Lemma valrel_termrelnd₀ {d w τ ts tu} :
    valrel d w τ ts tu -> termrelnd₀ d w τ ts tu.
  Proof.
    intros vr.
    destruct (valrel_implies_OfType vr) as [[vts ots] [vtu otu]].
    destruct d.
    - intros vs vvs es.
      destruct (F.value_evalStar vts es).
      exists tu; split; [assumption|]; split; eauto with eval.
    - intros vu vvu eu.
      destruct (I.value_evalStar vtu eu).
      exists ts; split; [assumption|]; split; eauto with eval.
  Qed.

  Lemma termrelnd₀_termrel {d w τ ts tu} :
    termrelnd₀ d w τ ts tu -> termrel d w τ ts tu.
  Proof.
    destruct d; cbn; intros tr.
    - intros Cs Cu eCs eCu cr term.
      destruct w; cbn in term; try contradiction.
      destruct term as (v & vv & es).
      destruct (F.evalHor_ectx_inv Cs eCs es vv) as (v' & vv' & es' & es'').
      destruct (tr v' vv' es') as (vu & vvu & eu & vr').
      eapply (evalstar_ctx Cu) in eu; eauto.
      eapply (termination_closed_under_antireductionStar eu).
      refine (cr _ _ _ _ vr' _); [lia|].
      exists v; eauto.
    - intros Cs Cu eCs eCu cr term.
      destruct w; cbn in term; try contradiction.
      destruct (I.TermHor_ectx_inv Cu eCu term) as (v' & vv' & es' & v'' & vv'' & es'').
      destruct (tr v' vv' es') as (vu & vvu & eu & vr').
      eapply (F.evalstar_ctx Cs) in eu; eauto.
      eapply (F.termination_closed_under_antireductionStar eu).
      refine (cr _ _ _ _ vr' _); [lia|].
      exists v''; repeat split; eauto with arith.
  Qed.

  Lemma termrelnd₀_antired {d w τ ts ts' tu tu'} :
    F.evalStar ts' ts -> tu' -->* tu ->
    termrelnd₀ d w τ ts tu -> termrelnd₀ d w τ ts' tu'.
  Proof.
    intros es eu tr.
    destruct d.
    - intros vs vvs es'.
      assert (es'' := F.determinacyStar es es' (F.values_are_normal vvs)).
      destruct (tr vs vvs es'') as (vu & vvu & eu' & vr).
      exists vu; repeat (split; eauto).
      refine (evalStepTrans _ eu eu').
    - intros vu vvu eu'.
      assert (eu'' := I.determinacyStar eu eu' (I.values_are_normal vvu)).
      destruct (tr vu vvu eu'') as (vs & vvs & es' & vr).
      exists vs; repeat (split; eauto).
      refine (evalStepTrans _ es es').
  Qed.

  Lemma termrelnd₀_antired_left {d w τ ts ts' tu} :
    F.evalStar ts' ts ->
    termrelnd₀ d w τ ts tu -> termrelnd₀ d w τ ts' tu.
  Proof.
    eauto using termrelnd₀_antired with eval.
  Qed.

  Lemma termrelnd₀_red {d w τ ts ts' tu tu'} :
    F.evalStar ts ts' -> tu -->* tu' ->
    termrelnd₀ d w τ ts tu -> termrelnd₀ d w τ ts' tu'.
  Proof.
    intros es eu tr.
    destruct d.
    - intros vs vvs es'.
      destruct (tr vs vvs (evalStepTrans _ es es')) as (vu & vvu & eu' & vr).
      exists vu; repeat (split; eauto).
      refine (I.determinacyStar eu eu' (I.values_are_normal vvu)).
    - intros vu vvu eu'.
      destruct (tr vu vvu (evalStepTrans _ eu eu')) as (vs & vvs & es' & vr).
      exists vs; repeat (split; eauto).
      refine (F.determinacyStar es es' (F.values_are_normal vvs)).
  Qed.

  Lemma termrelnd₀_ectx {d w w' τ₁ τ₂ ts Cs tu Cu} (eCs : F.ECtx Cs) (eCu : I.ECtx Cu) :
    termrelnd₀ d w τ₁ ts tu →
    (∀ vs vu, valrel d w τ₁ vs vu → termrelnd₀ d w' τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    termrelnd₀ d w' τ₂ (F.pctx_app ts Cs) (I.pctx_app tu Cu).
  Proof.
    intros tr cr.
    destruct d.
    - intros vs vvs es.
      destruct (F.evalStar_ectx_inv Cs ts eCs vs es vvs) as (vs' & vvs' & es1 & es2).
      destruct (tr vs' vvs' es1) as (vu & vvu & eu & vr2).
      specialize (cr vs' vu vr2).
      destruct (cr vs vvs es2) as (vu2 & vvu2 & eu2 & vr3).
      exists vu2.
      eapply (evalstar_ctx Cu eCu) in eu.
      split; [|split]; eauto using evalStepTrans.
    - intros vu vvu eu.
      destruct (I.evalStar_ectx_inv Cu tu eCu vu eu vvu) as (vu' & vvu' & eu1 & eu2).
      destruct (tr vu' vvu' eu1) as (vs & vvs & es & vr2).
      specialize (cr vs vu' vr2).
      destruct (cr vu vvu eu2) as (vs2 & vvs2 & es2 & vr3).
      exists vs2.
      eapply (F.evalstar_ctx Cs eCs) in es.
      split; [|split]; eauto using evalStepTrans.
  Qed.

  Lemma termrelnd₀_ectx' {d w w' τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termrelnd₀ d w τ₁ ts tu →
    ts' = F.pctx_app ts Cs →
    tu' = I.pctx_app tu Cu →
    (∀ vs vu, valrel d w τ₁ vs vu → termrelnd₀ d w' τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    F.ECtx Cs → I.ECtx Cu →
    termrelnd₀ d w' τ₂ ts' tu'.
  Proof.
    intros; subst; eauto using termrelnd₀_ectx.
  Qed.

  (* interestingly, the following doesn't seem to hold with termrel instead of termrelnd₀. *)
  Lemma termrelnd₀_ectx_sub {d w τ₁ τ₂ ts vu tub} Cs (eCs : F.ECtx Cs) {vvu : I.Value vu} :
    (* termrel d (S w) τ₁ ts vu → *)
    termrelnd₀ d w τ₁ ts vu →
    (∀ {vs}, valrel d w τ₁ vs vu → termrel d w τ₂ (F.pctx_app vs Cs) (tub [beta1 vu])) →
    termrel d w τ₂ (F.pctx_app ts Cs) (tub [beta1 vu]).
  Proof.
    intros tr contr.
    intros Cs' Cu' eCs' eCu' cr'.
    destruct d.
    - destruct w; try (cbn; contradiction).
      intros term.
      rewrite <-F.pctx_cat_app in term.
      destruct (F.TermHor_ectx_inv (F.pctx_cat Cs Cs') (F.ectx_cat Cs Cs' eCs eCs') term) as (vs' & vvs' & es' & term').
      destruct (tr vs' vvs' es') as (vu' & vvu' & eu' & vr').
      destruct (I.normal_evalStar (I.values_are_normal vvu) eu').
      clear vvu' tr eu' term.
      rewrite F.pctx_cat_app in term'.
      refine (contr _ vr' Cs' Cu' eCs' eCu' cr' term'); lia.
    - destruct w; try (cbn; contradiction).
      destruct (tr vu vvu (rt1n_refl _ _ _)) as (vs' & vvs' & es' & vr).
      eapply obs_antired_star.
      + eapply (F.evalstar_ctx _ eCs').
        refine (F.evalstar_ctx _ eCs es').
      + eapply rt1n_refl.
      + refine (contr vs' vr Cs' Cu' eCs' eCu' cr').
  Qed.

  Lemma termrelnd₀_div_lt {ts tu W τ} :
    not (F.Terminating ts) ->
    termrelnd₀ dir_lt W τ ts tu.
  Proof.
    intros div vs vvs es.
    contradict div.
    now exists vs.
  Qed.

End TermRelZeroNoDiv.

Ltac crushLRMatch :=
  match goal with
      [ |- _ ∧ _ ] => split
    | [ |- context[ lev ]] => unfold lev
    | [ H : context[ lev ] |- _ ] => unfold lev in *
    | [ |- ⟪ _ ⊩ _ ⟦ _ , _ ⟧ _ : _ ⟫ ] => (unfold OpenLRN; split)
    | [ H : ⟪ _ ⊩ _ ⟦ _ , _ ⟧ _ : _ ⟫ |- _ ] => (unfold OpenLRN in H; destruct_conjs)
    | [ H : valrel ?d _ ?τ ?ts ?tu |- termrel ?d _ ?τ ?ts ?tu ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ (F.abs _ _) (I.abs _ _) ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ F.unit I.unit ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ F.false I.false ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ F.true I.true ] => apply valrel_in_termrel
    | [ H : valrel ?d ?w ?τ ?ts ?tu |- valrel ?d ?w' ?τ ?ts ?tu ] => (refine (valrel_mono _ H); try lia)
    | [ H : envrel ?d ?w ?τ ?ts ?tu |- envrel ?d ?w' ?τ ?ts ?tu ] => (refine (envrel_mono _ H); try lia)
    | [ |- envrel ?d ?w (?Γ p▻ ?τ) (?γs↑ >=> beta1 ?ts) (?γu↑ >=> beta1 ?tu) ] => refine (extend_envrel _ _)
    | [ H : valrel _ _ ?τ ?ts ?tu |- OfType ?τ ?ts ?tu ] => refine (valrel_implies_OfType H)
    | [ |- valrel _ _ _ _ _] => rewrite -> valrel_fixp in |- *; unfold valrel' in |- *
    | [ |- F.ECtx (F.pctx_cat _ _) ] => apply F.ectx_cat
    | [ |- I.ECtx (I.pctx_cat _ _) ] => apply I.ectx_cat
  end.


(** * JCC (rel) instruction *)
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsops bitsprops bitsopsprops.
Require Import spec SPred septac spec safe triple basic basicprog spectac.
Require Import instr instrcodec eval monad monadinst reader pointsto cursor.
Require Import Setoid RelationClasses Morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Relations.
Require Import instrsyntax.

Local Open Scope instr_scope.

Require Import x86.instrrules.core.

(** For convenience, the [~~b] branch is not under a [|>] operator
    since [q] will never be equal to [p], and thus there is no risk of
    recursion. *)
Lemma JCCrel_rule rel cc cv (b:bool) (p q: DWORD) :
  |-- (
      |> safe @ (b == cv /\\ EIP ~= (addB q rel) ** ConditionIs cc b) //\\
         safe @ (b == (~~cv) /\\ EIP ~= q ** ConditionIs cc b) -->>
      safe @ (EIP ~= p ** ConditionIs cc b)
    ) <@ (p -- q :-> JCCrel cc cv (mkTgt rel)).
Proof.
  rewrite ->(spec_later_weaken (safe @ (b == (~~ cv) /\\ EIP~=q ** ConditionIs cc b))).
  rewrite <-spec_later_and. rewrite ->spec_at_and_or; last apply _.
  apply TRIPLE_safe => R. rewrite /evalInstr.
  triple_apply triple_letGetCondition.
  replace (b == (~~cv)) with (~~(b == cv)); last first.
  { case: b; case: cv; reflexivity. }
  case: (b == cv).
  { instrrule_triple_bazooka using do [ progress sbazooka | apply: lorR1 ]. }
  { instrrule_triple_bazooka using do [ progress sbazooka | apply: lorR2 ]. }
Qed.


Require Import AST.
Require Import Coqlib.

Require Import sepcomp.extspec.
Require Import sepcomp.core_semantics.
Require Import sepcomp.forward_simulations.

Section safety.
  Context {G C M D Z:Type}.
  Context (Hcore:CoreSemantics G C M).
  Variable (Hspec:external_specification M external_function Z).

  Variable ge : G.

  Fixpoint safeN (n:nat) (z:Z) (c:C) (m:M) : Prop :=
    match n with
    | O => True
    | S n' =>
       match at_external Hcore c, halted Hcore c with
       | None, None =>
           exists c', exists m',
             corestep Hcore ge c m c' m' /\
             safeN n' z c' m'
       | Some (e,sig,args), None =>
           exists x:ext_spec_type Hspec e,
             ext_spec_pre Hspec e x (sig_args sig) args z m /\
             (forall ret m' z',
               ext_spec_post Hspec e x (sig_res sig) ret z' m' ->
               exists c',
                 after_external Hcore ret c = Some c' /\
                 safeN n' z' c' m')
       | None, Some i => ext_spec_exit Hspec (Some i) z m
       | Some _, Some _ => False
       end
    end.

  Definition corestep_fun  :=
       forall ge m q m1 q1 m2 q2 ,
       corestep Hcore ge q m q1 m1 ->
       corestep Hcore ge q m q2 m2 ->
       (q1, m1) = (q2, m2).

  Lemma safe_corestep_forward:
     corestep_fun ->
    forall c m c' m' n z,
    corestep Hcore ge c m c' m' -> safeN (S n) z c m -> safeN n z c' m'.
  Proof.
    simpl; intros.
    erewrite corestep_not_at_external in H1; eauto.
    erewrite corestep_not_halted in H1; eauto.
    destruct H1 as [c'' [m'' [? ?]]].
    assert ((c',m') = (c'',m'')).
    eapply H; eauto.
   inv H3; auto.
  Qed.

  Lemma safe_corestep_backward:
    forall c m c' m' n z,
    corestep Hcore ge c m c' m' -> safeN n z c' m' -> safeN (S n) z c m.
  Proof.
    simpl; intros.
    erewrite corestep_not_at_external; eauto.
    erewrite corestep_not_halted; eauto.
  Qed.

  Lemma safe_downward1 :
    forall n c m z,
      safeN (S n) z c m -> safeN n z c m.
  Proof.
    induction n; simpl; intros; auto.
    destruct (at_external Hcore c);
      destruct (halted Hcore c).
    destruct p; auto.
    destruct p. destruct p.
    destruct H as [x ?].
    exists x.
    destruct H. split; auto.
    intros. specialize (H0 ret m' z' H1).
    destruct H0 as [c' [? ?]].
    exists c'; split; auto.
    auto.
    destruct H as [c' [m' [? ?]]].
    exists c'. exists m'; split; auto.
  Qed.

  Lemma safe_downward :
    forall n n' c m z,
      le n' n ->
      safeN n z c m -> safeN n' z c m.
  Proof.
    do 6 intro. revert c m z. induction H; auto.
    intros. apply IHle. apply safe_downward1. auto.
  Qed.

  Lemma convergent_controls_safe :
    forall m q1 q2,
      (at_external Hcore q1 = at_external Hcore q2) ->
      (forall ret q', after_external Hcore ret q1 = Some q' ->
                      after_external Hcore ret q2 = Some q') ->
      (halted Hcore q1 = halted Hcore q2) ->
      (forall q' m', corestep Hcore ge q1 m q' m' -> corestep Hcore ge q2 m q' m') ->
      (forall n z, safeN n z q1 m -> safeN n z q2 m).
  Proof.
    intros. destruct n; simpl in *; auto.
    rewrite H in H3. rewrite H1 in H3.
    destruct (at_external Hcore q2);
      destruct (halted Hcore q2); auto.
    destruct p. destruct p.
    destruct H3 as [x ?].
    exists x.
    destruct H3; split; auto.
    intros. specialize (H4 ret m' z' H5).
    destruct H4 as [c' [? ?]].
    exists c'; split; auto.
    destruct H3 as [c' [m' [? ?]]].
    exists c'. exists m'; split; auto.
  Qed.

Lemma safe_step'_back2 :
  forall
    {ora st m st' m' n},
   corestep Hcore ge st m st' m' ->
   safeN (n-1) ora st' m' ->
   safeN n ora st m.
Proof.
  intros.
  destruct n.
  hnf. auto.
  simpl in H0.
  replace (n-0)%nat with n in H0.
  eapply safe_corestep_backward; eauto.
  omega.
Qed.

Lemma wlog_safeN_gt0 : forall
  n z q m,
  (lt 0 n -> safeN n z q m) ->
  safeN n z q m.
Proof.
  intros. destruct n.
  hnf. auto.
  apply H. omega.
Qed.

End safety.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model RC11 *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition A := unknown_set "A".
Definition ACQ := unknown_set "ACQ".
Definition ACQ_REL := unknown_set "ACQ_REL".
Definition E := unknown_set "E".
Definition REL := unknown_set "REL".
Definition RLX := unknown_set "RLX".
Definition SC := unknown_set "SC".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition mo := co.
Definition sb := po.
Definition myrmw := [RMW] ⊔ rmw.
Definition rb := rf° ⋅ mo ⊓ !id.
Definition eco := (rf ⊔ (mo ⊔ rb))^+.
Definition rs := [W] ⋅ ((sb ⊓ loc ⊔ 1) ⋅ ([(W ⊓ (RLX ⊔ (REL ⊔ (ACQ_REL ⊔ (ACQ ⊔ SC)))))] ⋅ (rf ⋅ myrmw)^*)).
Definition sw := [(REL ⊔ (ACQ_REL ⊔ SC))] ⋅ (([F] ⋅ sb ⊔ 1) ⋅ (rs ⋅ (rf ⋅ ([(R ⊓ (RLX ⊔ (REL ⊔ (ACQ ⊔ (ACQ_REL ⊔ SC)))))] ⋅ ((sb ⋅ [F] ⊔ 1) ⋅ [(ACQ ⊔ (ACQ_REL ⊔ SC))]))))).
Definition hb := (sb ⊔ sw)^+.
Definition sbl := sb ⊓ !loc.
Definition hbl := hb ⊓ loc.
Definition scb := sb ⊔ (sbl ⋅ (hb ⋅ sbl) ⊔ (hbl ⊔ (mo ⊔ rb))).
Definition pscb := ([SC] ⊔ [(F ⊓ SC)] ⋅ (hb ⊔ 1)) ⋅ (scb ⋅ ([SC] ⊔ (hb ⊔ 1) ⋅ [(F ⊓ SC)])).
Definition pscf := [(F ⊓ SC)] ⋅ ((hb ⊔ hb ⋅ (eco ⋅ hb)) ⋅ [(F ⊓ SC)]).
Definition psc := pscb ⊔ pscf.
Definition cnf := ([W] ⋅ top ⋅ [top] ⊔ [top] ⋅ top ⋅ [W]) ⊓ loc ⊓ !([IW] ⋅ top ⋅ [top] ⊔ [top] ⋅ top ⋅ [IW]).
Definition dr := cnf ⊓ ext ⊓ !(hb ⊔ (hb° ⊔ [A] ⋅ top ⋅ [A])).
Definition co0_0 := hb ⋅ eco ⊔ (hb ⊔ myrmw ⋅ eco).
Definition at0 := myrmw ⊓ rb ⋅ mo.
Definition sc0 := psc^* ⊓ [E].
Definition th0 := (sb ⊔ rf)^* ⊓ [E].
Definition Dr := is_empty dr.
Definition coherence1 := irreflexive (hb ⋅ (eco ⊔ 1)).
Definition coherencermw := irreflexive (myrmw ⋅ eco).
Definition atomicity := is_empty (myrmw ⊓ rb ⋅ mo).
Definition SC_0 := acyclic psc.
Definition no_thin_air := acyclic (sb ⊔ rf).
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := Dr /\ (coherence1 /\ (coherencermw /\ (atomicity /\ (SC_0 /\ no_thin_air)))).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc A ACQ ACQ_REL E REL RLX SC tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos cobase coi coe fr fri fre mo sb myrmw rb eco rs sw hb sbl hbl scb pscb pscf psc cnf dr co0_0 at0 sc0 th0 Dr coherence1 coherencermw atomicity SC_0 no_thin_air witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model RC11 *)


Require Import Coq.Logic.FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import Eqdep_dec.

Require Import foltl.
Require Import dec.
Require Import finite.

Section SubInterp.

  Context {Ts: Type} {Tv: Ts->Type} {Tc: Ts->Type} {Tp: Type}.
  Variable srcSig: @Sig Ts Tv Tc Tp.

  Ltac psemTac :=
    match goal with
      H:psem _ _ ?sa |- psem _ _ ?sa' => assert (sa' = sa) as ae;
          try (rewrite ae; assumption); (apply functional_extensionality_dep; intros)
    end.

  Record subInterp {D1 D2: Dom srcSig} (I1: Interp D1) (I2: Interp D2): Type := {
    si_m: forall s, ssem (Dom:=D1) s -> ssem (Dom:=D2) s;
    si_inj: forall s d1 d2, si_m s d1 = si_m s d2 -> d1 = d2;
    si_c: forall s c, csem (Interp:=I2) c = si_m s (csem (Interp:=I1) c);
    si_p: forall p t a, psem (Interp:=I1) p t a <-> psem (Interp:=I2) p t (fun i => si_m _ (a i))
  }.
  Arguments si_m [_ _ _ _ ]_ _.
  Arguments si_inj [_ _ _ _ ].
  Arguments si_c [_ _ _ _ ].
  Arguments si_p [_ _ _ _ ].

  Lemma subItp_refl: forall {D: Dom srcSig} (Itp: Interp D),
    subInterp Itp Itp.
  Proof.
    intros; split with (si_m:=fun s x => x); intros; auto.
    split; intro; psemTac; auto.
  Qed.

  Definition subEnv {D1 D2: Dom srcSig} {I1: Interp D1} {I2: Interp D2} (si: subInterp I1 I2) (env1: Env srcSig D1) (env2: Env srcSig D2) :=
    forall s v, env2 s v = si_m si s (env1 s v).

  Lemma subEnv_add: forall {D1 D2: Dom srcSig} {I1: Interp D1} {I2: Interp D2} (si: subInterp I1 I2) (env1: Env srcSig D1) (env2: Env srcSig D2) s v d,
    subEnv si env1 env2 ->
      subEnv si (add srcSig v d env1) (add srcSig v (si_m si s d) env2).
  Proof.
    repeat intro.
    unfold add.
    destruct (eq_dec s s0).
    subst s0.
    destruct (eq_dec v v0); auto.
    apply H.
  Qed.

  Lemma subEnv_iadd: forall {D1 D2: Dom srcSig} {I1: Interp D1} {I2: Interp D2} (si: subInterp I1 I2) (env1: Env srcSig D1) (env2: Env srcSig D2)
    `(K: Finite) (sk: K->Sort) (vk: forall k, variable (sk k)) (dk: forall k, ssem (sk k)),
    subEnv si env1 env2 ->
      subEnv si (iadd srcSig K sk vk dk env1)
                (iadd srcSig K sk vk (fun k : K => si_m si (sk k) (dk k))
                  env2).
  Proof.
    repeat intro.
    unfold iadd.
    destruct (ex_dec (fun k : K => isEq2 (sk k) (vk k) s v)).
    destruct s0 as [k h].
    simpl in h.
    destruct (eq_dec (sk k) s).
    subst s.
    destruct (eq_dec (vk k) v).
    subst v.
    rewrite (proof_irrelevance _ h eq_refl); auto.
    exfalso.
    apply inj_pair2_eq_dec in h; auto.
    apply eq_dec.
    exfalso.
    injection h; clear h; simpl; intros.
    apply (n H1).
    apply H.
  Qed.

  Lemma tm_siSat: forall {D1 D2: Dom srcSig} {I1: Interp D1} {I2: Interp D2} (si: subInterp I1 I2) (env1: Env srcSig D1) (env2: Env srcSig D2) s (tm: term _ s),
    subEnv si env1 env2 ->
      tm_sem srcSig (Itp:=I2) env2 tm = si_m si s (tm_sem srcSig (Itp:=I1) env1 tm).
  Proof.
    intros.
    destruct tm; simpl.
    apply H.
    apply (si_c si).
  Qed.

  Lemma lt_siSat: forall {D1 D2: Dom srcSig} {I1: Interp D1} {I2: Interp D2} (si: subInterp I1 I2) (env1: Env srcSig D1) (env2: Env srcSig D2) a t,
    subEnv si env1 env2 ->
      lt_sem srcSig (Itp:=I2) env2 a t <-> lt_sem srcSig (Itp:=I1) env1 a t.
  Proof.
    intros.
    destruct a; simpl in *.
    rewrite (si_p si).
    split; intro.
    psemTac.
    symmetry; apply tm_siSat; auto.
    psemTac.
    apply tm_siSat; auto.
  Qed.

  Lemma at_siSat: forall {D1 D2: Dom srcSig} {I1: Interp D1} {I2: Interp D2} (si: subInterp I1 I2) (env1: Env srcSig D1) (env2: Env srcSig D2) a t,
    subEnv si env1 env2 ->
      at_sem srcSig (Itp:=I2) env2 a t <-> at_sem srcSig (Itp:=I1) env1 a t.
  Proof.
    intros.
    destruct a; simpl in *.
    apply lt_siSat with (si0:=si); auto.
    apply not_iff_compat.
    apply lt_siSat with (si0:=si); now auto.
    rewrite tm_siSat with (si0:=si) (env3:=env1); auto.
    rewrite tm_siSat with (si0:=si) (env3:=env1); auto.
    split; intro.
    apply si_inj in H0; apply H0.
    f_equal; apply H0.

    apply not_iff_compat.
    rewrite tm_siSat with (si0:=si) (env3:=env1); auto.
    rewrite tm_siSat with (si0:=si) (env3:=env1); auto.
    split; intro.
    apply si_inj in H0; apply H0.
    f_equal; apply H0.
  Qed.

  Theorem fm_siSat: forall {D1 D2: Dom srcSig} (I1: Interp D1) (I2: Interp D2) (si: subInterp I1 I2) f (env1: Env srcSig D1) (env2: Env srcSig D2) t,
    noEx srcSig f -> subEnv si env1 env2 ->
      fm_sem srcSig (Itp:=I2) env2 f t ->
        fm_sem srcSig (Itp:=I1) env1 f t.
  Proof.
    induction f; simpl; intros; try tauto.
  - revert H1; apply (at_siSat si); auto.
  - destruct H1.
    split; [revert H1; apply IHf1 | revert H2; apply IHf2]; intros; auto; tauto.
  - destruct H1; [left; revert H1; apply IHf1 | right; revert H1; apply IHf2]; auto; tauto.
  - specialize H1 with (si_m si _ d).
    revert H1; apply IHf; auto.
    apply subEnv_add; auto.
  - destruct H1 as [t' [h1 h2]].
    exists t'; split; auto.
    revert h2; apply IHf; auto.
  - generalize (H1 t' H2); clear H1; intro.
    revert H1; apply IHf; auto.
  Qed.

End SubInterp.


Require Import Coq.Strings.String.

Require Export SystemFR.ScalaDepSugar.
Require Export SystemFR.ErasedRecGen.
Require Export SystemFR.StepTactics.

Opaque reducible_values.

Lemma evaluate_list_match:
  forall ρ v t2 t3,
    valid_interpretation ρ ->
    wf t2 0 ->
    wf t3 2 ->
    is_erased_term t2 ->
    is_erased_term t3 ->
    pfv t2 term_var = nil ->
    pfv t3 term_var = nil ->
    [ ρ ⊨ v : List ]v -> (
      (v = tnil /\ list_match v t2 t3 ~>* t2) \/
      (exists h l,
         closed_value h /\
         closed_value l /\
         v = tcons h l /\
         [ ρ ⊨ h : T_top ]v /\
         [ ρ ⊨ l : List ]v /\
         [ list_match v t2 t3 ≡ open 0 (open 1 t3 h) l ]
      )
    ).
Proof.
  unfold List, list_match.
  intros.
  apply (reducible_values_unfold_gen _ _ _ _ 0) in H6;
    repeat step || simp_spos.
    simp_red_top_level_hyp; repeat step.

  - simp_red_top_level_hyp; left; steps; one_step.
  - simp_red_top_level_hyp; right; steps.
    eexists; eexists; repeat step || simp_red_goal; t_closer; eauto using reducible_value_expr.
    apply equivalent_trans with (open 0 (open 1 t3 (pi1 (pp a b))) (pi2 (pp a b))).
    + equivalent_star;
        eauto 3 with erased step_tactic;
        eauto 3 with wf step_tactic;
        try solve [ repeat apply pfv_shift_open || step ].

      apply star_one.
      eapply scbv_step_same.
      * apply SPBetaMatchRight; t_closer.
      * rewrite open_shift_open3; steps; t_closer;
          eauto 3 with wf step_tactic.
        rewrite open_shift_open4; steps; t_closer;
          eauto 3 with wf step_tactic.
        rewrite no_shift_open; t_closer.
        rewrite no_shift_open; t_closer.
        rewrite open_twice; steps; t_closer.

    + eapply equivalent_trans.
      * apply equivalent_context; steps;
          try solve [ apply is_erased_open; steps; t_closer ];
          try solve [ apply wf_open; steps; t_closer ];
          try solve [ apply fv_nils_open; steps; t_closer ].
        apply equivalent_star; repeat step || list_utils; t_closer.
        apply star_one.
        constructor; t_closer.
      * rewrite (swap_term_holes_open t3); steps; t_closer.
        rewrite (swap_term_holes_open t3); steps; t_closer.
        apply equivalent_context; steps;
          try solve [ apply is_erased_open; steps; t_closer ];
          try solve [ apply wf_open; steps; t_closer ];
          try solve [ apply fv_nils_open; steps; t_closer ];
          try solve [ apply wf_open; steps; t_closer; eauto with wf ].
        apply equivalent_star; repeat step || list_utils; t_closer.
        apply star_one.
        constructor; t_closer.
Qed.

Ltac evaluate_list_match :=
  match goal with
  | H: valid_interpretation ?ρ |- context[list_match ?v ?t2 ?t3] =>
    poseNew (Mark (v, t2, t3) "evaluate_list_match");
    unshelve epose proof (evaluate_list_match ρ v t2 t3 _ _ _ _ _ _ _ _)
  | H: valid_interpretation ?ρ, H2: context[list_match ?v ?t2 ?t3] |- _ =>
    poseNew (Mark (v, t2, t3) "evaluate_list_match");
    unshelve epose proof (evaluate_list_match ρ v t2 t3 _ _ _ _ _ _ _ _)
  | H: context[list_match ?v ?t2 ?t3] |- _ =>
    poseNew (Mark (v, t2, t3) "evaluate_list_match");
    unshelve epose proof (evaluate_list_match nil v t2 t3 _ _ _ _ _ _ _ _)
  end.

Lemma evaluate_list_match_scrut:
  forall t t' t2 t3,
    t ~>* t' ->
    list_match t t2 t3 ~>* list_match t' t2 t3.
Proof.
  unfold list_match; steps; eauto with cbvlemmas.
Qed.

Lemma evaluate_list_match2:
  forall ρ t t2 t3,
    valid_interpretation ρ ->
    wf t2 0 ->
    wf t3 2 ->
    is_erased_term t2 ->
    is_erased_term t3 ->
    pfv t2 term_var = nil ->
    pfv t3 term_var = nil ->
    [ ρ ⊨ t : List ] -> (
      (t ~>* tnil /\ list_match t t2 t3 ~>* t2) \/
      (exists h l,
         closed_value h /\
         closed_value l /\
         t ~>* tcons h l /\
         [ ρ ⊨ h : T_top ]v /\
         [ ρ ⊨ l : List ]v /\
         [ list_match t t2 t3 ≡ open 0 (open 1 t3 h) l ]
      )
    ).
Proof.
  intros.
  unfold reduces_to in * |-; steps.
  unshelve epose proof (evaluate_list_match ρ v t2 t3 _ _ _ _ _ _ _ _); steps.
  - left; steps; eauto using star_trans, evaluate_list_match_scrut.
  - right; exists h, l; steps.
    eapply equivalent_trans; eauto; equivalent_star; eauto using evaluate_list_match_scrut.
Qed.

Ltac evaluate_list_match2 :=
  match goal with
  | H: valid_interpretation ?ρ |- context[list_match ?t ?t2 ?t3] =>
    poseNew (Mark (t, t2, t3) "evaluate_list_match2");
    unshelve epose proof (evaluate_list_match2 ρ t t2 t3 _ _ _ _ _ _ _ _)
  | H: valid_interpretation ?ρ, _: context[list_match ?t ?t2 ?t3] |- _ =>
    poseNew (Mark (t, t2, t3) "evaluate_list_match2");
    unshelve epose proof (evaluate_list_match2 ρ t t2 t3 _ _ _ _ _ _ _ _)
  | _: context[list_match ?t ?t2 ?t3] |- _ =>
    poseNew (Mark (t, t2, t3) "evaluate_list_match2");
    unshelve epose proof (evaluate_list_match2 nil t t2 t3 _ _ _ _ _ _ _ _)
  end.


From iris.proofmode Require Import tactics.
From iris.algebra Require Import lib.excl_auth gmap agree.
From iris.base_logic.lib Require Export invariants.
From iris Require Import options.
Import uPred.

(** The CMRAs we need. *)
Class boxG Σ :=
  boxG_inG :> inG Σ (prodR
    (excl_authR boolO)
    (optionR (agreeR (laterO (iPropO Σ))))).

Definition boxΣ : gFunctors := #[ GFunctor (excl_authR boolO *
                                            optionRF (agreeRF (▶ ∙)) ) ].

Instance subG_boxΣ Σ : subG boxΣ Σ → boxG Σ.
Proof. solve_inG. Qed.

Section box_defs.
  Context `{!invG Σ, !boxG Σ} (N : namespace).

  Definition slice_name := gname.

  Definition box_own_auth (γ : slice_name) (a : excl_authR boolO) : iProp Σ :=
    own γ (a, None).

  Definition box_own_prop (γ : slice_name) (P : iProp Σ) : iProp Σ :=
    own γ (ε, Some (to_agree (Next P))).

  Definition slice_inv (γ : slice_name) (P : iProp Σ) : iProp Σ :=
    ∃ b, box_own_auth γ (●E b) ∗ if b then P else True.

  Definition slice (γ : slice_name) (P : iProp Σ) : iProp Σ :=
    box_own_prop γ P ∗ inv N (slice_inv γ P).

  Definition box (f : gmap slice_name bool) (P : iProp Σ) : iProp Σ :=
    ∃ Φ : slice_name → iProp Σ,
      ▷ (P ≡ [∗ map] γ ↦ _ ∈ f, Φ γ) ∗
      [∗ map] γ ↦ b ∈ f, box_own_auth γ (◯E b) ∗ box_own_prop γ (Φ γ) ∗
                         inv N (slice_inv γ (Φ γ)).
End box_defs.

Instance: Params (@box_own_prop) 3 := {}.
Instance: Params (@slice_inv) 3 := {}.
Instance: Params (@slice) 5 := {}.
Instance: Params (@box) 5 := {}.

Section box.
Context `{!invG Σ, !boxG Σ} (N : namespace).
Implicit Types P Q : iProp Σ.

Global Instance box_own_prop_ne γ : NonExpansive (box_own_prop γ).
Proof. solve_proper. Qed.
Global Instance box_own_prop_contractive γ : Contractive (box_own_prop γ).
Proof. solve_contractive. Qed.

Global Instance box_inv_ne γ : NonExpansive (slice_inv γ).
Proof. solve_proper. Qed.

Global Instance slice_ne γ : NonExpansive (slice N γ).
Proof. solve_proper. Qed.
Global Instance slice_contractive γ : Contractive (slice N γ).
Proof. solve_contractive. Qed.
Global Instance slice_proper γ : Proper ((≡) ==> (≡)) (slice N γ).
Proof. apply ne_proper, _. Qed.

Global Instance slice_persistent γ P : Persistent (slice N γ P).
Proof. apply _. Qed.

Global Instance box_contractive f : Contractive (box N f).
Proof. solve_contractive. Qed.
Global Instance box_ne f : NonExpansive (box N f).
Proof. apply (contractive_ne _). Qed.
Global Instance box_proper f : Proper ((≡) ==> (≡)) (box N f).
Proof. apply ne_proper, _. Qed.

Lemma box_own_auth_agree γ b1 b2 :
  box_own_auth γ (●E b1) ∗ box_own_auth γ (◯E b2) ⊢ ⌜b1 = b2⌝.
Proof.
  rewrite /box_own_prop -own_op own_valid prod_validI /= and_elim_l.
  by iDestruct 1 as %?%excl_auth_agree_L.
Qed.

Lemma box_own_auth_update γ b1 b2 b3 :
  box_own_auth γ (●E b1) ∗ box_own_auth γ (◯E b2)
  ==∗ box_own_auth γ (●E b3) ∗ box_own_auth γ (◯E b3).
Proof.
  rewrite /box_own_auth -!own_op. apply own_update, prod_update; last done.
  apply excl_auth_update.
Qed.

Lemma box_own_agree γ Q1 Q2 :
  box_own_prop γ Q1 ∗ box_own_prop γ Q2 ⊢ ▷ (Q1 ≡ Q2).
Proof.
  rewrite /box_own_prop -own_op own_valid prod_validI /= and_elim_r.
  by rewrite option_validI /= agree_validI agree_equivI later_equivI /=.
Qed.

Lemma box_alloc : ⊢ box N ∅ True.
Proof.
  iIntros. iExists (λ _, True)%I. by rewrite !big_opM_empty.
Qed.

Lemma slice_insert_empty E q f Q P :
  ▷?q box N f P ={E}=∗ ∃ γ, ⌜f !! γ = None⌝ ∗
    slice N γ Q ∗ ▷?q box N (<[γ:=false]> f) (Q ∗ P).
Proof.
  iDestruct 1 as (Φ) "[#HeqP Hf]".
  iMod (own_alloc_cofinite (●E false ⋅ ◯E false,
    Some (to_agree (Next Q))) (dom _ f))
    as (γ) "[Hdom Hγ]"; first by (split; [apply auth_both_valid_discrete|]).
  rewrite pair_split. iDestruct "Hγ" as "[[Hγ Hγ'] #HγQ]".
  iDestruct "Hdom" as % ?%not_elem_of_dom.
  iMod (inv_alloc N _ (slice_inv γ Q) with "[Hγ]") as "#Hinv".
  { iNext. iExists false; eauto. }
  iModIntro; iExists γ; repeat iSplit; auto.
  iNext. iExists (<[γ:=Q]> Φ); iSplit.
  - iNext. iRewrite "HeqP". by rewrite big_opM_fn_insert'.
  - rewrite (big_opM_fn_insert (λ _ _ P',  _ ∗ _ _ P' ∗ _ _ (_ _ P')))%I //.
    iFrame; eauto.
Qed.

Lemma slice_delete_empty E q f P Q γ :
  ↑N ⊆ E →
  f !! γ = Some false →
  slice N γ Q -∗ ▷?q box N f P ={E}=∗ ∃ P',
    ▷?q (▷ (P ≡ (Q ∗ P')) ∗ box N (delete γ f) P').
Proof.
  iIntros (??) "[#HγQ Hinv] H". iDestruct "H" as (Φ) "[#HeqP Hf]".
  iExists ([∗ map] γ'↦_ ∈ delete γ f, Φ γ')%I.
  iInv N as (b) "[>Hγ _]".
  iDestruct (big_sepM_delete _ f _ false with "Hf")
    as "[[>Hγ' #[HγΦ ?]] ?]"; first done.
  iDestruct (box_own_auth_agree γ b false with "[-]") as %->; first by iFrame.
  iModIntro. iSplitL "Hγ"; first iExists false; eauto.
  iModIntro. iNext. iSplit.
  - iDestruct (box_own_agree γ Q (Φ γ) with "[#]") as "HeqQ"; first by eauto.
    iNext. iRewrite "HeqP". iRewrite "HeqQ". by rewrite -big_opM_delete.
  - iExists Φ; eauto.
Qed.

Lemma slice_fill E q f γ P Q :
  ↑N ⊆ E →
  f !! γ = Some false →
  slice N γ Q -∗ ▷ Q -∗ ▷?q box N f P ={E}=∗ ▷?q box N (<[γ:=true]> f) P.
Proof.
  iIntros (??) "#[HγQ Hinv] HQ H"; iDestruct "H" as (Φ) "[#HeqP Hf]".
  iInv N as (b') "[>Hγ _]".
  iDestruct (big_sepM_delete _ f _ false with "Hf")
    as "[[>Hγ' #[HγΦ Hinv']] ?]"; first done.
  iMod (box_own_auth_update γ b' false true with "[$Hγ $Hγ']") as "[Hγ Hγ']".
  iModIntro. iSplitL "Hγ HQ"; first (iNext; iExists true; by iFrame).
  iModIntro; iNext; iExists Φ; iSplit.
  - by rewrite big_opM_insert_override.
  - rewrite -insert_delete big_opM_insert ?lookup_delete //.
    iFrame; eauto.
Qed.

Lemma slice_empty E q f P Q γ :
  ↑N ⊆ E →
  f !! γ = Some true →
  slice N γ Q -∗ ▷?q box N f P ={E}=∗ ▷ Q ∗ ▷?q box N (<[γ:=false]> f) P.
Proof.
  iIntros (??) "#[HγQ Hinv] H"; iDestruct "H" as (Φ) "[#HeqP Hf]".
  iInv N as (b) "[>Hγ HQ]".
  iDestruct (big_sepM_delete _ f with "Hf")
    as "[[>Hγ' #[HγΦ Hinv']] ?]"; first done.
  iDestruct (box_own_auth_agree γ b true with "[-]") as %->; first by iFrame.
  iFrame "HQ".
  iMod (box_own_auth_update γ with "[$Hγ $Hγ']") as "[Hγ Hγ']".
  iModIntro. iSplitL "Hγ"; first (iNext; iExists false; by repeat iSplit).
  iModIntro; iNext; iExists Φ; iSplit.
  - by rewrite big_opM_insert_override.
  - rewrite -insert_delete big_opM_insert ?lookup_delete //.
    iFrame; eauto.
Qed.

Lemma slice_insert_full E q f P Q :
  ↑N ⊆ E →
  ▷ Q -∗ ▷?q box N f P ={E}=∗ ∃ γ, ⌜f !! γ = None⌝ ∗
    slice N γ Q ∗ ▷?q box N (<[γ:=true]> f) (Q ∗ P).
Proof.
  iIntros (?) "HQ Hbox".
  iMod (slice_insert_empty with "Hbox") as (γ ?) "[#Hslice Hbox]".
  iExists γ. iFrame "%#". iMod (slice_fill with "Hslice HQ Hbox"); first done.
  by apply lookup_insert. by rewrite insert_insert.
Qed.

Lemma slice_delete_full E q f P Q γ :
  ↑N ⊆ E →
  f !! γ = Some true →
  slice N γ Q -∗ ▷?q box N f P ={E}=∗
  ∃ P', ▷ Q ∗ ▷?q ▷ (P ≡ (Q ∗ P')) ∗ ▷?q box N (delete γ f) P'.
Proof.
  iIntros (??) "#Hslice Hbox".
  iMod (slice_empty with "Hslice Hbox") as "[$ Hbox]"; try done.
  iMod (slice_delete_empty with "Hslice Hbox") as (P') "[Heq Hbox]"; first done.
  { by apply lookup_insert. }
  iExists P'. iFrame. rewrite -insert_delete delete_insert ?lookup_delete //.
Qed.

Lemma box_fill E f P :
  ↑N ⊆ E →
  box N f P -∗ ▷ P ={E}=∗ box N (const true <$> f) P.
Proof.
  iIntros (?) "H HP"; iDestruct "H" as (Φ) "[#HeqP Hf]".
  iExists Φ; iSplitR; first by rewrite big_opM_fmap.
  iEval (rewrite internal_eq_iff later_iff big_sepM_later) in "HeqP".
  iDestruct ("HeqP" with "HP") as "HP".
  iCombine "Hf" "HP" as "Hf".
  rewrite -big_sepM_sep big_opM_fmap; iApply (big_sepM_fupd _ _ f).
  iApply (@big_sepM_impl with "Hf").
  iIntros "!>" (γ b' ?) "[(Hγ' & #$ & #$) HΦ]".
  iInv N as (b) "[>Hγ _]".
  iMod (box_own_auth_update γ with "[Hγ Hγ']") as "[Hγ $]"; first by iFrame.
  iModIntro. iSplitL; last done. iNext; iExists true. iFrame.
Qed.

Lemma box_empty E f P :
  ↑N ⊆ E →
  map_Forall (λ _, (true =.)) f →
  box N f P ={E}=∗ ▷ P ∗ box N (const false <$> f) P.
Proof.
  iDestruct 1 as (Φ) "[#HeqP Hf]".
  iAssert (([∗ map] γ↦b ∈ f, ▷ Φ γ) ∗
    [∗ map] γ↦b ∈ f, box_own_auth γ (◯E false) ∗  box_own_prop γ (Φ γ) ∗
      inv N (slice_inv γ (Φ γ)))%I with "[> Hf]" as "[HΦ ?]".
  { rewrite -big_sepM_sep -big_sepM_fupd. iApply (@big_sepM_impl with "[$Hf]").
    iIntros "!>" (γ b ?) "(Hγ' & #HγΦ & #Hinv)".
    assert (true = b) as <- by eauto.
    iInv N as (b) "[>Hγ HΦ]".
    iDestruct (box_own_auth_agree γ b true with "[-]") as %->; first by iFrame.
    iMod (box_own_auth_update γ true true false with "[$Hγ $Hγ']") as "[Hγ $]".
    iModIntro. iSplitL "Hγ"; first (iNext; iExists false; iFrame; eauto).
    iFrame "HγΦ Hinv". by iApply "HΦ". }
  iModIntro; iSplitL "HΦ".
  - rewrite internal_eq_iff later_iff big_sepM_later. by iApply "HeqP".
  - iExists Φ; iSplit; by rewrite big_opM_fmap.
Qed.

Lemma slice_iff E q f P Q Q' γ b :
  ↑N ⊆ E → f !! γ = Some b →
  ▷ □ (Q ↔ Q') -∗ slice N γ Q -∗ ▷?q box N f P ={E}=∗ ∃ γ' P',
    ⌜delete γ f !! γ' = None⌝ ∗ ▷?q ▷ □ (P ↔ P') ∗
    slice N γ' Q' ∗ ▷?q box N (<[γ' := b]>(delete γ f)) P'.
Proof.
  iIntros (??) "#HQQ' #Hs Hb". destruct b.
  - iMod (slice_delete_full with "Hs Hb") as (P') "(HQ & Heq & Hb)"; try done.
    iDestruct ("HQQ'" with "HQ") as "HQ'".
    iMod (slice_insert_full with "HQ' Hb") as (γ' ?) "[#Hs' Hb]"; try done.
    iExists γ', _. iIntros "{$∗ $# $%} !>". do 2 iNext. iRewrite "Heq".
    iIntros "!>". by iSplit; iIntros "[? $]"; iApply "HQQ'".
  - iMod (slice_delete_empty with "Hs Hb") as (P') "(Heq & Hb)"; try done.
    iMod (slice_insert_empty with "Hb") as (γ' ?) "[#Hs' Hb]"; try done.
    iExists γ', (Q' ∗ P')%I. iIntros "{$∗ $# $%} !>".  do 2 iNext. iRewrite "Heq".
    iIntros "!>". by iSplit; iIntros "[? $]"; iApply "HQQ'".
Qed.

Lemma slice_split E q f P Q1 Q2 γ b :
  ↑N ⊆ E → f !! γ = Some b →
  slice N γ (Q1 ∗ Q2) -∗ ▷?q box N f P ={E}=∗ ∃ γ1 γ2,
    ⌜delete γ f !! γ1 = None⌝ ∗ ⌜delete γ f !! γ2 = None⌝ ∗ ⌜γ1 ≠ γ2⌝ ∗
    slice N γ1 Q1 ∗ slice N γ2 Q2 ∗ ▷?q box N (<[γ2 := b]>(<[γ1 := b]>(delete γ f))) P.
Proof.
  iIntros (??) "#Hslice Hbox". destruct b.
  - iMod (slice_delete_full with "Hslice Hbox") as (P') "([HQ1 HQ2] & Heq & Hbox)"; try done.
    iMod (slice_insert_full with "HQ1 Hbox") as (γ1 ?) "[#Hslice1 Hbox]"; first done.
    iMod (slice_insert_full with "HQ2 Hbox") as (γ2 ?) "[#Hslice2 Hbox]"; first done.
    iExists γ1, γ2. iIntros "{$% $#} !>". iSplit; last iSplit; try iPureIntro.
    { by eapply lookup_insert_None. }
    { by apply (lookup_insert_None (delete γ f) γ1 γ2 true). }
    iNext. iApply (internal_eq_rewrite_contractive _ _ (box _ _) with "[Heq] Hbox").
    iNext. iRewrite "Heq". iPureIntro. by rewrite assoc (comm _ Q2).
  - iMod (slice_delete_empty with "Hslice Hbox") as (P') "[Heq Hbox]"; try done.
    iMod (slice_insert_empty with "Hbox") as (γ1 ?) "[#Hslice1 Hbox]".
    iMod (slice_insert_empty with "Hbox") as (γ2 ?) "[#Hslice2 Hbox]".
    iExists γ1, γ2. iIntros "{$% $#} !>". iSplit; last iSplit; try iPureIntro.
    { by eapply lookup_insert_None. }
    { by apply (lookup_insert_None (delete γ f) γ1 γ2 false). }
    iNext. iApply (internal_eq_rewrite_contractive _ _ (box _ _) with "[Heq] Hbox").
    iNext. iRewrite "Heq". iPureIntro. by rewrite assoc (comm _ Q2).
Qed.

Lemma slice_combine E q f P Q1 Q2 γ1 γ2 b :
  ↑N ⊆ E → γ1 ≠ γ2 → f !! γ1 = Some b → f !! γ2 = Some b →
  slice N γ1 Q1 -∗ slice N γ2 Q2 -∗ ▷?q box N f P ={E}=∗ ∃ γ,
    ⌜delete γ2 (delete γ1 f) !! γ = None⌝ ∗ slice N γ (Q1 ∗ Q2) ∗
    ▷?q box N (<[γ := b]>(delete γ2 (delete γ1 f))) P.
Proof.
  iIntros (????) "#Hslice1 #Hslice2 Hbox". destruct b.
  - iMod (slice_delete_full with "Hslice1 Hbox") as (P1) "(HQ1 & Heq1 & Hbox)"; try done.
    iMod (slice_delete_full with "Hslice2 Hbox") as (P2) "(HQ2 & Heq2 & Hbox)"; first done.
    { by simplify_map_eq. }
    iMod (slice_insert_full _ _ _ _ (Q1 ∗ Q2)%I with "[$HQ1 $HQ2] Hbox")
      as (γ ?) "[#Hslice Hbox]"; first done.
    iExists γ. iIntros "{$% $#} !>". iNext.
    iApply (internal_eq_rewrite_contractive _ _ (box _ _) with "[Heq1 Heq2] Hbox").
    iNext. iRewrite "Heq1". iRewrite "Heq2". by rewrite assoc.
  - iMod (slice_delete_empty with "Hslice1 Hbox") as (P1) "(Heq1 & Hbox)"; try done.
    iMod (slice_delete_empty with "Hslice2 Hbox") as (P2) "(Heq2 & Hbox)"; first done.
    { by simplify_map_eq. }
    iMod (slice_insert_empty with "Hbox") as (γ ?) "[#Hslice Hbox]".
    iExists γ. iIntros "{$% $#} !>". iNext.
    iApply (internal_eq_rewrite_contractive _ _ (box _ _) with "[Heq1 Heq2] Hbox").
    iNext. iRewrite "Heq1". iRewrite "Heq2". by rewrite assoc.
Qed.
End box.

Typeclasses Opaque slice box.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import machine_int.
Import MachineInt.
Require Import mips_cmd.
Import expr_m.
Require Import pick_sign_prg multi_lt_prg multi_add_u_u_prg multi_sub_u_u_prg.
Require Import multi_negate_prg copy_s_u_prg multi_is_zero_u_prg abs_prg.
Require Import multi_zero_s_prg copy_s_s_prg.

Local Open Scope mips_cmd_scope.

(** z <- x + y with z, x signed and y unsigned *)
Definition multi_add_s_s_u0 rk rz rx ry a0 a1 a2 a3 a4 ret X Z : while.cmd :=
   lw Z four16 rz ;
   lw X four16 rx ;
   pick_sign rx a0 a1 ;
   If_bgez a1 Then (* 0 <= x ? *)
     If_beq a1, r0 Then (* x = 0 ? *)
       copy_s_u rk rz ry a0 a1 a2 a3 ;
       addiu a3 r0 zero16
     Else (* 0 < x *) (* NB: a1 = 1 *)
       multi_add_u_u rk a1 ry X Z a2 a3 a4 ;
       mflo a3;
       sw rk zero16 rz (* fix size *)
   Else (* x < 0 *)
   (multi_lt rk ry X a0 a1 ret a2 a3 a4 ;
    If_beq ret, r0 Then (* ry >= X ? *)
      If_beq a2, r0 Then (* Y = X *)
        multi_zero_s rz ; (* fix size *)
        addiu a3 r0 zero16 (* no overflow *)
      Else (* Y > X *)
        multi_sub_u_u rk ry X Z a0 a1 a2 a3 a4 ret;
        sw rk zero16 rz (* fix size *)
    Else (* ry < X *)
     (multi_sub_u_u rk X ry Z a0 a1 ret a3 a2 a4;
      subu a0 r0 rk ;
      sw a0 zero16 rz
     )).

Definition multi_add_s_s_u rk rz rx ry a0 a1 a2 a3 a4 ret X Z :=
  multi_is_zero_u rk ry a0 a1 a2 ;
  If_bne a2 , r0 Then (* y = 0 ? *)
    copy_s_s rk rz rx a0 a1 a2 a3 a4 ;
    addiu a3 r0 zero16 (* no overflow *)
  Else (* y <> 0 *)
    multi_add_s_s_u0 rk rz rx ry a0 a1 a2 a3 a4 ret X Z.


Require Import Infrastructure.

(* ********************************************************************** *)
(** * Properties of disjointness *)

Lemma disjoint_and : forall Δ A B C,
    lc_sty A ->
    disjoint Δ A (sty_and B C) <->
    disjoint Δ A B /\ disjoint Δ A C.
Proof with eauto.
  introv LCA.
  induction LCA.

  - splits.

    introv Dis.
    inverts Dis as WF1 WF2 TL.
    inverts TL.
    inverts WF2.
    inverts TL.
    splits...
    splits...

    introv Dis.
    destruct Dis...

  - splits.

    introv Dis.
    lets (? & Wft): disjoint_regular Dis.
    inverts Wft...

    introv Dis.
    destruct Dis...

  - splits.

    introv Dis.
    inverts Dis as WF1 WF2 TL.
    inverts TL.
    inverts WF2.
    inverts TL.
    splits...
    splits...

    introv Dis.
    inverts Dis...

  - splits.

    introv Dis.
    inverts Dis as WF1 WF2 TL.
    inverts TL.
    inverts WF2.
    inverts TL.
    splits...
    splits...

    splits...
    forwards (c1 & c2 & Sub1 & Sub2) : sub_andr WF2...
    forwards (c1 & c2 & Sub1 & Sub2) : sub_andr WF2...

    introv Dis.
    destruct Dis...

  - splits.

    introv Dis.
    inverts Dis as WF1 WF2 TL.
    inverts TL.
    inverts WF1.
    inverts WF2.
    splits...
    inverts TL.
    inverts WF1.
    inverts WF2.
    splits...

    splits...

    introv Dis.
    inverts Dis...

  - splits.

    introv Dis.
    inverts Dis as WF1 WF2 TL.
    inverts TL.
    inverts WF1.
    inverts WF2.
    splits...
    inverts TL.
    inverts WF1.
    inverts WF2.
    splits...

    apply IHLCA1 in WF1...
    apply IHLCA2 in WF2...
    destructs WF1...
    destructs WF2...

    splits...

    introv Dis.
    inverts Dis...

  - splits.

    introv Dis.
    inverts Dis as WF1 WF2 TL...
    inverts TL.
    inverts WF1.
    splits...
    inverts TL.
    inverts WF2.
    splits...

    introv Dis.
    inverts Dis...

  - splits.

    introv Dis.
    inverts Dis as WF1 WF2 TL...
    inverts TL.
    inverts WF1.
    inverts WF2.
    splits...
    inverts TL.
    inverts WF1.
    inverts WF2.
    splits...

    introv Dis.
    inverts Dis...

Qed.

Lemma disjoint_narrow : forall F X U T E A B c,
    disjoint (F ++ X ~ U ++ E) A B ->
    sub E T U c ->
    uniq (F ++ X ~ U ++ E) ->
    disjoint (F ++ X ~ T ++ E) A B.
Proof with eauto using swft_narrow, sub_narrow.
  introv Dis.
  remember (F ++ X ~ U ++ E) as G.
  generalize dependent F.
  induction Dis; introv EQ Uniq Sub; subst...

  - Case "Var1".
    analyze_binds_uniq H...
    assert (sub (F ++ X ~ T ++ E) T B (co_trans c0 c)).
      eapply S_trans...
      rewrite_env (nil ++ (F ++ [(X, T)]) ++ E).
      apply sub_weakening...
      solve_uniq.
    eapply D_tvarL...

  - Case "Var2".
    analyze_binds_uniq H...
    assert (sub (F ++ X ~ T ++ E) T B (co_trans c0 c)).
      eapply S_trans...
      rewrite_env (nil ++ (F ++ [(X, T)]) ++ E).
      apply sub_weakening...
      solve_uniq.
    eapply D_tvarR...

  - Case "forall".
    pick fresh Y and apply D_forall...
    rewrite_env (([(Y, sty_and A1 A2)] ++ F) ++ [(X, T)] ++ E)...
Qed.

Lemma disjoint_symmetric: forall Δ A B,
    disjoint Δ A B ->
    uniq Δ ->
    disjoint Δ B A.
Proof with eauto.
  introv Dis.
  induction Dis; introv Uniq...
  pick fresh X and apply D_forall...

  rewrite_env (nil ++ [(X, sty_and A2 A1)] ++ DD).
  eapply disjoint_narrow...
Qed.

Inductive BotDisjoint : stctx -> sty -> Prop :=
| bl_bot : forall Δ A,
    TopLike A ->
    BotDisjoint Δ A
| bl_and : forall Δ A B,
    BotDisjoint Δ A ->
    BotDisjoint Δ B ->
    BotDisjoint Δ (sty_and A B)
| bl_tvar : forall Δ A X c,
    binds X A Δ ->
    sub Δ A sty_bot c ->
    BotDisjoint Δ (sty_var_f X).

Hint Constructors BotDisjoint.

Lemma bot_disjoint : forall Δ A B,
    BotDisjoint Δ A ->
    swft Δ A ->
    swft Δ B ->
    disjoint Δ A B.
Proof with eauto.
  introv Bob.
  gen B.

  induction Bob; introv SWFT1 SWFT2; simpls...

  inverts SWFT1...
Qed.

Lemma disjoint_bot : forall Δ A,
    lc_sty A ->
    uniq Δ ->
    disjoint Δ A sty_bot ->
    BotDisjoint Δ A.

Proof with eauto.
  introv LC.
  gen Δ.
  induction LC; introv Uniq Dis; simpls...

  - inverts Dis as ? HH1 HH2; inverts HH2.
  - inverts Dis as ? HH1 HH2; inverts HH2.
  - inverts Dis as ? HH1 HH2; try solve [inverts HH2]; simpls...
  - inverts Dis as ? HH1 HH2; try solve [inverts HH2]; simpls...
  - inverts Dis as ? HH1 HH2; try solve [inverts HH2]; simpls...
  - inverts Dis as ? HH1 HH2; try solve [inverts HH2]; simpls...
  - inverts Dis as ? HH1 HH2; try solve [inverts HH2]; simpls...
Qed.

Lemma TopLike_sub : forall Δ A B c,
    sub Δ A B c ->
    TopLike A ->
    TopLike B.
Proof with eauto.
  introv Sub.
  induction Sub; introv TT; try solve [inverts TT; auto]; simpls...

  inverts TT.

  pick fresh X and apply tl_all...

  inverts TT as TT1 TT2.
  inverts TT1...
  inverts TT2...

  inverts TT as TT1 TT2.
  inverts TT1...
  inverts TT2...

  inverts TT as TT1 TT2.
  inverts TT1.
  inverts TT2.
  pick fresh X and apply tl_all...
  unfold open_sty_wrt_sty.
  simpls...

  Unshelve.
  exact (dom DD).
Qed.

Lemma  sub_TopLike_aux : forall Δ B,
    TopLike B ->
    uniq Δ ->
    swft Δ B ->
    exists c, sub Δ sty_top B c.
Proof with eauto.
  introv Bob.
  gen Δ.

  induction Bob; introv Uniq WFT; simpls...

  - Case "and".
    inverts WFT.
    forwards (c1 & ?) : IHBob1...
    forwards (c2 & ?) : IHBob2...

  - Case "arr".
    inverts WFT.
    forwards (c & ?) : IHBob...

  - Case "all".
    inverts WFT.
    pick fresh X.
    forwards (c & ?): H0 X ([(X, A)] ++ Δ)...
    exists (co_trans (co_forall c) co_topAll).
    eapply S_trans...
    pick fresh Y and apply S_forall...
    eapply sub_renaming...

  - Case "rcd".
    inverts WFT...
    forwards (c & ?) : IHBob...
Qed.

Lemma sub_TopLike : forall Δ A B,
    TopLike B ->
    uniq Δ ->
    swft Δ A ->
    swft Δ B ->
    exists c, sub Δ A B c.
Proof with eauto.
  introv TT ? ? ?.

  forwards (c & ?) : sub_TopLike_aux TT...
Qed.

Lemma disjoint_sub : forall Δ Δ' A B C c,
    sub Δ' B C c ->
    same_stctx Δ' Δ ->
    swfte Δ ->
    disjoint Δ A B ->
    disjoint Δ A C.
Proof with eauto using swft_type.
  introv Sub.
  gen A Δ.

  induction Sub; introv Same Wfte Dis...

  - Case "top".
    lets (? & ?) : disjoint_regular Dis...

  -Case "bot".
   forwards (WFA & ?) : disjoint_regular Dis...
   forwards : disjoint_bot Dis...
   eapply bot_disjoint...

  - Case "topArr".
    forwards (WFA & ?) : disjoint_regular Dis...

  - Case "topRcd".
    forwards (WFA & ?) : disjoint_regular Dis...

  - Case "topAll".
    forwards (WFA & ?) : disjoint_regular Dis...

  - Case "arr".
    forwards (WFA & WFB) : disjoint_regular Dis...
    apply sub_change with (Δ' := Δ) in Sub1...
    apply sub_change with (Δ' := Δ) in Sub2...
    inverts WFB.
    forwards (? & ?) : sub_regular Sub1...
    forwards (? & ?) : sub_regular Sub2...
    induction WFA...

    + SCase "A is bot".
      inverts Dis as WF1 WF2 WF3; auto.
      eapply D_topR...
      inverts WF3...
      constructor.
      eapply TopLike_sub...

    + SCase "A is var".
      inverts Dis as WF1 WF2 WF3...
      inverts WF3.
      eapply D_topR...
      constructor.
      eapply TopLike_sub...

    + SCase "A is arrow".
      inverts Dis as WF1 WF2 WF3; auto.
      inverts WF3...

    + SCase "A is and".
      inverts Dis as WF1 WF2 WF3; auto.

  - Case "andl".
    forwards (? & ?) : disjoint_regular Dis...
    apply disjoint_and in Dis...
    destruct Dis...

  - Case "andr".
    forwards (? & ?) : disjoint_regular Dis...
    apply disjoint_and in Dis...
    destruct Dis...

  - Case "forall".
    forwards (WFA & ?) : disjoint_regular Dis...
    assert (Sub2 : sub DD (sty_all A1 B1) (sty_all A2 B2) (co_forall c))...
    apply sub_change with (Δ' := Δ) in Sub...
    apply sub_change with (Δ' := Δ) in Sub2...
    forwards (? & ?) : sub_regular Sub...
    lets (? & ?) : sub_regular Sub2.
    induction WFA...

    + SCase "A is bot".
      inverts Dis as WF1 WF2 WF3; auto.
      eapply D_topR...
      eapply TopLike_sub...

    + SCase "A is var".
      inverts Dis as WF1 WF2 WF3...
      eapply D_topR...
      eapply TopLike_sub...

    + SCase "A is all".
      inverts Dis as WF1 WF2 WF3; auto.
      eapply D_topR...
      eapply TopLike_sub...

      pick fresh X and apply D_forall...
      eapply H0...
      rewrite_env (nil ++ [(X, sty_and A A2)] ++ DD0).
      eapply disjoint_narrow...

    + SCase "A is and".
      inverts Dis as WF1 WF2 WF3; auto.

  - Case "rcd".
    forwards (WFA & ?) : disjoint_regular Dis...
    apply sub_change with (Δ' := Δ) in Sub...
    forwards (? & ?) : sub_regular Sub...
    induction WFA...

    + SCase "A is bot".
      inverts Dis as WF1 WF2 WF3; auto.
      eapply D_topR...
      eapply TopLike_sub...

    + SCase "A is var".
      inverts Dis as WF1 WF2 WF3...
      eapply D_topR...
      eapply TopLike_sub...

    + SCase "A is and".
      inverts Dis as WF1 WF2 WF3; auto.

    + SCase "A is record".
      inverts Dis as WF1 WF2 WF3; auto.
      eapply D_topR...
      eapply TopLike_sub...

  - Case "distArr".
    forwards (WFA & ?) : disjoint_regular Dis...
    apply swft_change with (Δ' := Δ) in H...
    apply swft_change with (Δ' := Δ) in H0...
    apply swft_change with (Δ' := Δ) in H1...
    induction WFA...

    + SCase "A is bot".
      apply disjoint_and in Dis...
      inverts Dis as Dis1 Dis2.
      eapply disjoint_symmetric in Dis1...
      eapply disjoint_symmetric in Dis2...
      eapply disjoint_bot in Dis1...
      inverts Dis1 as Dis1.
      eapply disjoint_bot in Dis2...
      inverts Dis2 as Dis2.
      inverts Dis1.
      inverts Dis2.
      eapply D_topR...

    + SCase "A is var".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT; auto.
      inverts TT as TT1.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT as TT2.
      eapply D_topR...
      forwards : binds_unique WF21 H3; auto.
      substs.
      forwards (c' & ?) : sub_TopLike DD0 A3 TT1...
      assert (sub DD0 (sty_arrow A1 A3) (sty_arrow A1 (sty_and A2 A3)) (co_arr co_id (co_pair c' co_id)))...

      forwards : binds_unique WF11 H3; auto.
      substs.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT as TT.
      forwards (c' & ?) : sub_TopLike DD0 A2 TT...
      assert (sub DD0 (sty_arrow A1 A2) (sty_arrow A1 (sty_and A2 A3)) (co_arr co_id (co_pair co_id c')))...

      forwards : binds_unique WF21 H3; auto.
      substs...

    + SCase "A is arrow".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT; auto.
      inverts TT.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT.
      eapply D_topR...

      inverts WF2 as WF21 WF22 TT1 TT2; auto.
      inverts TT1...

    + SCase "A is and".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT; auto.
      inverts TT.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT.
      eapply D_topR...
      eapply D_andL...

      inverts WF2 as WF21 WF22 TT; auto.

  - Case "distRcd".
    forwards (WFA & ?) : disjoint_regular Dis...
    apply swft_change with (Δ' := Δ) in H...
    apply swft_change with (Δ' := Δ) in H0...
    induction WFA...

    + SCase "A is bot".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      eapply disjoint_symmetric in WF1...
      eapply disjoint_symmetric in WF2...
      forwards WW1: disjoint_bot WF1...
      forwards WW2: disjoint_bot WF2...
      inverts WW1 as WW1.
      inverts WW2 as WW2.
      inverts WW1.
      inverts WW2.
      eapply D_topR...

    + SCase "A is var".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT; auto.
      inverts TT as TT1.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT as TT2.
      eapply D_topR...
      forwards : binds_unique WF21 H2; auto.
      substs.
      forwards (c' & ?) : sub_TopLike DD0 B TT1...
      assert (sub DD0 (sty_rcd l B) (sty_rcd l (sty_and A B)) (co_pair c' co_id))...

      forwards : binds_unique WF11 H2; auto.
      substs.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT as TT.
      forwards (c' & ?) : sub_TopLike DD0 A TT...
      assert (sub DD0 (sty_rcd l A) (sty_rcd l (sty_and A B)) (co_pair co_id c'))...

      forwards : binds_unique WF21 H2; auto.
      substs...

    + SCase "A is and".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT; auto.
      inverts TT.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT.
      eapply D_topR...
      eapply D_andL...

      inverts WF2 as WF21 WF22 TT; auto.

    + SCase "A is record".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT; auto.
      inverts TT.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT.
      eapply D_topR...

      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT.
      eapply D_rcdEq...

  - Case "distPoly".
    forwards (WFA & WFB) : disjoint_regular Dis...
    inverts WFB as WFB1 WFB2.
    assert (swft Δ (sty_all A (sty_and B1 B2))).
      inverts WFB2.
      inverts WFB1.
      pick fresh X and apply swft_all...
      unfold open_sty_wrt_sty.
      simpl...

    induction WFA...

    + SCase "A is bot".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      eapply disjoint_symmetric in WF1...
      eapply disjoint_symmetric in WF2...
      forwards WW1: disjoint_bot WF1...
      forwards WW2: disjoint_bot WF2...
      inverts WW1 as WW1.
      inverts WW2 as WW2.
      inverts WW1 as WW1.
      inverts WW2 as WW2.
      eapply D_topR...
      pick fresh X and apply tl_all.
      forwards : WW1...
      forwards : WW2...
      unfold open_sty_wrt_sty in *.
      simpls...

    + SCase "A is var".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT1; auto.
      inverts WF2 as WF21 WF22 TT2; auto.
      inverts TT1 as TT1.
      inverts TT2 as TT2.
      eapply D_topR...
      pick fresh Y and apply tl_all...
      forwards : TT1...
      forwards : TT2...
      unfold open_sty_wrt_sty in *.
      simpls...

      forwards : binds_unique WF21 H3; auto.
      substs.
      inverts TT1 as TT1.
      inverts WFB1.
      inverts WFB2.
      pick fresh Y.
      forwards TT : TT1 Y...
      clear TT1.
      forwards (c' & Imp): sub_TopLike ([(Y, A)] ++ DD0) (open_sty_wrt_sty B2 (sty_var_f Y)) TT...
      assert (sub DD0 (sty_all A B2) (sty_all A (sty_and B1 B2)) (co_forall (co_pair c' co_id) ))...
      pick fresh Z and apply S_forall...
      forwards Imp' : sub_renaming Y Z Imp...
      unfold open_sty_wrt_sty.
      simpls...

      forwards : binds_unique WF11 H3; auto.
      substs.
      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT as TT.
      inverts WFB1.
      inverts WFB2.
      pick fresh Y.
      forwards TT' : TT Y...
      clear TT.
      forwards (c' & Imp): sub_TopLike ([(Y, A)] ++ DD0) (open_sty_wrt_sty B1 (sty_var_f Y)) TT'...
      assert (sub DD0 (sty_all A B1) (sty_all A (sty_and B1 B2)) (co_forall (co_pair co_id c' ) ))...
      pick fresh Z and apply S_forall...
      forwards Imp' : sub_renaming Y Z Imp...
      unfold open_sty_wrt_sty.
      simpls...

      forwards : binds_unique WF21 H3; auto.
      substs.

      apply D_tvarL with (A := A0) (c := co_trans co_distPoly (co_pair c c0))...
      eapply S_trans...
      eapply S_distPoly...

    + SCase "A is all".

      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT1; auto.
      inverts WF2 as WF21 WF22 TT2; auto.
      inverts TT1 as TT1.
      inverts TT2 as TT2.
      eapply D_topR...
      pick fresh Y and apply tl_all...
      forwards : TT1...
      forwards : TT2...
      unfold open_sty_wrt_sty in *.
      simpls...

      inverts TT1.
      pick fresh X and apply D_forall...
      unfold open_sty_wrt_sty.
      simpls...
      eapply disjoint_and...
      splits...
      eapply D_topR...
      inverts WFB1...
      eapply swft_change...
      econstructor...
      eapply swft_change...
      econstructor...

      inverts WF2 as WF21 WF22 TT; auto.
      inverts TT as TT.
      pick fresh X and apply D_forall...
      unfold open_sty_wrt_sty.
      simpls.
      eapply disjoint_and...
      splits...
      eapply D_topR...
      eapply swft_change...
      econstructor...
      eapply swft_change...
      econstructor...

      pick fresh X and apply D_forall...
      unfold open_sty_wrt_sty.
      simpls...

    + SCase "A is and".
      apply disjoint_and in Dis...
      inverts Dis as WF1 WF2.

      inverts WF1 as WF11 WF12 TT1; auto.
      inverts WF2 as WF21 WF22 TT2; auto.

      inverts WF2 as WF21 WF22 TT; auto.

      (* WTF? *)
      Unshelve.
      exact (dom DD).
      exact (dom DD).

Qed.

Lemma disjoint_weakening : forall G F E A B,
  disjoint (G ++ E) A B ->
  uniq (G ++ F ++ E) ->
  disjoint (G ++ F ++ E) A B.
Proof with eauto using sub_weakening, swft_weaken.
  introv Dis.
  remember (G ++ E) as H.
  generalize dependent G.
  induction Dis; introv EQ Ok; subst...

  pick fresh X and apply D_forall...
  rewrite_env (([(X, sty_and A1 A2)] ++ G) ++ F ++ E).
  eapply H0...
  solve_uniq.
Qed.

(* Lemma disjoint_subst : forall Z E F C A B P, *)
(*   disjoint (F ++ Z ~ C ++ E) A B -> *)
(*   swfte (F ++ Z ~ C ++ E) -> *)
(*   swft E P -> *)
(*   disjoint E P C -> *)
(*   swfte (map (subst_sty_in_sty P Z) F ++ E) -> *)
(*   disjoint (map (subst_sty_in_sty P Z) F ++ E) (subst_sty_in_sty P Z A) (subst_sty_in_sty P Z B). *)
(* Proof with eauto using subst_sty_in_sty_lc_sty, swft_subst_tb, swft_type, same_eq. *)
(*   introv WT EP. *)
(*   remember (F ++ Z ~ C ++ E) as G. *)
(*   generalize dependent F. *)
(*   induction WT; introv Eq Wft Dis Uniq; substs; simpl... *)

(*   constructor; *)
(*   replace (sty_all (subst_sty_in_sty P Z A1) (subst_sty_in_sty P Z B1)) with (subst_sty_in_sty P Z (sty_all A1 B1))... *)
(*   constructor; *)
(*   replace (sty_all (subst_sty_in_sty P Z A1) (subst_sty_in_sty P Z B1)) with (subst_sty_in_sty P Z (sty_all A1 B1))... *)
(*   constructor; *)
(*   replace (sty_all (subst_sty_in_sty P Z A1) (subst_sty_in_sty P Z B1)) with (subst_sty_in_sty P Z (sty_all A1 B1))... *)
(*   constructor; *)
(*   replace (sty_all (subst_sty_in_sty P Z A1) (subst_sty_in_sty P Z B1)) with (subst_sty_in_sty P Z (sty_all A1 B1))... *)
(*   constructor; *)
(*   replace (sty_all (subst_sty_in_sty P Z A1) (subst_sty_in_sty P Z B1)) with (subst_sty_in_sty P Z (sty_all A1 B1))... *)
(*   constructor; *)
(*   replace (sty_all (subst_sty_in_sty P Z A1) (subst_sty_in_sty P Z B1)) with (subst_sty_in_sty P Z (sty_all A1 B1))... *)

(*   - Case "Var1". *)
(*     case_if. *)
(*     substs. *)
(*     analyze_binds_uniq H... *)
(*     substs... *)
(*     apply disjoint_sub with (Δ' := (map (subst_sty_in_sty P Z) F ++ E)) (B := (subst_sty_in_sty P Z C)) (c := c)... *)
(*     eapply sub_subst... *)
(*     replace (subst_sty_in_sty P Z C) with C. *)
(*     rewrite_env (nil ++ map (subst_sty_in_sty P Z) F ++ E). *)
(*     eapply disjoint_weakening... *)
(*     rewrite subst_sty_in_sty_fresh_eq... *)
(*     clear Uniq. *)
(*     eapply swfte_tvar... *)

(*     analyze_binds_uniq H... *)
(*     eapply D_tvarL... *)
(*     eapply sub_subst... *)

(*     eapply D_tvarL... *)
(*     replace A with (subst_sty_in_sty P Z A). *)
(*     eapply sub_subst... *)
(*     rewrite subst_sty_in_sty_fresh_eq... *)
(*     apply swft_tvar with (D := E)... *)
(*     eapply swft_from_swfte... *)
(*     eapply swfte_strength... *)
(*     inverts BindsTacSideCond0... *)

(*   - Case "Var2". *)
(*     eapply disjoint_symmetric... *)
(*     case_if. *)
(*     substs. *)
(*     analyze_binds_uniq H... *)
(*     substs... *)
(*     apply disjoint_sub with (Δ' := (map (subst_sty_in_sty P Z) F ++ E)) (B := (subst_sty_in_sty P Z C)) (c := c)... *)
(*     eapply sub_subst... *)
(*     replace (subst_sty_in_sty P Z C) with C. *)
(*     rewrite_env (nil ++ map (subst_sty_in_sty P Z) F ++ E). *)
(*     eapply disjoint_weakening... *)
(*     rewrite subst_sty_in_sty_fresh_eq... *)
(*     clear Uniq. *)
(*     eapply swfte_tvar... *)

(*     analyze_binds_uniq H... *)
(*     eapply D_tvarL... *)
(*     eapply sub_subst... *)

(*     eapply D_tvarL... *)
(*     replace A with (subst_sty_in_sty P Z A). *)
(*     eapply sub_subst... *)
(*     rewrite subst_sty_in_sty_fresh_eq... *)
(*     apply swft_tvar with (D := E)... *)
(*     eapply swft_from_swfte... *)
(*     eapply swfte_strength... *)
(*     inverts BindsTacSideCond0... *)

(*   - Case "forall". *)

(*     pick fresh Y and apply D_forall... *)
(*     rewrite subst_sty_in_sty_open_sty_wrt_sty_var... *)
(*     rewrite subst_sty_in_sty_open_sty_wrt_sty_var... *)
(*     rewrite_env (map (subst_sty_in_sty P Z) ([(Y, sty_and A1 A2)] ++ F) ++ E). *)
(*     apply H0... *)

(*     simpl; constructor... *)

(* Qed. *)

Lemma rel_d_tvar_disjoint : forall Δ p X A,
    rel_d Δ p ->
    swfte Δ ->
    binds X A Δ ->
    disjoint nil (mtsubst_in_sty p (sty_var_f X) ) (mtsubst_in_sty p A).
Proof with eauto.
  introv RelD.
  gen X A.
  induction RelD; introv Swft Bind; simpls...

  case_if.
  + SCase "X0 = X".
    substs.
    forwards (? & ?): rel_d_uniq RelD.
    analyze_binds_uniq Bind...
    inverts Swft...
    rewrite mtsubst_fresh...
    rewrite subst_sty_in_sty_fresh_eq...
    eapply swft_tvar...
  + SCase "X0 <> X".
    forwards (? & ?): rel_d_uniq RelD.
    analyze_binds_uniq Bind...
    inverts Swft as Swft ?.
    forwards Dis : IHRelD Swft...
    applys_eq Dis 1.
    rewrite subst_sty_in_sty_fresh_eq...
    eapply swft_tvar...
Qed.

Lemma subst_toplike : forall C x B,
    TopLike B ->
    lc_sty C ->
    TopLike (subst_sty_in_sty C x B).
Proof with eauto.
  introv TT.
  gen C x.

  induction TT; introv LC; simpls...

  pick fresh X and apply tl_all...
  rewrite subst_sty_in_sty_open_sty_wrt_sty_var...
Qed.

Lemma mtsubst_toplike : forall Δ p A,
    rel_d Δ p ->
    TopLike A ->
    TopLike (mtsubst_in_sty p A).
Proof with eauto using subst_toplike.
  introv RelD.
  gen A.

  induction RelD; introv TT; simpls...
Qed.

Lemma mtsubst_disjoint_helper : forall A B Δ1 Δ2 p,
    rel_d Δ2 p ->
    swfte (Δ1 ++ Δ2) ->
    disjoint (Δ1 ++ Δ2) A B ->
    disjoint (map (mtsubst_in_sty p) Δ1) (mtsubst_in_sty p A) (mtsubst_in_sty p B).
Proof with eauto using mtsubst_toplike.
  introv Eq Wfte Dis.
  gen p.
  inductions Dis; introv Eq; simpls; autorewrite with lr_rewrite...

  eapply D_axRcdAll...
  rewrite <- mtsubst_forall...

  eapply D_axAllRcd...
  rewrite <- mtsubst_forall...

  eapply D_axAllNat...
  rewrite <- mtsubst_forall...

  eapply D_axNatAll...
  rewrite <- mtsubst_forall...

  eapply D_axArrAll...
  rewrite <- mtsubst_forall...

  eapply D_axAllArr...
  rewrite <- mtsubst_forall...

  + Case "var1".
    analyze_binds_uniq H...
    rewrite mtsubst_tvar_notin...
    apply D_tvarL with (A := (mtsubst_in_sty p A)) (c := c)...
    eapply sub_subst_ctx...
    eapply rel_d_notin...
    forwards : rel_d_tvar_disjoint Eq BindsTac...
    eapply swfte_strength...
    apply disjoint_sub with (Δ' := (map (mtsubst_in_sty p) Δ1)) (B := (mtsubst_in_sty p A)) (c := c)...
    eapply sub_subst_ctx...
    eapply swfte_subst_ctx...
    rewrite_env (nil ++ map (mtsubst_in_sty p) Δ1 ++ nil).
    eapply disjoint_weakening...
    solve_uniq.

  + Case "var2".
    analyze_binds_uniq H...
    rewrite mtsubst_tvar_notin...
    apply D_tvarR with (A := (mtsubst_in_sty p A)) (c := c)...
    eapply sub_subst_ctx...
    eapply rel_d_notin...
    forwards : rel_d_tvar_disjoint Eq BindsTac...
    eapply swfte_strength...
    eapply disjoint_symmetric...
    apply disjoint_sub with (Δ' := (map (mtsubst_in_sty p) Δ1)) (B := (mtsubst_in_sty p A)) (c := c)...
    eapply sub_subst_ctx...
    eapply swfte_subst_ctx...
    rewrite_env (nil ++ map (mtsubst_in_sty p) Δ1 ++ nil).
    eapply disjoint_weakening...
    solve_uniq.
    solve_uniq.

  + Case "forall".
    pick fresh X and apply D_forall; simpl_env...
    lets (? & ?) : rel_d_uniq Eq.
    forwards Imp : H0 X Δ2 ([(X, sty_and A1 A2)] ++ Δ1) p...
    simpl_env...
    simpls...
    erewrite mtsubst_open in Imp...
    rewrite mtsubst_tvar_notin in Imp...
    erewrite mtsubst_open in Imp...
    rewrite mtsubst_tvar_notin in Imp...
    autorewrite with lr_rewrite in Imp...
Qed.

Lemma mtsubst_disjoint : forall A B Δ p,
    rel_d Δ p ->
    swfte Δ ->
    disjoint Δ A B ->
    disjoint nil (mtsubst_in_sty p A) (mtsubst_in_sty p B).
Proof with eauto.
  intros.
  rewrite_env (map (mtsubst_in_sty p) nil).
  eapply mtsubst_disjoint_helper...
Qed.


(** This file contains the common part of the [CNF] modules
   built on top of the module [LLAZY] of lazy literals. *)
Require Import Quote List Ergo.
Require Import BinPos LLazy SemLazy.
Require Import Containers.Sets.
Require Import Cnf Semantics DoubleNegUtils Setoid.

(** * The module type [CNFLAZY_INTERFACE]

   This module defines the interface that a [CNF] module working
   with [LLAZY] literals should match. First, we use [Include Type]
   to include the module [L := LLAZY] of literals, and we define
   a formula as simply being a literal [LLAZY.t].
*)
Module Type CNFLAZY_INTERFACE.
(** Doesnt work for some reason... *)
  Include Type CNF
    with Module L := LLAZY
    with Module Sem := SEMLAZY
    with Definition formula := LLAZY.t.

  Axiom make_1 :
    forall f, make f [=] singleton {f}.

  Definition interp : varmaps -> formula -> Prop
    := LLAZY.interp.

  (** We also require a conversion function [mk_form] that builds
     a formula (a proxy hierarchy) from a concrete reified formula
     of type [Ergo.form]. This conversion should return a semantically
     equivalent formula, as stated by the axiom [cnf].
     Addendum (May 2010) : we now add a prerequisite on a formula for
     the CNF to be correct, it must be well-typed in the sense of
     [Ergo.well_typed_formula].
     *)
  Module Conversion.
    Parameter mk_form : fform -> formula.

    Axiom cnf :
      forall v f, Ergo.well_typed_formula v f ->
        ~~(finterp v f <-> interp v (mk_form f)).
  End Conversion.
End CNFLAZY_INTERFACE.

(** * The module [CNFLAZYCOMMON]

   We also define a module which is the "basis" of all
   modules that match [CNFLAZY_INTERFACE]. Namely, this module
   contains the module of literals, builds the necessary finite
   sets and facts about these sets.
   It also provides the [pick] function used to choose a literal.
   Thanks to this module, we aboid duplication between the different
   variants of [CNFLAZY_INTERFACE] that we will implement.
*)
Module CNFLAZYCOMMON.

  Module Import L := LLAZY.

  Notation lset := (@set L.t L.t_OT (@SetAVLInstance.SetAVL_FSet L.t L.t_OT)).
  Notation clause := (@set L.t L.t_OT
    (@SetListInstance.SetList_FSet L.t L.t_OT)).

  Definition clause_OT : OrderedType clause := SOT_as_OT.
  Existing Instance clause_OT.
  Notation cset := (@set clause clause_OT
    (@SetListInstance.SetList_FSet clause clause_OT)).
(*   Module LSet := FSetList.Make(L). *)

(*   Module Clause := FSetList.Make(L). *)
(*   Module CSet := FSetList.Make(Clause). *)

(*   Module LFacts := WFacts(Clause). *)
(*   Module CFacts := WFacts(CSet). *)

  Definition formula := L.t.

  (** We provide a function that picks the first literal of a problem. *)
  Definition pick (D : cset) :=
    match choose D with
      | None => None
      | Some c =>
        match choose c with
          | Some l => Some (c, l)
          | None => None
        end
    end.

  Fact pick_1 :
    forall (D : cset) (C : clause) (l : L.t),
      pick D = Some (C, l) -> C \In D /\ l \In C.
  Proof.
    intros D c l; unfold pick; case_eq (choose D).
    intros e Hc; case_eq (choose e).
    intros l' Hl' Heq; inversion Heq; subst; split.
    exact (choose_1 Hc). exact (choose_1 Hl').
    intros; discriminate. intros; discriminate.
  Qed.

  Fact pick_2 :
    forall (D : cset),
      (forall C, C \In D -> ~Empty C) ->
      pick D = None -> Empty D.
  Proof.
    intros D HD; unfold pick; case_eq (choose D).
    intros c Hc; case_eq (choose c).
    intros; discriminate.
    intro abs; contradiction
      (HD c (choose_1 Hc) (choose_2 abs)).
    intros empty _; exact (choose_2 empty).
  Qed.

  (** And the adhoc semantics for literals with equations *)
  Module Sem := SEMLAZY.
End CNFLAZYCOMMON.