Require Import ClassicalDescription Lia.

From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import Prog.
Require Import ProgToExecution.
Require Import ProgToExecutionProperties.
Require Import RMWinstrProps.

Set Implicit Arguments.

(******************************************************************************)
(** **  *)
(******************************************************************************)

Lemma ectrl_ctrl_step (tid : thread_id)
         s s' (STEP : step tid s s')
         MOD (ECTRL: exists a, (MOD ∩₁ ectrl s') a)
        (NCTRL: MOD ∩₁ dom_rel ((ctrl (G s'))) ⊆₁ ∅) :
         (G s) = (G s').
Proof using.
destruct STEP; desc.
red in H; desc.
destruct ISTEP0; try done.
all: exfalso; eapply NCTRL.
all: revert ECTRL;  unfolder; splits; try edone.
all: desc; eauto; exists (ThreadEvent tid (eindex s)).
all: rewrite UG; unfold add; ins; rewrite <- UECTRL; basic_solver.
Qed.

Lemma TWF_helper tid s1 (TWF : thread_wf tid s1):
~ acts_set (G s1) (ThreadEvent tid ((eindex s1))).
Proof using.
red in TWF.
intro.
specialize (TWF (ThreadEvent tid (eindex s1)) H); desf.
lia.
Qed.

Lemma TWF_helper_rmw tid s1 (TWF : thread_wf tid s1):
~ acts_set (G s1) (ThreadEvent tid ((eindex s1) + 1)).
Proof using.
red in TWF.
intro.
specialize (TWF (ThreadEvent tid (eindex s1 +1)) H); desf.
lia.
Qed.

Lemma acts_increasing (tid : thread_id) s s' (STEP : step tid s s') :
  (acts_set (G s)) ⊆₁ (acts_set (G s')).
Proof using.
destruct STEP; desc.
red in H; desc.
destruct ISTEP0.
all: rewrite UG; try done.
all: unfold add, add_rmw, acts_set; ins.
all: unfolder; ins; desc; eauto.
Qed.

Lemma is_r_ex_increasing (tid : thread_id) s s' (STEP : step tid s s') (TWF : thread_wf tid s):
  (acts_set (G s)) ∩₁ R_ex (lab (G s)) ⊆₁ R_ex (lab (G s')).
Proof using.
destruct STEP; desc.
red in H; desc.
destruct ISTEP0.
all: rewrite UG; try done.
all: unfold add, add_rmw, R_ex; ins.
all: unfolder; ins; desc; eauto.
all: rewrite !updo; try done.
all: try by (intro; subst; eapply TWF_helper; edone).
all: try by (intro; subst; eapply TWF_helper_rmw; edone).
Qed.

Lemma is_r_increasing (tid : thread_id) s s' (STEP : step tid s s') (TWF : thread_wf tid s):
  (acts_set (G s)) ∩₁ is_r (lab (G s)) ⊆₁ is_r (lab (G s')).
Proof using.
destruct STEP; desc.
red in H; desc.
destruct ISTEP0.
all: rewrite UG; try done.
all: unfold add, add_rmw, is_r; ins.
all: unfolder; ins; desc; eauto.
all: rewrite !updo; try done.
all: try by (intro; subst; eapply TWF_helper; edone).
all: try by (intro; subst; eapply TWF_helper_rmw; edone).
Qed.

Lemma is_w_increasing (tid : thread_id) s s' (STEP : step tid s s') (TWF : thread_wf tid s):
  (acts_set (G s)) ∩₁ is_w (lab (G s)) ⊆₁ is_w (lab (G s')).
Proof using.
destruct STEP; desc.
red in H; desc.
destruct ISTEP0.
all: rewrite UG; try done.
all: unfold add, add_rmw, is_w; ins.
all: unfolder; ins; desc; eauto.
all: rewrite !updo; try done.
all: try by (intro; subst; eapply TWF_helper; edone).
all: try by (intro; subst; eapply TWF_helper_rmw; edone).
Qed.

(******************************************************************************)
(** **  *)
(******************************************************************************)

Lemma regf_expr_helper regf regf' depf MOD expr
  (REGF : forall reg, RegFun.find reg regf = RegFun.find reg regf' \/
           (exists a, RegFun.find reg depf a /\ MOD a))
  (NDEP: forall a (IN: MOD a), ~ DepsFile.expr_deps depf expr a):
  RegFile.eval_expr regf expr = RegFile.eval_expr regf' expr.
Proof using.
unfold DepsFile.expr_deps, DepsFile.val_deps in NDEP.
unfold RegFile.eval_expr, RegFile.eval_value.
destruct expr.
- destruct val; [by vauto| specialize (REGF reg); desf].
  exfalso; eapply NDEP; edone.
- destruct op0; [by vauto| specialize (REGF reg); desf].
  rewrite REGF; auto.
  exfalso; eapply NDEP; edone.
- destruct op1, op2.
* by vauto.
* specialize (REGF reg); desf; [rewrite REGF|]; eauto.
  exfalso; eapply NDEP; [edone| basic_solver].
* specialize (REGF reg); desf; [rewrite REGF|]; eauto.
  exfalso; eapply NDEP; [edone| basic_solver].
* generalize (REGF reg0); intro REGF0.
  specialize (REGF reg).
  desf.
  by rewrite REGF, REGF0; auto.
  all: exfalso; eapply NDEP; [edone| basic_solver].
Qed.

Lemma regf_lexpr_helper regf regf' depf MOD expr
  (REGF : forall reg, RegFun.find reg regf = RegFun.find reg regf' \/
            (exists a, RegFun.find reg depf a /\ MOD a))
  (NDEP: forall a (IN: MOD a), ~ DepsFile.lexpr_deps depf expr a):
  RegFile.eval_lexpr regf expr = RegFile.eval_lexpr regf' expr.
Proof using.
unfold DepsFile.lexpr_deps in NDEP.
unfold RegFile.eval_lexpr.
desf; exfalso; apply n; erewrite regf_expr_helper; eauto.
ins; specialize (REGF reg); desf; eauto.
Qed.

(******************************************************************************)
(** **  *)
(******************************************************************************)

Definition sim_execution G G' MOD :=
      ⟪ ACTS : (acts_set G) = (acts_set G') ⟫ /\
      ⟪ TS: threads_set G ≡₁ threads_set G'⟫ /\
      ⟪ SAME : same_lab_u2v (lab G') (lab G) ⟫ /\
      ⟪ OLD_VAL : forall a (NIN: ~ MOD a), val ((lab G')) a = val ((lab G)) a ⟫ /\
      ⟪ RMW  : (rmw G)  ≡ (rmw G')  ⟫ /\
      ⟪ DATA : (data G) ≡ (data G') ⟫ /\
      ⟪ ADDR : (addr G) ≡ (addr G') ⟫ /\
      ⟪ CTRL : (ctrl G) ≡ (ctrl G') ⟫ /\
      ⟪ FRMW : (rmw_dep G) ≡ (rmw_dep G') ⟫ /\
      ⟪ RRF : (rf G) ≡ (rf G') ⟫ /\
      ⟪ RCO : (co G) ≡ (co G') ⟫.

Definition sim_state s s' MOD (new_rfi : relation actid) new_val :=
      ⟪ INSTRS  : (instrs s) = (instrs s') ⟫ /\
      ⟪ PC  : (pc s) = (pc s') ⟫ /\
      ⟪ EXEC : sim_execution (G s) (G s') MOD ⟫ /\
      ⟪ EINDEX  : (eindex s) = (eindex s') ⟫ /\
      ⟪ REGF  : forall reg, RegFun.find reg (regf s) = RegFun.find reg (regf s') \/
exists a, (RegFun.find reg (depf s)) a /\ MOD a ⟫ /\
      ⟪ DEPF  : (depf s) = (depf s') ⟫ /\
      ⟪ ECTRL  : (ectrl s) = (ectrl s') ⟫ /\
      ⟪ NEW_VAL1 : forall r w (RF: new_rfi w r) (INr: (acts_set (G s')) r)
(INw: (acts_set (G s')) w) (READ: is_r (lab (G s')) r) (WRITE: is_w (lab (G s')) w) (IN_MOD: MOD r),
                     val ((lab (G s'))) r = val ((lab (G s'))) w ⟫ /\
      ⟪ NEW_VAL2 : forall r (READ: is_r (lab (G s')) r) (IN_MOD: MOD r)
                     (IN: (acts_set (G s')) r) (NIN_NEW_RF: ~ (codom_rel new_rfi) r),
                     val ((lab (G s'))) r = Some (new_val r) ⟫.

Lemma sim_execution_same_r G G' MOD (EXEC: sim_execution G G' MOD) :
is_r (lab G') ≡₁ is_r (lab G).
Proof using.
red in EXEC; desf.
eby erewrite same_lab_u2v_is_r.
Qed.

Lemma sim_execution_same_w G G' MOD (EXEC: sim_execution G G' MOD) :
is_w (lab G') ≡₁ is_w (lab G).
Proof using.
red in EXEC; desf.
eby erewrite same_lab_u2v_is_w.
Qed.

Lemma sim_execution_same_acts G G' MOD (EXEC: sim_execution G G' MOD) :
acts_set G ≡₁ acts_set G'.
Proof using.
red in EXEC; desf. by rewrite ACTS.
Qed.

(******************************************************************************)
(** **  *)
(******************************************************************************)

Lemma receptiveness_sim_assign (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (reg : Reg.t) (expr : Instr.expr)
  (ISTEP : Some (Instr.assign reg expr) = nth_error (instrs s1) (pc s1))
  (UPC : pc s2 = pc s1 + 1) (UG : G s2 = G s1)
  (UINDEX : eindex s2 = eindex s1)
  (UREGS : regf s2 = RegFun.add reg (RegFile.eval_expr (regf s1) expr) (regf s1))
  (UDEPS : depf s2 = RegFun.add reg (DepsFile.expr_deps (depf s1) expr) (depf s1))
  (UECTRL : ectrl s2 = ectrl s1)
  MOD (new_rfi : relation actid) new_val
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
red in SIM; desc.
cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.
do 7 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eby eexists; splits; [ rewrite <- INSTRS, <- PC| eapply assign; reflexivity].
  * ins; congruence.
  * ins; congruence.
  * ins; congruence.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf.
    destruct (classic ((exists a : actid, DepsFile.expr_deps (depf s1) expr a /\ MOD a))) as [A|A].
    by auto.
    by left; apply (regf_expr_helper (regf s1) (regf s1') (depf s1) MOD expr REGF); eauto.
  * ins; congruence.
  * ins; congruence.
  * by ins; apply NEW_VAL1; try done; rewrite <- UG.
  * by ins; apply NEW_VAL2; try done; rewrite <- UG.
Qed.

Lemma receptiveness_sim_if_else (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (expr : Instr.expr) (shift : nat)
  (e : RegFile.eval_expr (regf s1) expr = 0)
  (ISTEP : Some (Instr.ifgoto expr shift) = nth_error (instrs s1) (pc s1))
  (UPC : pc s2 = pc s1 + 1) (UG : G s2 = G s1)
  (UINDEX : eindex s2 = eindex s1)
  (UREGS : regf s2 = regf s1)
  (UDEPS : depf s2 = depf s1)
  (UECTRL : ectrl s2 = DepsFile.expr_deps (depf s1) expr ∪₁ ectrl s1)
  MOD (new_rfi : relation actid) new_val
  (NCTRL : MOD ∩₁ ectrl s2 ⊆₁ ∅)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
red in SIM; desc.
cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.
eexists.
  exists (if Const.eq_dec (RegFile.eval_expr (regf s1') expr) 0
        then pc s1' + 1 else shift).
  do 5 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC|].
    eapply if_; try reflexivity; ins; desf.
  * ins; congruence.
  * ins.
    erewrite <- regf_expr_helper with (regf:= regf s1).
    desf; congruence.
    eauto.
    ins; intro; eapply NCTRL; rewrite UECTRL; basic_solver.
  * ins; congruence.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS; eauto.
  * ins; congruence.
  * ins; congruence.
  * by ins; apply NEW_VAL1; try done; rewrite <- UG.
  * by ins; apply NEW_VAL2; try done; rewrite <- UG.
Qed.

Lemma receptiveness_sim_if_then (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (expr : Instr.expr) (shift : nat)
  (n : RegFile.eval_expr (regf s1) expr <> 0)
  (ISTEP : Some (Instr.ifgoto expr shift) = nth_error (instrs s1) (pc s1))
  (UPC : pc s2 = shift) (UG : G s2 = G s1)
  (UINDEX : eindex s2 = eindex s1)
  (UREGS : regf s2 = regf s1)
  (UDEPS : depf s2 = depf s1)
  (UECTRL : ectrl s2 = DepsFile.expr_deps (depf s1) expr ∪₁ ectrl s1)
  MOD (new_rfi : relation actid) new_val
  (NCTRL : MOD ∩₁ ectrl s2 ⊆₁ ∅)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
red in SIM; desc.
cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.
 eexists.
  exists (if Const.eq_dec (RegFile.eval_expr (regf s1') expr) 0
        then pc s1' + 1 else shift).
  do 5 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC|].
    eapply if_; try reflexivity; ins; desf.
  * ins; congruence.
  * ins.
    erewrite <- regf_expr_helper with (regf:= regf s1).
    desf; congruence.
    eauto.
    ins; intro; eapply NCTRL; rewrite UECTRL; basic_solver.
  * ins; congruence.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS; eauto.
  * ins; congruence.
  * ins; congruence.
  * by ins; apply NEW_VAL1; try done; rewrite <- UG.
  * by ins; apply NEW_VAL2; try done; rewrite <- UG.
Qed.

Definition new_rfi_ex (new_rfi :relation actid) :=
new_rfi ∪ ⦗ set_compl (codom_rel new_rfi) ⦘.

Lemma new_rfi_unique (new_rfi : relation actid)
      (new_rfif : functional new_rfi⁻¹):
forall r, exists ! w, (new_rfi_ex new_rfi)⁻¹  r w.
Proof using.
ins.
destruct (classic ((codom_rel new_rfi) r)) as [X|X].
- unfolder in X; desf.
exists x; red; splits.
unfold new_rfi_ex; basic_solver 12.
unfold new_rfi_ex; unfolder; ins; desf.
eapply new_rfif; basic_solver.
exfalso; eauto.
- exists r; red; splits.
unfold new_rfi_ex; basic_solver 12.
unfold new_rfi_ex; unfolder; ins; desf.
unfolder in X; exfalso; eauto.
Qed.

Definition new_write new_rfi new_rfif :=
  unique_choice (new_rfi_ex new_rfi)⁻¹ (@new_rfi_unique new_rfi new_rfif).

Definition get_val (v: option value) :=
  match v with | Some v => v | _ => 0 end.

Lemma RFI_index_helper tid s new_rfi (TWF : thread_wf tid s)
   (RFI_INDEX : new_rfi ⊆ ext_sb)
   w r (RFI: new_rfi w r)
  (IN: ThreadEvent tid (eindex s) = r \/ (acts_set (G s)) r) :
   w <> ThreadEvent tid ((eindex s)).
Proof using.
intro; subst; desf.
apply RFI_INDEX in RFI.
eby eapply ext_sb_irr.
specialize (TWF r IN); desf.
apply RFI_INDEX in RFI.
unfold sb, ext_sb in RFI; unfolder in RFI; desf; lia.
Qed.

Lemma receptiveness_sim_load (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (ord : mode) (reg : Reg.t)
  (lexpr : Instr.lexpr) (ISTEP : Some (Instr.load ord reg lexpr) = nth_error (instrs s1) (pc s1))
  (val_ : value) (UPC : pc s2 = pc s1 + 1)
  (UG : G s2 =
     add (G s1) tid (eindex s1)
       (Aload false ord (RegFile.eval_lexpr (regf s1) lexpr) val_)
       ∅ (DepsFile.lexpr_deps (depf s1) lexpr) (ectrl s1)
       ∅)
  (UINDEX : eindex s2 = eindex s1 + 1)
  (UREGS : regf s2 = RegFun.add reg val_ (regf s1))
  (UDEPS : depf s2 = RegFun.add reg (eq (ThreadEvent tid (eindex s1))) (depf s1))
  (UECTRL : ectrl s2 = ectrl s1)
  MOD (new_rfi : relation actid) new_val
  (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
  (RFI_INDEX : new_rfi ⊆ ext_sb)
  (TWF : thread_wf tid s1)
  (new_rfif : functional new_rfi⁻¹)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
generalize (@new_write new_rfi new_rfif); intro F; destruct F as [new_w F].
red in SIM; desc.

assert (SAME_LOC: RegFile.eval_lexpr (regf s1) lexpr = RegFile.eval_lexpr (regf s1') lexpr).
{ ins; eapply regf_lexpr_helper; eauto.
ins; intro; eapply NADDR; unfolder; splits; eauto.
exists (ThreadEvent tid (eindex s1)).
rewrite UG; unfold add; basic_solver. }

cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.

do 7 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC |].
    eapply load with (val :=
      if excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))
      then if excluded_middle_informative ((codom_rel new_rfi) (ThreadEvent tid (eindex s1')))
           then (get_val (val (lab (G s1')) (new_w (ThreadEvent tid (eindex s1')))))
           else (new_val (ThreadEvent tid (eindex s1')))
      else val_);
    reflexivity.
  * ins; congruence.
  * ins; congruence.
  * ins.
    destruct (G s2) as [acts2 lab2 rmw2 data2 addr2 ctrl2 rf2 co2].
    inversion UG; subst; clear UG.
    red in EXEC; desc.
    red; splits; ins.
    + by rewrite EINDEX, ACTS.
    + by rewrite TS.
    + rewrite EINDEX.
      unfold same_lab_u2v in *; intro e.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1'))).
      { by subst; rewrite !upds. }
      ins. rewrite !updo; auto.
    + rewrite EINDEX.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1'))).
      by desf; unfold val; rewrite !upds.
      unfold val; rewrite !updo; [|intro; desf|intro; desf].
      by apply OLD_VAL in NIN; unfold val in NIN; rewrite NIN.
    + by rewrite DATA, EINDEX.
    + by rewrite ADDR, EINDEX, DEPF.
    + by rewrite CTRL, EINDEX, ECTRL.
    + by rewrite FRMW, EINDEX.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf; eauto.
  * eby ins; rewrite <- DEPF, <- EINDEX.
  * ins; congruence.
  * simpl; ins.
     unfold add, acts_set in INw; ins.
    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'))); subst.
    + exfalso; eapply RFI_index_helper.
      edone.
      eapply RFI_INDEX.
      edone.
      unfold add, acts_set in INr; ins.
      rewrite EINDEX; destruct INr; [eauto|].
      right; eapply sim_execution_same_acts; eauto.
      by rewrite EINDEX.
    + destruct INw as [X|INw]; [desf|].
      destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
      -- unfold val in *; rewrite !upds.
         rewrite !updo; try done.
         destruct (excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))); [|desf].
         destruct (excluded_middle_informative (codom_rel new_rfi (ThreadEvent tid (eindex s1')))).
         2: by exfalso; apply n0; basic_solver 12.
         assert (w = new_w (ThreadEvent tid (eindex s1'))).
         { assert (U: exists ! w1 : actid, (new_rfi_ex new_rfi)⁻¹ (ThreadEvent tid (eindex s1')) w1).
           apply new_rfi_unique, new_rfif.
           eapply unique_existence with
           (P:= fun x => (@new_rfi_ex new_rfi)⁻¹ (ThreadEvent tid (eindex s1')) x) in U; desc.
           eapply U0.
           unfold new_rfi_ex.
           basic_solver.
           apply F. }
         unfold is_w in WRITE; rewrite updo in WRITE; desf.
      -- unfold val in *; rewrite !updo; try done.
         eapply NEW_VAL1; try edone.
         { unfolder in INr. desf. }
         { by unfold is_r in *; rewrite updo in READ. }
           by unfold is_w in *; rewrite updo in WRITE.
  * simpl; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    + destruct (excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))); [subst|desf].
      destruct (excluded_middle_informative (codom_rel new_rfi (ThreadEvent tid (eindex s1')))); [desf|].
      by unfold val in *; rewrite !upds.
    + unfold val in *; rewrite !updo; try done.
      apply NEW_VAL2; try done.
      { by unfold is_r in *; rewrite updo in READ. }
        by unfolder in IN; unfold add in IN; ins; desf.
Qed.

Lemma receptiveness_sim_store (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (ord : mode) (reg : Reg.t)
  (lexpr : Instr.lexpr) (expr : Instr.expr)
  (ISTEP : Some (Instr.store ord lexpr expr) = nth_error (instrs s1) (pc s1))
  (UPC : pc s2 = pc s1 + 1)
  (UG : G s2 = add (G s1) tid (eindex s1)
         (Astore Xpln ord (RegFile.eval_lexpr (regf s1) lexpr) (RegFile.eval_expr (regf s1) expr))
         (DepsFile.expr_deps (depf s1) expr) (DepsFile.lexpr_deps (depf s1) lexpr) (ectrl s1) ∅)
  (UINDEX : eindex s2 = eindex s1 + 1)
  (UREGS : regf s2 = regf s1)
  (UDEPS : depf s2 = depf s1)
  (UECTRL : ectrl s2 = ectrl s1)
  MOD (new_rfi : relation actid) new_val
  (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
  (NDATA: ⦗MOD⦘ ⨾ (data (G s2)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂)
   (RFI_INDEX : new_rfi ⊆ ext_sb)
  (TWF : thread_wf tid s1)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
red in SIM; desc.

assert (SAME_LOC: RegFile.eval_lexpr (regf s1) lexpr = RegFile.eval_lexpr (regf s1') lexpr).
{ ins; eapply regf_lexpr_helper; eauto.
ins; intro; eapply NADDR; unfolder; splits; eauto.
exists (ThreadEvent tid (eindex s1)).
rewrite UG; unfold add; basic_solver. }

cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.

 do 7 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC |].
    eapply store; reflexivity.
  * ins; congruence.
  * ins; congruence.
  * ins.
    destruct (G s2) as [acts2 lab2 rmw2 data2 addr2 ctrl2 rf2 co2].
    inversion UG; subst; clear UG.
    red in EXEC; desc.
    red; splits; ins.
    + by rewrite EINDEX, ACTS.
    + by rewrite TS.
    + rewrite EINDEX.
      unfold same_lab_u2v in *; intro e.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1'))).
      { by subst; rewrite !upds. }
      rewrite !updo; auto.
    + rewrite EINDEX.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1'))); subst.
      -- desf; unfold val; rewrite !upds.
         erewrite regf_expr_helper; try edone.
         intro reg0; specialize (REGF reg0); desf; eauto.
         ins; intro DEPS; eapply NDATA; unfolder; splits; eauto.
         by rewrite EINDEX.
      -- unfold val;  rewrite !updo; try done.
         by apply OLD_VAL in NIN; unfold val in NIN; rewrite NIN.
    + by rewrite DATA, EINDEX, DEPF.
    + by rewrite ADDR, EINDEX, DEPF.
    + by rewrite CTRL, EINDEX, ECTRL.
    + by rewrite FRMW, EINDEX.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf; eauto.
  * by ins; rewrite <- DEPF, <- UDEPS.
  * ins; congruence.
  * simpl; ins.
    unfold add, acts_set in INw; ins.
    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'))); subst.
    + exfalso; eapply RFI_index_helper.
      edone.
      eapply RFI_INDEX.
      edone.
      unfold add, acts_set in INr; ins.
      rewrite EINDEX; destruct INr; [eauto|].
      right; eapply sim_execution_same_acts; eauto.
      by rewrite EINDEX.
    + destruct INw as [X|INw]; [desf|].
      destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
      by unfold is_r in *; rewrite !upds in READ; desf.
      unfold val in *; rewrite !updo; try done.
      eapply NEW_VAL1; try edone.
      { unfolder in INr; desf. }
      { by unfold is_r in *; rewrite updo in READ. }
        by unfold is_w in *; rewrite updo in WRITE.
  * simpl; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    by unfold is_r in *; rewrite upds in READ; desf.
    unfold val; rewrite updo; try done.
    apply NEW_VAL2; try done.
    unfold is_r in *; rewrite updo in READ; try done.
    unfolder in IN. desf.
Qed.

Lemma receptiveness_sim_fence (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (ord : mode)
  (ISTEP : Some (Instr.fence ord) = nth_error (instrs s1) (pc s1))
  (UPC : pc s2 = pc s1 + 1)
  (UG : G s2 = add (G s1) tid (eindex s1) (Afence ord) ∅ ∅ (ectrl s1) ∅)
  (UINDEX : eindex s2 = eindex s1 + 1)
  (UREGS : regf s2 = regf s1)
  (UDEPS : depf s2 = depf s1)
  (UECTRL : ectrl s2 = ectrl s1)
  MOD (new_rfi : relation actid) new_val
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
red in SIM; desc.

cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.

do 7 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC |].
    eapply fence; reflexivity.
  * ins; congruence.
  * ins; congruence.
  * ins.
    destruct (G s2) as [acts2 lab2 rmw2 data2 addr2 ctrl2 rf2 co2].
    inversion UG; subst; clear UG.
    red in EXEC; desc.
    red; splits; ins.
    + by rewrite EINDEX, ACTS.
    + by rewrite TS.
    + rewrite EINDEX.
      unfold same_lab_u2v in *; intro e.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1'))).
      { by subst; rewrite !upds. }
      rewrite !updo; auto.
    + rewrite EINDEX.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1'))).
      by desf; unfold val; rewrite !upds.
      unfold val; rewrite !updo; [|intro; desf|intro; desf].
      by apply OLD_VAL in NIN; unfold val in NIN; rewrite NIN.
    + by rewrite DATA, EINDEX.
    + by rewrite ADDR, EINDEX.
    + by rewrite CTRL, EINDEX, ECTRL.
    + by rewrite FRMW, EINDEX.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf; eauto.
  * by ins; rewrite <- DEPF, <- UDEPS.
  * ins; congruence.
  * ins.
    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'))); subst.
    by unfold is_w in WRITE; rewrite upds in WRITE; desf.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    by unfold is_r in READ; rewrite upds in READ; desf.
    unfold val; rewrite !updo; try done.
    eapply NEW_VAL1; try edone.
    { unfolder in INr; desf. }
    { unfolder in INw; desf. }
    { unfold is_r in *; rewrite updo in READ; try edone. }
    unfold is_w in *; rewrite updo in WRITE; try edone.
  * simpl; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    by unfold is_r in *; rewrite upds in READ; desf.
    unfold val; rewrite updo; try done.
    apply NEW_VAL2; try done.
    unfold is_r in *; rewrite updo in READ; try done.
    unfolder in IN; desf.
Qed.

Lemma receptiveness_sim_cas_fail (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (CASREX : cas_produces_R_ex_instrs (instrs s1))
  (expr_old expr_new : Instr.expr)
  rexmod
  xmod
  (ordr ordw : mode)
  (reg : Reg.t)
  (lexpr : Instr.lexpr)
  (ISTEP : Some (Instr.update (Instr.cas expr_old expr_new) rexmod xmod ordr ordw reg lexpr) =
           nth_error (instrs s1) (pc s1))
  (val_ : value)
  (NEXPECTED : val_ <> RegFile.eval_expr (regf s1) expr_old)
  (UPC : pc s2 = pc s1 + 1)
  (UG : G s2 =
        add (G s1) tid (eindex s1)
            (Aload rexmod ordr (RegFile.eval_lexpr (regf s1) lexpr) val_)
            ∅ (DepsFile.lexpr_deps (depf s1) lexpr) (ectrl s1)
            (DepsFile.expr_deps (depf s1) expr_old))
  (UINDEX : eindex s2 = eindex s1 + 1)
  (UREGS : regf s2 = RegFun.add reg val_ (regf s1))
  (UDEPS : depf s2 = RegFun.add reg (eq (ThreadEvent tid (eindex s1))) (depf s1))
  (UECTRL : ectrl s2 = ectrl s1)
  MOD (new_rfi : relation actid) new_val
  (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s2))) ⊆₁ ∅)
  (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
  (NREX:  MOD ∩₁ (acts_set (G s2)) ∩₁ (R_ex (lab (G s2))) ⊆₁ ∅)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
  exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
red in SIM; desc.
assert (rexmod = true); subst.
{ clear -ISTEP CASREX. red in CASREX.
  set (AA:=ISTEP).
  symmetry in AA. apply nth_error_In in AA.
  apply CASREX in AA. red in AA. desf. }

assert (SAME_LOC: RegFile.eval_lexpr (regf s1) lexpr = RegFile.eval_lexpr (regf s1') lexpr).
{ eapply regf_lexpr_helper; eauto.
ins; intro; eapply NADDR; unfolder; splits; eauto.
exists (ThreadEvent tid (eindex s1)).
rewrite UG; unfold add; basic_solver. }

cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.

do 7 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC |].
    eapply cas_un with (val := val_); try reflexivity.
    erewrite <- regf_expr_helper with (regf := (regf s1)); try edone.
    ins; intro;  eapply NFRMW; rewrite UG; unfold add; ins; basic_solver.
  * ins; congruence.
  * ins; congruence.
  * ins.
    destruct (G s2) as [acts2 lab2 rmw2 data2 addr2 ctrl2 rf2 co2].
    inversion UG; subst; clear UG.
    red in EXEC; desc.
    red; splits; ins.
    + by rewrite EINDEX, ACTS.
    + by rewrite TS.
    + rewrite EINDEX.
      unfold same_lab_u2v in *; intro e.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1'))).
      { by subst; rewrite !upds; rewrite SAME_LOC. }
      rewrite !updo; auto.
    + rewrite EINDEX.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1'))).
      rewrite SAME_LOC.
      by desf; unfold val; rewrite !upds.
      unfold val; rewrite !updo; [|intro; desf|intro; desf].
      by apply OLD_VAL in NIN; unfold val in NIN; rewrite NIN.
    + by rewrite DATA, EINDEX.
    + by rewrite ADDR, EINDEX, DEPF.
    + by rewrite CTRL, EINDEX, ECTRL.
    + by rewrite FRMW, EINDEX, DEPF.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf; eauto.
  * eby ins; rewrite <- DEPF, <- EINDEX.
  * ins; congruence.
  * ins.
    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'))); subst.
    by unfold is_w in WRITE; rewrite upds in WRITE; desf.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    + exfalso.
      eapply NREX; split; [eauto|].
      { rewrite UG; unfold add; ins. split; eauto.
        rewrite EINDEX; basic_solver. }
      rewrite UG; unfold add; unfold R_ex; ins.
        by rewrite EINDEX, upds.
    + unfold val; rewrite !updo; try done.
      eapply NEW_VAL1; try edone.
      { unfolder in INr. desf. }
      { unfolder in INw. desf. }
      { unfold is_r in *; rewrite updo in READ; try edone. }
      unfold is_w in *; rewrite updo in WRITE; try edone.
  * simpl; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    + exfalso.
      eapply NREX; split; [eauto|].
      { rewrite UG; unfold add; ins. split; eauto.
        rewrite EINDEX; basic_solver. }
      rewrite UG; unfold add; unfold R_ex; ins.
      by rewrite EINDEX, upds.
    + unfold val; rewrite updo; try done.
      apply NEW_VAL2; try done.
      unfold is_r in *; rewrite updo in READ; try done.
      unfolder in IN. desf.
Qed.

Lemma receptiveness_sim_cas_suc (tid : thread_id)
  s1 s2 (INSTRS0 : instrs s1 = instrs s2)
  (CASREX : cas_produces_R_ex_instrs (instrs s1))
  (expr_old expr_new : Instr.expr)
  rexmod xmod
  (ordr ordw : mode)
  (reg : Reg.t)
  (lexpr : Instr.lexpr)
  (ISTEP : Some (Instr.update (Instr.cas expr_old expr_new) rexmod xmod ordr ordw reg lexpr) =
           nth_error (instrs s1) (pc s1))
  (UPC : pc s2 = pc s1 + 1)
  (UG : G s2 =
        add_rmw (G s1) tid (eindex s1)
                (Aload rexmod ordr (RegFile.eval_lexpr (regf s1) lexpr)
                       (RegFile.eval_expr (regf s1) expr_old))
                (Astore xmod ordw (RegFile.eval_lexpr (regf s1) lexpr)
                        (RegFile.eval_expr (regf s1) expr_new))
                (DepsFile.expr_deps (depf s1) expr_new)
                (DepsFile.lexpr_deps (depf s1) lexpr) (ectrl s1)
                (DepsFile.expr_deps (depf s1) expr_old))
  (UINDEX : eindex s2 = eindex s1 + 2)
  (UREGS : regf s2 = RegFun.add reg (RegFile.eval_expr (regf s1) expr_old) (regf s1))
  (UDEPS : depf s2 = RegFun.add reg (eq (ThreadEvent tid (eindex s1))) (depf s1))
  (UECTRL : ectrl s2 = ectrl s1)
  MOD (new_rfi : relation actid) new_val
  (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s2))) ⊆₁ ∅)
  (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
  (NREX:  MOD ∩₁ (acts_set (G s2)) ∩₁ (R_ex (lab (G s2))) ⊆₁ ∅)
  (NDATA: ⦗MOD⦘ ⨾ (data (G s2)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂)
  (RFI_INDEX : new_rfi ⊆ ext_sb)
  (TWF : thread_wf tid s1)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
  exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
red in SIM; desc.

assert (rexmod = true); subst.
{ clear -ISTEP CASREX. red in CASREX.
  set (AA:=ISTEP).
  symmetry in AA. apply nth_error_In in AA.
  apply CASREX in AA. red in AA. desf. }

assert (SAME_LOC: RegFile.eval_lexpr (regf s1) lexpr = RegFile.eval_lexpr (regf s1') lexpr).
{ ins; eapply regf_lexpr_helper; eauto.
ins; intro; eapply NADDR; unfolder; splits; eauto.
exists (ThreadEvent tid (eindex s1)).
rewrite UG; unfold add_rmw; basic_solver. }

cut (exists instrs pc G_ eindex regf depf ectrl,
  step tid s1' {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |} /\
  (sim_state s2 {| instrs := instrs; pc := pc; G := G_; eindex := eindex; regf := regf; depf := depf; ectrl := ectrl |}
  MOD new_rfi new_val)).
by ins; desc; eauto.

do 7 eexists; splits; red; splits.
  * eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC |].
    eapply cas_suc; try reflexivity.
  * ins; congruence.
  * ins; congruence.
  * ins.
    destruct (G s2) as [acts2 lab2 rmw2 data2 addr2 ctrl2 rf2 co2].
    inversion UG; subst; clear UG; ins.
    unfold acts_set, R_ex in NREX; ins.
    red in EXEC; desc.
    red; splits; ins.
    + by rewrite EINDEX, ACTS.
    + by rewrite TS.
    + rewrite EINDEX.
      unfold same_lab_u2v in *; intro e.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1' + 1))).
      by subst; rewrite !upds; rewrite SAME_LOC.
      rewrite updo; try done.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1'))).
      by subst; rewrite !upds; rewrite updo; [| by desf]; rewrite upds; rewrite SAME_LOC.
      rewrite !updo; auto.
    + rewrite EINDEX.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1' + 1))).
      -- subst; rewrite SAME_LOC.
         unfold val; rewrite !upds.
         erewrite regf_expr_helper; try edone.
         intro reg0; specialize (REGF reg0); desf; eauto.
         ins; intro DEPS; eapply NDATA; unfolder; splits; eauto.
         by rewrite EINDEX.
      -- unfold val; rewrite updo; [|done].
         destruct (eq_dec_actid a (ThreadEvent tid (eindex s1'))).
         ** subst; rewrite SAME_LOC.
            rewrite !upds.
            rewrite updo; [|intro; desf; lia].
            rewrite !upds.
            erewrite regf_expr_helper; try edone.
            intro reg0; specialize (REGF reg0); desf; eauto.
            ins; intro DEPS; eapply NFRMW; unfolder; splits; eauto.
         ** rewrite !updo; try done.
            by apply OLD_VAL in NIN; unfold val in NIN; rewrite NIN.
    + by rewrite RMW, EINDEX.
    + by rewrite DATA, EINDEX, DEPF.
    + by rewrite ADDR, EINDEX, DEPF.
    + by rewrite CTRL, EINDEX, ECTRL.
    + by rewrite FRMW, EINDEX, DEPF.
  * ins; congruence.
  * ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf; eauto.
    erewrite regf_expr_helper; eauto.
    ins; intro; eapply NFRMW.
    rewrite UG; ins; basic_solver.
  * eby ins; rewrite <- DEPF, <- EINDEX.
  * ins; congruence.
  * ins; unfold acts_set, is_r, is_w in INr, INw, READ, WRITE; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'+1))); subst.
    by rewrite upds in READ; desf.
    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'))); subst.
    rewrite updo in WRITE; [| intro; desf; lia].
    by rewrite upds in WRITE; desf.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    + exfalso.
      eapply NREX; split; [eauto|].
      { rewrite UG; unfold add; ins. split; eauto.
        rewrite EINDEX; basic_solver. }
      rewrite UG; unfold add; unfold R_ex; ins.
      by rewrite updo; [| intro; desf; lia]; rewrite EINDEX, upds.
    + unfold val; rewrite updo; [|done].
      rewrite updo; [|done].
      destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'+1))); subst.
      -- exfalso.
         apply RFI_INDEX in RF; unfold ext_sb in RF.
         destruct r; [eauto|]; desc.
         destruct INr as [[X|X]|INr]; try by desf.
         apply sim_execution_same_acts in EXEC.
         apply EXEC in INr.
         apply TWF in INr; desc.
         rewrite <- EINDEX in RF0.
         desf; lia.
      -- rewrite !updo; try done.
         eapply NEW_VAL1; try edone.
         { unfolder in INr; desf. }
         { unfolder in INw; desf. }
         { by rewrite !updo in READ; try edone. }
           by rewrite !updo in WRITE; try edone.
  * simpl; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'+1))); subst.
    by unfold is_r in READ; rewrite upds in READ; desf.
    unfold val; rewrite updo; [|done].
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    + exfalso.
      eapply NREX; split; [eauto|].
      { rewrite UG; unfold add; unfold acts_set; ins. split; eauto.
        rewrite EINDEX; basic_solver. }
      rewrite UG; unfold add; unfold R_ex; ins.
      by rewrite updo; [| intro; desf; lia]; rewrite EINDEX, upds.
    + unfold val; rewrite updo; try done.
      apply NEW_VAL2; try done.
      unfold is_r in *; rewrite !updo in READ; try done.
      unfolder in IN; desf.
Qed.

Lemma receptiveness_sim_inc (tid : thread_id)
      s1 s2 (INSTRS0 : instrs s1 = instrs s2)
      (expr_add : Instr.expr)
      rexmod xmod
      (ordr ordw : mode)
      (reg : Reg.t)
      (lexpr : Instr.lexpr)
      (ISTEP : Some (Instr.update
                       (Instr.fetch_add expr_add) rexmod xmod ordr ordw reg lexpr) =
               nth_error (instrs s1) (pc s1))
      (val_ : nat)
      (UPC : pc s2 = pc s1 + 1)
      (UG : G s2 =
            add_rmw (G s1) tid (eindex s1)
                    (Aload rexmod ordr
                           (RegFile.eval_lexpr (regf s1) lexpr) val_)
                    (Astore xmod ordw (RegFile.eval_lexpr (regf s1) lexpr)
                            (val_ + RegFile.eval_expr (regf s1) expr_add))
                    ((eq (ThreadEvent tid (eindex s1))) ∪₁
                     (DepsFile.expr_deps (depf s1) expr_add))
                    (DepsFile.lexpr_deps (depf s1) lexpr)
                    (ectrl s1) ∅)
      (UINDEX : eindex s2 = eindex s1 + 2)
      (UREGS : regf s2 = RegFun.add reg val_ (regf s1))
      (UDEPS : depf s2 = RegFun.add reg (eq (ThreadEvent tid (eindex s1))) (depf s1))
      (UECTRL : ectrl s2 = ectrl s1)
      MOD (new_rfi : relation actid) new_val
      (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s2))) ⊆₁ ∅)
      (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
      (NREX:  MOD ∩₁ (acts_set (G s2)) ∩₁ (R_ex (lab (G s2))) ⊆₁ ∅)
      (NDATA: ⦗MOD⦘ ⨾ (data (G s2)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂)
      (TWF : thread_wf tid s1)
      (RFI_INDEX : new_rfi ⊆ ext_sb)
      (new_rfif : functional new_rfi⁻¹)
      s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
  generalize (@new_write new_rfi new_rfif); intro F; destruct F as [new_w F].
  red in SIM; desc.
  assert (SAME_LOC : RegFile.eval_lexpr (regf s1) lexpr =
                     RegFile.eval_lexpr (regf s1') lexpr).
  { ins; eapply regf_lexpr_helper; eauto.
    ins; intro; eapply NADDR; unfolder; splits; eauto.
    exists (ThreadEvent tid (eindex s1)).
    rewrite UG; unfold add_rmw; basic_solver. }

  cut (exists instrs pc G_ eindex regf depf ectrl,
          step tid s1' (Build_state instrs pc G_ eindex regf depf ectrl) /\
          (sim_state s2 (Build_state instrs pc G_ eindex regf depf ectrl)
                     MOD new_rfi new_val)).
  { ins; desc; eauto. }
  do 7 eexists; splits; red; splits.
  { eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC |].
    eapply inc with (val :=
      if excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))
      then if excluded_middle_informative ((codom_rel new_rfi) (ThreadEvent tid (eindex s1')))
           then (get_val (val (lab (G s1')) (new_w (ThreadEvent tid (eindex s1')))))
           else (new_val (ThreadEvent tid (eindex s1')))
      else val_);
    reflexivity. }
  1,2,4,7: ins; congruence.
  { ins.
    destruct (G s2) as [acts2 lab2 rmw2 data2 addr2 ctrl2 rf2 co2].
    inversion UG; subst; clear UG.
    red in EXEC; desc.
    red; splits; ins.
    { by rewrite EINDEX, ACTS. }
    {  by rewrite TS. }
    { rewrite EINDEX.
      unfold same_lab_u2v in *; intro e.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1'))).
      { subst.
        rewrite updo; [|intros HH; clear -HH; inv HH; lia].
        rewrite !upds. unfold same_label_u2v.
        rewrite updo; [|intros HH; clear -HH; inv HH; lia].
        rewrite upds; auto. }
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1' + 1))).
      { subst.
        rewrite !upds. unfold same_label_u2v; auto. }
      ins. rewrite !updo; auto. }
    { rewrite EINDEX.
      unfold val.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1' + 1))).
      { subst.
        destruct (excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))) as [MN|NMN].
        { exfalso.
          eapply NDATA.
          apply seq_eqv_lr. splits; eauto.
          basic_solver 10. }
        assert (SAME_VAL : RegFile.eval_expr (regf s1 ) expr_add =
                           RegFile.eval_expr (regf s1') expr_add).
        { ins; eapply regf_expr_helper; eauto.
          ins; intro; eapply NDATA; unfolder; splits; eauto.
            by rewrite EINDEX. }
        rewrite !upds. by rewrite SAME_VAL. }
      rewrite updo; auto.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1'))).
      { subst.
        rewrite !upds.
        destruct (excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))) as [MN|NMN].
        { exfalso. eauto. }
        rewrite updo; [|intros HH; clear -HH; inv HH; lia].
          by rewrite upds. }
      rewrite !updo; auto.
      by apply OLD_VAL in NIN; unfold val in NIN; rewrite NIN. }
    { by rewrite RMW, EINDEX. }
    { by rewrite DATA, EINDEX, DEPF. }
    { by rewrite ADDR, EINDEX, DEPF. }
    { by rewrite CTRL, EINDEX, ECTRL. }
      by rewrite FRMW, EINDEX. }
  { ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf; eauto. }
  { eby ins; rewrite <- DEPF, <- EINDEX. }
  { ins; unfold acts_set, is_r, is_w in INr, INw, READ, WRITE; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'+1))); subst.
    { by rewrite upds in READ; desf. }
    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'))); subst.
    rewrite updo in WRITE; [| intro; desf; lia].
    { by rewrite upds in WRITE; desf. }

    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1' + 1))); subst.
    { exfalso.
      apply RFI_INDEX in RF; unfold ext_sb in RF.
      destruct INr as [[INr|INr]|INr]; subst.
      1,2: clear -RF; lia.
      destruct r; [eauto|]; desc.
      apply sim_execution_same_acts in EXEC.
      apply EXEC in INr.
      apply TWF in INr; desc.
      rewrite <- EINDEX in RF0.
      inv EE. clear -RF0 LT. lia. }

    assert (is_w (lab (G s1')) w) as WW'.
    { rewrite !updo in WRITE; edone. }

    unfold val.
    rewrite updo; auto.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    { rewrite !upds.
      destruct (excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))) as [MN|NMN].
      2: eby exfalso.
      rewrite !updo; auto.
      destruct (excluded_middle_informative
                  (codom_rel new_rfi (ThreadEvent tid (eindex s1')))) as [|XX].
      2: { exfalso. apply XX. generalize RF. clear. basic_solver. }
      assert (w = new_w (ThreadEvent tid (eindex s1'))); subst.
      { edestruct new_rfi_unique with
            (r:=ThreadEvent tid (eindex s1')) as [wu [_ HH]]; eauto.
        transitivity wu.
        2: by apply HH.
        symmetry. apply HH. do 2 red. generalize RF. clear. basic_solver. }
      unfold get_val.
      clear -WW'. unfold is_w in WW'. desf. }
    rewrite !updo; auto.
    eapply NEW_VAL1; try edone.
    { unfolder in INr; desf. }
    { unfolder in INw; desf. }
      by rewrite !updo in READ; try edone. }
  simpl; ins.
  destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'+1))); subst.
  { by unfold is_r in READ; rewrite upds in READ; desf. }
  unfold val; rewrite updo; [|done].
  destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
  { rewrite upds. desf. }
  unfold val; rewrite updo; try done.
  apply NEW_VAL2; try done.
  unfold is_r in *; rewrite !updo in READ; try done.
  unfolder in IN; desf.
Qed.

Lemma receptiveness_sim_exchange
      (tid : thread_id)
      s1 s2 (INSTRS0 : instrs s1 = instrs s2)
      (new_expr : Instr.expr)
      rexmod xmod
      (ordr ordw : mode)
      (reg : Reg.t)
      (lexpr : Instr.lexpr)
      (ISTEP : Some (Instr.update
                       (Instr.exchange new_expr)
                       rexmod xmod ordr ordw reg lexpr) = nth_error (instrs s1) (pc s1))
      (val_ : nat)
      (UPC : pc s2 = pc s1 + 1)
      (UG : G s2 = add_rmw (G s1) tid (eindex s1)
                           (Aload rexmod ordr (RegFile.eval_lexpr (regf s1) lexpr)
                                  val_)
                           (Astore xmod ordw (RegFile.eval_lexpr (regf s1) lexpr)
                                   (RegFile.eval_expr (regf s1) new_expr))
                           (DepsFile.expr_deps (depf s1) new_expr)
                           (DepsFile.lexpr_deps (depf s1) lexpr)
                           (ectrl s1) ∅)
      (UINDEX : eindex s2 = eindex s1 + 2)
      (UREGS : regf s2 = RegFun.add reg val_ (regf s1))
      (UDEPS : depf s2 = RegFun.add reg (eq (ThreadEvent tid (eindex s1)))
                                    (depf s1))
      (UECTRL : ectrl s2 = ectrl s1)
      MOD (new_rfi : relation actid) new_val
      (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s2))) ⊆₁ ∅)
      (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
      (NREX:  MOD ∩₁ (acts_set (G s2)) ∩₁ (R_ex (lab (G s2))) ⊆₁ ∅)
      (NDATA: ⦗MOD⦘ ⨾ (data (G s2)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂)
      (TWF : thread_wf tid s1)
      (RFI_INDEX : new_rfi ⊆ ext_sb)
      (new_rfif : functional new_rfi⁻¹)
      s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
  exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
  generalize (@new_write new_rfi new_rfif); intro F; destruct F as [new_w F].
  red in SIM; desc.
  assert (SAME_LOC : RegFile.eval_lexpr (regf s1) lexpr =
                     RegFile.eval_lexpr (regf s1') lexpr).
  { ins; eapply regf_lexpr_helper; eauto.
    ins; intro; eapply NADDR; unfolder; splits; eauto.
    exists (ThreadEvent tid (eindex s1)).
    rewrite UG; unfold add_rmw; basic_solver. }

  cut (exists instrs pc G_ eindex regf depf ectrl,
          step tid s1' (Build_state instrs pc G_ eindex regf depf ectrl) /\
          (sim_state s2 (Build_state instrs pc G_ eindex regf depf ectrl)
                     MOD new_rfi new_val)).
  { ins; desc; eauto. }
  do 7 eexists; splits; red; splits.
  { eexists; red; splits; [by ins; eauto|].
    eexists; splits; [eby rewrite <- INSTRS, <- PC |].
    eapply exchange with (val :=
      if excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))
      then if excluded_middle_informative ((codom_rel new_rfi) (ThreadEvent tid (eindex s1')))
           then (get_val (val (lab (G s1')) (new_w (ThreadEvent tid (eindex s1')))))
           else (new_val (ThreadEvent tid (eindex s1')))
      else val_);
    reflexivity. }
  1,2,4,7: ins; congruence.
  { ins.
    destruct (G s2) as [acts2 lab2 rmw2 data2 addr2 ctrl2 rf2 co2].
    inversion UG; subst; clear UG.
    red in EXEC; desc.
    red; splits; ins.
    { by rewrite EINDEX, ACTS. }
    { by rewrite TS. }
    { rewrite EINDEX.
      unfold same_lab_u2v in *; intro e.
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1'))).
      { subst.
        rewrite updo; [|intros HH; clear -HH; inv HH; lia].
        rewrite !upds. unfold same_label_u2v.
        rewrite updo; [|intros HH; clear -HH; inv HH; lia].
        rewrite upds; auto. }
      destruct (eq_dec_actid e (ThreadEvent tid (eindex s1' + 1))).
      { subst.
        rewrite !upds. unfold same_label_u2v; auto. }
      ins. rewrite !updo; auto. }
    { rewrite EINDEX.
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1' + 1))).
      { subst; rewrite SAME_LOC.
        unfold val; rewrite !upds.
        erewrite regf_expr_helper; try edone.
        intro reg0; specialize (REGF reg0); desf; eauto.
        ins; intro DEPS; eapply NDATA; unfolder; splits; eauto.
        by rewrite EINDEX. }
      unfold val; rewrite updo; [|done].
      destruct (eq_dec_actid a (ThreadEvent tid (eindex s1'))).
      { subst; rewrite SAME_LOC.
         rewrite !upds.
         rewrite updo; [|intro; desf; lia].
         rewrite !upds. desf. }
      rewrite !updo; try done.
      by apply OLD_VAL in NIN; unfold val in NIN; rewrite NIN. }
    { by rewrite RMW, EINDEX. }
    { by rewrite DATA, EINDEX, DEPF. }
    { by rewrite ADDR, EINDEX, DEPF. }
    { by rewrite CTRL, EINDEX, ECTRL. }
      by rewrite FRMW, EINDEX. }
  { ins; rewrite UREGS, UDEPS.
    unfold RegFun.add, RegFun.find in *; desf; eauto. }
  { eby ins; rewrite <- DEPF, <- EINDEX. }
  { ins; unfold acts_set, is_r, is_w in INr, INw, READ, WRITE; ins.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'+1))); subst.
    { by rewrite upds in READ; desf. }
    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1'))); subst.
    rewrite updo in WRITE; [| intro; desf; lia].
    { by rewrite upds in WRITE; desf. }

    destruct (eq_dec_actid w (ThreadEvent tid (eindex s1' + 1))); subst.
    { exfalso.
      apply RFI_INDEX in RF; unfold ext_sb in RF.
      destruct INr as [[INr|INr]|INr]; subst.
      1,2: clear -RF; lia.
      destruct r; [eauto|]; desc.
      apply sim_execution_same_acts in EXEC.
      apply EXEC in INr.
      apply TWF in INr; desc.
      rewrite <- EINDEX in RF0.
      inv EE. clear -RF0 LT. lia. }

    assert (is_w (lab (G s1')) w) as WW'.
    { rewrite !updo in WRITE; edone. }

    unfold val.
    rewrite updo; auto.
    destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
    { rewrite !upds.
      destruct (excluded_middle_informative (MOD (ThreadEvent tid (eindex s1')))) as [MN|NMN].
      2: eby exfalso.
      rewrite !updo; auto.
      destruct (excluded_middle_informative
                  (codom_rel new_rfi (ThreadEvent tid (eindex s1')))) as [|XX].
      2: { exfalso. apply XX. generalize RF. clear. basic_solver. }
      assert (w = new_w (ThreadEvent tid (eindex s1'))); subst.
      { edestruct new_rfi_unique with
            (r:=ThreadEvent tid (eindex s1')) as [wu [_ HH]]; eauto.
        transitivity wu.
        2: by apply HH.
        symmetry. apply HH. do 2 red. generalize RF. clear. basic_solver. }
      unfold get_val.
      clear -WW'. unfold is_w in WW'. desf. }
    rewrite !updo; auto.
    eapply NEW_VAL1; try edone.
    { unfolder in INr; desf. }
    { unfolder in INw; desf. }
      by rewrite !updo in READ; try edone. }
  simpl; ins.
  destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'+1))); subst.
  { by unfold is_r in READ; rewrite upds in READ; desf. }
  unfold val; rewrite updo; [|done].
  destruct (eq_dec_actid r (ThreadEvent tid (eindex s1'))); subst.
  { rewrite upds. desf. }
  unfold val; rewrite updo; try done.
  apply NEW_VAL2; try done.
  { unfold is_r in *; rewrite !updo in READ; done. }
  unfolder in IN; desf.
Qed.

Lemma receptiveness_sim_step (tid : thread_id)
  s1 s2
  (STEP : (step tid) s1 s2)
  (CASREX : cas_produces_R_ex_instrs (instrs s1))
  MOD (new_rfi : relation actid) new_val
  (NCTRL : MOD ∩₁ ectrl s2 ⊆₁ ∅)
  (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s2))) ⊆₁ ∅)
  (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
  (NREX:  MOD ∩₁ (acts_set (G s2)) ∩₁ (R_ex (lab (G s2))) ⊆₁ ∅)
  (NDATA: ⦗MOD⦘ ⨾ (data (G s2)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂)
  (new_rfif : functional new_rfi⁻¹)
   (RFI_INDEX : new_rfi ⊆ ext_sb)
  (TWF : thread_wf tid s1)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid) s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
destruct STEP; red in H; desf.
destruct ISTEP0; desf.
- eby eapply receptiveness_sim_assign.
- eby eapply receptiveness_sim_if_else.
- eby eapply receptiveness_sim_if_then.
- eby eapply receptiveness_sim_load.
- eby eapply receptiveness_sim_store.
- eby eapply receptiveness_sim_fence.
- eby eapply receptiveness_sim_cas_fail.
- eby eapply receptiveness_sim_cas_suc.
- eby eapply receptiveness_sim_inc.
- eby eapply receptiveness_sim_exchange.
Qed.

Lemma receptiveness_sim (tid : thread_id)
  s1 s2
  (STEPS : (step tid)＊ s1 s2)
  (CASREX : cas_produces_R_ex_instrs (instrs s1))
  MOD (new_rfi : relation actid) new_val
  (NCTRL : MOD ∩₁ ectrl s2 ⊆₁ ∅)
  (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s2))) ⊆₁ ∅)
  (NADDR : MOD ∩₁ dom_rel ((addr (G s2))) ⊆₁ ∅)
  (NREX:  MOD ∩₁ (acts_set (G s2)) ∩₁ (R_ex (lab (G s2))) ⊆₁ ∅)
  (NDATA: ⦗MOD⦘ ⨾ (data (G s2)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂)
  (new_rfif : functional new_rfi⁻¹)
   (RFI_INDEX : new_rfi ⊆ ext_sb)
  (TWF : thread_wf tid s1)
  s1' (SIM: sim_state s1 s1' MOD new_rfi new_val) :
 exists s2', (step tid)＊ s1' s2' /\ sim_state s2 s2' MOD new_rfi new_val.
Proof using.
  apply clos_rt_rtn1 in STEPS.
  induction STEPS.
  { by eexists; vauto. }
  exploit IHSTEPS.
  { unfolder; splits; ins; eauto; desf.
    eapply ectrl_increasing in H1; eauto.
    eapply NCTRL; basic_solver. }
  { unfolder; splits; ins; eauto; desf.
    eapply rmw_dep_increasing in H1; eauto.
    eapply NFRMW; basic_solver. }
  { unfolder; splits; ins; eauto; desf.
    eapply addr_increasing in H1; eauto.
    eapply NADDR; basic_solver. }
  { unfolder; splits; ins; eauto; desf.
    eapply NREX; split; [split; [eauto |] |].
    eapply acts_increasing; edone.
    eapply is_r_ex_increasing; eauto.
    eapply thread_wf_steps; try edone.
    { by apply clos_rtn1_rt. }
    basic_solver. }
  { unfolder; splits; ins; eauto; desf.
    eapply data_increasing in H1; eauto.
    eapply NDATA; basic_solver. }
  intro; desc.
  eapply receptiveness_sim_step in x0; eauto; desf.
  { exists s2'0; splits; eauto.
      by eapply rt_trans; [eauto | econs]. }
  { arewrite (instrs y = instrs s1); auto.
    apply clos_rtn1_rt in STEPS.
    eapply steps_preserve_instrs; eauto. }
  eapply thread_wf_steps; try edone.
    by apply clos_rtn1_rt.
Qed.

Lemma receptiveness_helper (tid : thread_id)
      s_init s
      (CASREX : cas_produces_R_ex_instrs (instrs s_init))
      (GPC : wf_thread_state tid s_init)
      (new_val : actid -> value)
      (new_rfi : relation actid)
      (MOD: actid -> Prop)
      (STEPS : (step tid)＊ s_init s)
      (new_rfiE : new_rfi ≡ ⦗(acts_set (G s))⦘ ⨾ new_rfi ⨾ ⦗(acts_set (G s))⦘)
      (new_rfiD : new_rfi ≡ ⦗is_w (lab (G s))⦘ ⨾ new_rfi ⨾ ⦗is_r (lab (G s))⦘)
      (new_rfif : functional new_rfi⁻¹)
      (RFI_INDEX : new_rfi ⊆ ext_sb)
      (NCTRL : MOD ∩₁ ectrl s ⊆₁ ∅)
      (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s))) ⊆₁ ∅)
      (NADDR : MOD ∩₁ dom_rel ((addr (G s))) ⊆₁ ∅)
      (NREX:  MOD ∩₁ (acts_set (G s)) ∩₁ (R_ex (lab (G s))) ⊆₁ ∅)
      (NDATA: ⦗MOD⦘ ⨾ (data (G s)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂)
      (new_rfiMOD : codom_rel new_rfi ⊆₁ MOD)
      (NMODINIT: MOD ∩₁ (acts_set (ProgToExecution.G s_init)) ⊆₁ ∅)
      (EMOD : MOD ⊆₁ (acts_set (ProgToExecution.G s))) :
    exists s',
      ⟪ STEPS' : (step tid)＊ s_init s' ⟫ /\
      ⟪ EXEC : sim_execution (G s) (G s') MOD ⟫ /\
      ⟪ NEW_VAL1 : forall r w (RF: new_rfi w r), val ((lab (G s'))) r = val ((lab (G s'))) w ⟫ /\
      ⟪ NEW_VAL2 : forall r (RR : is_r (lab (G s')) r) (IN: MOD r) (NIN: ~ (codom_rel new_rfi) r),
          val ((lab (G s'))) r = Some (new_val r) ⟫ /\
      ⟪ OLD_VAL : forall a (NIN: ~ MOD a), val ((lab (G s'))) a = val ((lab (G s))) a ⟫.
Proof using.
apply receptiveness_sim with (s1':= s_init) (MOD:=MOD) (new_rfi:=new_rfi) (new_val:=new_val) in STEPS.
all: try done.
- desc.
  red in STEPS0; desc.
  exists s2'; splits; eauto.
  * ins; eapply NEW_VAL1; try done.
    + hahn_rewrite new_rfiE in RF; unfolder in RF; desf.
      apply sim_execution_same_acts in EXEC.
      revert EXEC; basic_solver.
    + hahn_rewrite new_rfiE in RF; unfolder in RF; desf.
      apply sim_execution_same_acts in EXEC.
      revert EXEC; basic_solver.
    + hahn_rewrite new_rfiD in RF; unfolder in RF; desf.
      apply sim_execution_same_r in EXEC.
      revert EXEC; basic_solver.
    + hahn_rewrite new_rfiD in RF; unfolder in RF; desf.
      apply sim_execution_same_w in EXEC.
      revert EXEC; basic_solver.
    + revert new_rfiMOD; basic_solver.
  * ins; eapply NEW_VAL2; try done.
    apply sim_execution_same_acts in EXEC.
    revert EXEC; basic_solver.
  * ins; red in EXEC; desc.
    by eapply OLD_VAL.
- red; apply (acts_rep GPC).
- red; splits; eauto.
  { red; splits; eauto; red; red; ins; red; eauto; desf. }
  ins; exfalso; revert NMODINIT; basic_solver.
  ins; exfalso; unfolder in *; basic_solver.
Qed.

Lemma receptiveness_ectrl_helper (tid : thread_id)
      s_init s
      (GPC : wf_thread_state tid s_init)
      (STEPS : (step tid)＊ s_init s)
      MOD (NCTRL: MOD ∩₁ dom_rel ((ctrl (G s))) ⊆₁ ∅)
      (NMODINIT: MOD ∩₁ (acts_set (G s_init)) ⊆₁ ∅):
      exists s', (step tid)＊ s_init s' /\
                 (MOD ∩₁ ectrl s' ⊆₁ ∅) /\ (G s') = (G s).
Proof using.
apply clos_rt_rtn1 in STEPS.
induction STEPS.
- exists s_init; splits; vauto.
  by rewrite (wft_ectrlE GPC).
- assert (A: MOD ∩₁ dom_rel (ctrl (G y)) ⊆₁ ∅).
  generalize (ctrl_increasing H).
  revert NCTRL; basic_solver 12.
  apply IHSTEPS in A.
  desc.
  destruct  (classic (MOD ∩₁ ectrl z ⊆₁ ∅)).
  * exists z; splits; eauto.
    eapply rt_trans.
    eby apply clos_rtn1_rt.
    by apply rt_step.
  * exists s'; splits; eauto.
    transitivity (G y); [done|].
    eapply ectrl_ctrl_step; try edone.
    destruct (classic (exists a : actid, (MOD ∩₁ ectrl z) a)); auto.
    exfalso; apply H0; unfolder; ins; eapply H1; basic_solver.
Qed.

Lemma receptiveness_full (tid : thread_id)
      s_init s
      (new_val : actid -> value)
      (new_rfi : relation actid)
      (MOD: actid -> Prop)
      (GPC : wf_thread_state tid s_init)
      (CASREX : cas_produces_R_ex_instrs (instrs s_init))
      (STEPS : (step tid)＊ s_init s)
      (new_rfiE : new_rfi ≡ ⦗(acts_set (G s))⦘ ⨾ new_rfi ⨾ ⦗(acts_set (G s))⦘)
      (new_rfiD : new_rfi ≡ ⦗is_w (lab (G s))⦘ ⨾ new_rfi ⨾ ⦗is_r (lab (G s))⦘)
      (new_rfif : functional new_rfi⁻¹)
      (RFI_INDEX : new_rfi ⊆ ext_sb)
      (new_rfiMOD : codom_rel new_rfi ⊆₁ MOD)
      (EMOD : MOD ⊆₁ (acts_set (ProgToExecution.G s)))
      (NMODINIT: MOD ∩₁ (acts_set (ProgToExecution.G s_init)) ⊆₁ ∅)
      (NFRMW: MOD ∩₁ dom_rel ((rmw_dep (G s))) ⊆₁ ∅)
      (NADDR : MOD ∩₁ dom_rel ((addr (G s))) ⊆₁ ∅)
      (NREX:  MOD ∩₁ (acts_set (G s)) ∩₁(R_ex (lab (G s))) ⊆₁ ∅)
      (NCTRL: MOD ∩₁ dom_rel ((ctrl (G s))) ⊆₁ ∅)
      (NDATA: ⦗MOD⦘ ⨾ (data (G s)) ⨾ ⦗set_compl MOD⦘ ⊆ ∅₂) :
    exists s',
      ⟪ STEPS' : (step tid)＊ s_init s' ⟫ /\
      ⟪ RACTS : (acts_set (G s)) = (acts_set (G s')) ⟫ /\
      ⟪ RTS: threads_set (G s) ≡₁ threads_set (G s')⟫ /\
      ⟪ RRMW  : (rmw (G s))  ≡ (rmw (G s'))  ⟫ /\
      ⟪ RDATA : (data (G s)) ≡ (data (G s')) ⟫ /\
      ⟪ RADDR : (addr (G s)) ≡ (addr (G s')) ⟫ /\
      ⟪ RCTRL : (ctrl (G s)) ≡ (ctrl (G s')) ⟫  /\
      ⟪ RFAILRMW : (rmw_dep (G s)) ≡ (rmw_dep (G s')) ⟫  /\
      ⟪ SAME : same_lab_u2v ((lab (G s'))) ((lab (G s)))⟫ /\
      ⟪ NEW_VAL1 : forall r w (RF: new_rfi w r), val ((lab (G s'))) r = val ((lab (G s'))) w ⟫ /\
      ⟪ NEW_VAL2 : forall r (RR : is_r (lab (G s')) r) (IN: MOD r) (NIN: ~ (codom_rel new_rfi) r),
          val ((lab (G s'))) r = Some (new_val r) ⟫ /\
      ⟪ OLD_VAL : forall a (NIN: ~ MOD a), val ((lab (G s'))) a = val ((lab (G s))) a ⟫.
Proof using.
forward (apply receptiveness_ectrl_helper); try edone.

ins; desc.
rewrite <- H1 in *.
clear STEPS H1 s.
forward (eapply receptiveness_helper with (new_rfi:=new_rfi)); ins; eauto.
desc.
red in EXEC; desc.
eexists; splits; eauto.
Qed.


Theorem Euclides : ∀ a b  : Z, b > 0 -> ∃ r q  : Z, (a=b*q + r) ∧ (0 < r ∨ 0=r)  ∧ r< b .
Proof.
intros.
set (S := {  l  : Z | ∃ q : Z, l=a - b*q +1 ∧ l>0 }).
pose proof ( W1 S).
assert (S≠ ∅).
{
case (classic (a > 0)).
case (classic (S = ∅)).
intros.
assert ( a +1 ∈ S ).
{
unfold In.
unfold S.
exists 0.
rewrite M1.
rewrite A1P6 .
rewrite G .
rewrite PORRA.
rewrite A3.
pose proof (R3 0 a (a+1)).
case (classic (0 < a+1)).
intros.
tauto.
pose proof H2 as H1945.
intros.
pose proof (I778 ).
apply (O1 0 1 a) in H5.
rewrite A1P1 in H5.
rewrite A1 in H5.
tauto. }
rewrite H1 in H3.
contradiction.
intros.
exact H1.
intros.
destruct (T a) as [[H3 [H4 H5]] | [[H3 [H4 H5]] | [H3 [H4 H5]]]].
tauto.
assert (1 ∈ S).
unfold S, In.
exists 0.
rewrite M1, A1P6 .

rewrite G, PORRA, A3.
rewrite H4, A1P1.
pose proof I778.
tauto.
case (classic (S = ∅)).
intros.
rewrite H6 in H2.
contradiction.
intros.
tauto.
case (classic (S = ∅)).
intros.
assert (((-a)*b + a + 1) ∈ S) .
unfold S, In.
exists a.
split.
rewrite G.
rewrite (A1 a (- (b * a) )).
rewrite (M1 b a), <-A1P7.
rewrite <-(A1P7 (a*b)).
rewrite M2.
tauto.
apply Davi in H.
destruct H.
rewrite H.
rewrite M3, A1P2.
rewrite A1P1.
pose proof I778.
tauto.
pose proof H as H8.
pose proof (O2 1 b (-a) ).
apply H6 in H.
rewrite M1, M3 in H.
rewrite M1 in H.
pose proof (R3 (-a) ((-a)*b) (((-a)*b) + a +1)).
rewrite <-A1P7 .
rewrite M2.
rewrite (M1 a b).
rewrite <-M2.
rewrite <-(M3 a) at 2.
rewrite (M1 a 1).
rewrite M1, <-M2.
rewrite NOW.
rewrite A1P3.
rewrite <-(A1P5 a) at 2.
rewrite <-NOW at 2.
rewrite <-(NOW (a * (-1))).
rewrite NOW.
rewrite (M1 a (-1)).
rewrite <-(A1P7 ((-1) * a) ) .
rewrite (A1P7 a) .
rewrite M1 at 1.
rewrite <-D1.
rewrite <-G.
apply (O1 1 b (-1)) in H8.
rewrite A4 in H8.
rewrite <-G in H8.
pose proof (O2 0 (b-1) (-a)).
apply H9 in H8.
rewrite A1P6 in H8.
pose proof (R3 0  ((b - 1) * (- a))  ((b - 1) * (- a) + 1)).
pose proof (I778).
apply (O1 0 1 ((b - 1) * (- a))) in H11.
rewrite A1 in H11.
rewrite A3 in H11.
rewrite A1 in H11.
tauto.
apply I3 in H5.
rewrite PORRA in H5.
exact H5.
apply I3 in H5.
rewrite PORRA in H5.
exact H5.
rewrite H2 in H6.
unfold In in H6.
tauto.
tauto.   }
apply H0 in H1.
destruct H1.
pose proof I778 as H2.
destruct H1.
pose proof H1 as H67.
unfold S in H1.
unfold In in H1.
destruct H1.
destruct H1.

case (classic ( x<b+1 )).
intros.
exists (x-1).
exists x0.
apply (S1 x (a- (b*x0)+1) (b*x0)) in H1.
rewrite M1 in H1.
rewrite G in H1.
rewrite A2 in H1.
rewrite A2 in H1.
rewrite (A1 (-(x0 * b)) (1 +  (x0*b))) in H1.
rewrite A2 in H1.
rewrite A4 in H1.
rewrite A3 in H1.
apply (S1 (x+ (x0*b) ) (a+1) (-1)) in H1.
rewrite A1 in H1.
rewrite (A2 a 1 (-1)) in H1.
rewrite A4 in H1.
rewrite A3 in H1.
symmetry in H1.
rewrite <-A2 in H1.
rewrite M1 in H1.
rewrite (A1 (-1) x) in H1.
rewrite A1 in H1.
rewrite <-G in H1.
split.
tauto.
split.
unfold S in H67.
unfold In in H67.
destruct H67.
destruct H6.

apply (O1 0 (x) (-1)) in H7.

rewrite A1P1 in H7.
rewrite <-G in H7.
pose proof (Sena2 (-1) (x-1)).
destruct H8.
exact H7.
right.
apply (O1 (-1) (x-1) 1)in H7.
rewrite A1P2 in H7.
rewrite G in H7.
rewrite A2 in H7.
rewrite A1P2 in H7.
rewrite A3 in H7.
apply (S1 (-1) (x-1-1) 1) in H8.
rewrite A1P2 in H8.
rewrite G in H8.
rewrite A2 in H8.
rewrite A1P2 in H8.
rewrite A3 in H8.
tauto.
apply Sena in H7.
destruct H7.
rewrite A1P2 in H7.
symmetry in H7.
tauto.
rewrite A1P2 in H7 .
tauto.
apply ( O1 (x) (b+1) (-1)) in H5.
rewrite A2 in H5.
rewrite A4 in H5.
rewrite A3 in H5.
rewrite <-G in H5.
tauto.
intros.
case (classic (x=b)).
intros.
exists (x-1).
exists x0.
auto.
apply (S1 x ( a - (b*x0) + 1) ( (b*x0) + (- 1))) in H1.
rewrite A2 in H1.
rewrite (A1 (b*x0) (-1) ) in H1.
rewrite <-( A2 1 (-1) (b*x0)) in H1.
rewrite A4 in H1.
rewrite A1P1 in H1.
rewrite G in H1.
rewrite A2 in H1.
rewrite A1P2 in H1.
rewrite A3 in H1.
rewrite A1 in H1.
rewrite (A1 (-1) (b*x0)) in H1.
rewrite A2 in H1.
rewrite (A1 (-1) (x)) in H1.
split.
symmetry in H1.
tauto.
split.
apply Sena2 in H4.
tauto.
rewrite H6.
pose  proof (I778).
apply (O1 0 1 (b-1)) in H7.
rewrite A1P1 in H7.

rewrite G in H7.
rewrite A1 in H7 at 2.
rewrite <-A2 in H7.
rewrite A4 in H7.
rewrite <-G in H7.
rewrite A1P1 in H7.
tauto.
intros.
 destruct (Y x b) as [[H7 [H8 H9]] | [[H7 [H8 H9]] | [H7 [H8 H9]]]].
apply Sena2 in H7.
destruct H7.
assert ( (x-b) ∈ S ).
unfold In.
unfold S.
exists (x0 +1).
split.
rewrite G.
apply (S1 x  (a -( b * x0) + 1) (-b)) in H1.
rewrite <-G in H1.
rewrite (G a (b*x0)) in H1.
rewrite A2 in H1.
rewrite (A1 1 (-b)) in H1.
rewrite <-A2 in H1.
rewrite <-(A1P7 b) in H1.
rewrite M1 in H1.
rewrite (M1 (-1) b) in H1.
rewrite <-NOW in H1.
rewrite M2 in H1.
rewrite <-M2 in H1.
rewrite A1 in H1.
rewrite A2 in H1.

rewrite <-(D1 (x0*b) b (-1)) in H1.
rewrite NOW in H1.
rewrite <-(A1P3 b) in H1 at 3.
rewrite <-D1 in H1.
rewrite M1 in H1.
rewrite A1 in H1.
tauto.
apply (S1 b (x - 1) (-b +1)) in H7.
rewrite G in H7.
rewrite <-A2 in H7.
rewrite A4 in H7.
rewrite A1P1 in H7.
rewrite A2 in H7.
rewrite A1 in H7.
rewrite (A1 (-b) 1) in H7.
rewrite <-(A2 (-1) 1  (- b)) in H7.
rewrite A1P2 in H7.
rewrite A1P1 in H7.
rewrite A1 in H7.
rewrite <-G in H7.
rewrite <-H7.
pose proof I778.

tauto.
apply H3 in H10.
destruct H10.
apply (O1 x (x-b) (-x)) in H10.
rewrite A4 in H10.
rewrite A1 in H10.
rewrite G in H10.
rewrite <-A2 in H10.
rewrite A1P2 in H10.
rewrite A1P1 in H10.
apply I3 in H10.
rewrite A1P5 in H10.
rewrite PORRA in H10.
apply I7 in H10.
tauto.
apply (S1 x (x-b) (-x)) in H10.
rewrite A4 in H10.
rewrite A1 in H10.
rewrite G in H10.
rewrite <-A2 in H10.
rewrite A1P2 in H10.
rewrite A1P1 in H10.
apply (S2 0 (-b) (-1)) in H10.
rewrite A1P6 in H10.
rewrite NOW in H10.
rewrite A1P5 in H10.
pose proof (I8 b).
apply I9 in H10.
tauto.
assert ( (x-b) ∈ S ).
unfold In.
unfold S.
exists (x0 +1).
split.
rewrite G.
apply (S1 x  (a -( b * x0) + 1) (-b)) in H1.
rewrite <-G in H1.
rewrite (G a (b*x0)) in H1.
rewrite A2 in H1.
rewrite (A1 1 (-b)) in H1.
rewrite <-A2 in H1.
rewrite <-(A1P7 b) in H1.
rewrite M1 in H1.
rewrite (M1 (-1) b) in H1.
rewrite <-NOW in H1.
rewrite M2 in H1.
rewrite <-M2 in H1.
rewrite A1 in H1.
rewrite A2 in H1.

rewrite <-(D1 (x0*b) b (-1)) in H1.
rewrite NOW in H1.
rewrite <-(A1P3 b) in H1 at 3.
rewrite <-D1 in H1.
rewrite M1 in H1.
rewrite A1 in H1.
tauto.
apply (O1 b (x - 1) (-b +1)) in H7.
rewrite G in H7.
rewrite <-A2 in H7.
rewrite A4 in H7.
rewrite A1P1 in H7.
rewrite A2 in H7.
rewrite A1 in H7.
rewrite (A1 (-b) 1) in H7.
rewrite <-(A2 (-1) 1  (- b)) in H7.
rewrite A1P2 in H7.
rewrite A1P1 in H7.
rewrite A1 in H7.
rewrite <-G in H7.
pose proof I778.
pose proof (R3 0 1 (x-b)).
pose proof (conj H10 H7).
apply H11 in H12.
exact H12.
apply H3 in H10.
destruct H10.
apply (O1 x (x-b) (-x)) in H10.
rewrite A4 in H10.
rewrite A1 in H10.
rewrite G in H10.
rewrite <-A2 in H10.
rewrite A1P2 in H10.
rewrite A1P1 in H10.
apply I3 in H10.
rewrite A1P5 in H10.
rewrite PORRA in H10.
apply I7 in H10.
tauto.
apply (S1 x (x-b) (-x)) in H10.
rewrite A4 in H10.
rewrite A1 in H10.
rewrite G in H10.
rewrite <-A2 in H10.
rewrite A1P2 in H10.
rewrite A1P1 in H10.
apply (S2 0 (-b) (-1)) in H10.
rewrite A1P6 in H10.
rewrite NOW in H10.
rewrite A1P5 in H10.
pose proof (I8 b).
apply I9 in H10.
tauto.
tauto.
pose proof (Sena x 0).
exists (x-1).
exists x0.
apply (S1 x (a - (b * x0) + 1) ((b * x0) - 1)) in H1.
rewrite (G a (b*x0)) in H1.
rewrite A2  in H1.
rewrite (G (b*x0) (1)) in H1.
rewrite (A1 (b * x0) (- 1)) in H1.
rewrite <-(A2 1 (-1) (b*x0)) in H1.
rewrite A4 in H1.
rewrite A1P1 in H1.
rewrite A2 in H1.
rewrite A1P2 in H1.
rewrite A3 in H1.
rewrite <-A2 in H1.
rewrite A1 in H1.
symmetry in H1.
split.
tauto.
split.
apply H10 in H4.
rewrite A1P1 in H4.
destruct H4.
apply (S1 x 1 (-1)) in H4.
rewrite <-G in H4.
rewrite A4 in H4.
symmetry in H4.
tauto.
apply (O1 1 x (-1)) in H4.
rewrite A4 in H4.
rewrite <-G in H4.
tauto.
pose proof (R3 (x-1) x b).
pose proof I778.
apply I3 in H12.
rewrite PORRA in H12.
apply (O1 (-1) 0 x) in H12.
rewrite A1P1 in H12.
rewrite A1 in H12.
rewrite <-G in H12.
tauto.
unfold Included.
unfold S.
unfold In at 1.
intros.
destruct H2.
destruct H2.

apply lt_N_elt.
tauto.
Qed.


From iris.base_logic Require Export invariants.
From iris.algebra Require Import agree frac.
From iris.proofmode Require Import tactics.
From fae_gtlc_mu.stlc_mu Require Export lang.
Import uPred.

(* Name for invariant that supervises the static side *)
Definition specN := nroot .@ "gradual".

(* Iris resources for keeping track of static side *)
Canonical Structure exprO := leibnizO expr.

Definition specR := prodR fracR (agreeR exprO).

Class specG Σ := SpecG { specR_inG :> inG Σ specR; spec_name : gname }.

Definition currently `{specG Σ} (e : expr) : iProp Σ :=
  own spec_name ((1%Qp , to_agree e) : specR).

Definition currently_half `{specG Σ} (e : expr) : iProp Σ :=
  own spec_name (((1 / 2)%Qp , to_agree e) : specR).

(* Invariant body to keep track of static side *)
Definition initially_body `{specG Σ} (ei' : expr) : iProp Σ :=
  (∃ e', (currently_half e')
            ∗ ⌜rtc erased_step ([ei'] , tt) ([e'] , tt)⌝)%I.

(* Invariant to keep track of static side *)
Definition initially_inv `{specG Σ} `{invG Σ} (ei' : expr) : iProp Σ :=
  inv specN (initially_body ei').

Section cfg.
  Context `{!specG Σ}.
  Context `{!invG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val → iProp Σ.
  Implicit Types e : expr.
  Implicit Types v : val.

  Local Hint Resolve to_of_val : core.

  (* uninteresting technical lemma *)
  Lemma step_insert_no_fork K e σ e' σ' :
    head_step e σ [] e' σ' [] → erased_step ([fill K e], σ) ([fill K e'], σ').
  Proof. intros Hst. exists []. eapply (step_atomic _ _ _ _ _ _ _ [] [] []); eauto.
         by apply: Ectx_step.
  Qed.

  (* Updating the static side with a head step under an evaluation context *)
  Lemma step_pure E ei' K e1' e2' σ :
    (head_step e1' σ [] e2' σ []) →
    nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K e1') ={E}=∗ currently_half (fill K e2').
  Proof.
    iIntros (??) "[Hinv Hj]".
    rewrite /initially_inv /initially_body.
    iInv specN as ">Hinit" "Hclose".
    iDestruct "Hinit" as (ef') "[Hown %]".
    (** fill K e1' = ef' *)
    rewrite /currently_half.
    iDestruct (own_valid_2 with "Hown Hj") as "#eee".
    rewrite -pair_op frac_op' Qp_half_half.
    iDestruct "eee" as %[_ ->%agree_op_inv'%leibniz_equiv]%pair_valid.
    (** update *)
    (* bring together *)
    iDestruct (equiv_entails_sym _ _ (own_op _ _ _) with "[Hj Hown]") as "HOwnOne".
    iFrame.
    (* actually update *)
    rewrite -pair_op frac_op' Qp_half_half.
    iMod (own_update _ _ (1%Qp, to_agree (fill K e2')) with "HOwnOne") as "HOwnOne".
    rewrite agree_idemp.
    { apply cmra_update_exclusive. done. }
    rewrite -Qp_half_half -frac_op' -(agree_idemp (to_agree (fill K e2'))).
    iDestruct "HOwnOne" as "[Hown1 Hown2]".
    rewrite frac_op' Qp_half_half (agree_idemp (to_agree (fill K e2'))).
    (** close invariant *)
    iApply fupd_wand_r. iSplitL "Hclose Hown1". iApply ("Hclose" with "[Hown1]").
    iNext. iExists (fill K e2'). iFrame.
    iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto.
    destruct σ. by simpl in H. iFrame "Hown2". done.
  Qed.

  (* uninteresting technical lemmas *)
  Lemma nsteps_pure_step_ctx n e1' e2' K :
    nsteps pure_step n e1' e2' → nsteps pure_step n (fill K e1') (fill K e2').
  Proof.
    revert e2'. revert e1'.
    induction n.
    - intros e1 e2 H. inversion H. simplify_eq. constructor.
    - intros e1 e2 H. inversion H. econstructor.
      apply (pure_step_ctx (fill K)).
      apply H1. by apply IHn.
  Qed.

  Lemma pure_step_prim_step e e' : pure_step e e' → prim_step e tt [] e' tt [].
    intro Pstp. destruct Pstp. destruct (pure_step_safe tt).
    destruct H as [σ [ls Hprim]]. destruct σ.
    by destruct (pure_step_det tt [] x tt ls Hprim) as [_ [ _ [-> ->]]].
  Qed.

  Lemma pure_step_erased_step e e' : pure_step e e' → erased_step ([e], ()) ([e'],()).
  Proof. intros Pst. exists []. eapply (step_atomic _ _ _ _ _ _ _ [] [] []); eauto. by apply pure_step_prim_step. Qed.

  Lemma nsteps_pure_step_prim_step n e e' : nsteps pure_step n e e' → nsteps erased_step n ([e], ()) ([e'], ()).
  Proof.
    intros.
    cut (nsteps erased_step n ((fun e => ([e], ())) e) ((fun e => ([e], ())) e')). by simpl.
    eapply nsteps_congruence; eauto.
    intros. by apply pure_step_erased_step.
  Qed.

  (* Update static side with arbitrary amount of steps under an evaluation context *)
  Lemma steps_pure E ei' K e1' e2' n :
    (nsteps pure_step n e1' e2') →
    nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K e1') ={E}=∗ currently_half (fill K e2').
  Proof.
    iIntros (??) "[Hinv Hj]".
    rewrite /initially_inv /initially_body.
    iInv specN as ">Hinit" "Hclose".
    iDestruct "Hinit" as (ef') "[Hown %]".
    (** fill K e1' = ef' *)
    rewrite /currently_half.
    iDestruct (own_valid_2 with "Hown Hj") as "#eee".
    rewrite -pair_op frac_op' Qp_half_half.
    iDestruct "eee" as %[_ ->%agree_op_inv'%leibniz_equiv]%pair_valid.
    (** update *)
    (* bring together *)
    iDestruct (equiv_entails_sym _ _ (own_op _ _ _) with "[Hj Hown]") as "HOwnOne".
    iFrame.
    (* actually update *)
    rewrite -pair_op frac_op' Qp_half_half.
    iMod (own_update _ _ (1%Qp, to_agree (fill K e2')) with "HOwnOne") as "HOwnOne".
    rewrite agree_idemp.
    { apply cmra_update_exclusive. done. }
    rewrite -Qp_half_half -frac_op' -(agree_idemp (to_agree (fill K e2'))).
    iDestruct "HOwnOne" as "[Hown1 Hown2]".
    rewrite frac_op' Qp_half_half (agree_idemp (to_agree (fill K e2'))).
    (** close invariant *)
    iApply fupd_wand_r. iSplitL "Hclose Hown1". iApply ("Hclose" with "[Hown1]").
    iNext. iExists (fill K e2'). iFrame.
    iPureIntro. eapply rtc_transitive. apply H1.
    apply (nsteps_rtc n).
    apply nsteps_pure_step_prim_step. by apply nsteps_pure_step_ctx.
    iFrame "Hown2". done.
  Qed.

  (* Different instantiations of step_pure *)
  Lemma step_fst E ei' K e1' e2' :
    AsVal e1' → AsVal e2' →
    nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K (Fst (Pair e1' e2'))) ={E}=∗ currently_half (fill K e1').
  Proof. intros [? <-] [? <-]. apply step_pure with (σ := tt); econstructor; eauto. Qed.

  Lemma step_snd E ei' K e1' e2' :
    AsVal e1' → AsVal e2' → nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K (Snd (Pair e1' e2'))) ={E}=∗ currently_half (fill K e2').
  Proof. intros [? <-] [? <-]. apply step_pure with (σ := tt); econstructor; eauto. Qed.

  Lemma step_lam E ei' K e1' e2' :
    AsVal e2' → nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K (App (Lam e1') e2'))
    ={E}=∗ currently_half (fill K (e1'.[e2'/])).
  Proof. intros [? <-]; apply step_pure with (σ := tt); econstructor; eauto. Qed.

  Lemma step_Fold E ei' K e' :
    AsVal e' → nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K (Unfold (Fold e'))) ={E}=∗ currently_half (fill K e').
  Proof. intros [? <-]; apply step_pure with (σ := tt); econstructor; eauto. Qed.

  Lemma step_case_inl E ei' K e0' e1' e2' :
    AsVal e0' → nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K (Case (InjL e0') e1' e2'))
      ={E}=∗ currently_half (fill K (e1'.[e0'/])).
  Proof. intros [? <-]; apply step_pure with (σ := tt); econstructor; eauto. Qed.

  Lemma step_case_inr E ei' K e0' e1' e2' :
    AsVal e0' → nclose specN ⊆ E →
    initially_inv ei' ∗ currently_half (fill K (Case (InjR e0') e1' e2'))
      ={E}=∗ currently_half (fill K (e2'.[e0'/])).
  Proof. intros [? <-]; apply step_pure with (σ := tt); econstructor; eauto. Qed.

End cfg.


Variables S1 S2 : Set.

Goal @eq Type S1 S2 -> @eq Type S1 S2.
intro H.
Fail tauto.
assumption.
Qed.

(*This is in 8.5pl1, and Matthieq Sozeau says: "That's a regression in tauto indeed, which now requires exact equality of the universes, through a non linear goal pattern matching:
match goal with ?X1 |- ?X1 forces both instances of X1 to be convertible,
with no additional universe constraints currently, but the two types are
initially different. This can be fixed easily to allow the same flexibility
as in 8.4 (or assumption) to unify the universes as well."*)


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

  Defining type safety, page 67.

*)

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

Lemma A_2_Term_Weakening_1 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (x : var) (p p' : Path) (tau tau' : Tau),
    LVPE.extends u u' ->
    extends g g' ->
    WFC d u g ->
    WFC d u' g' ->
    gettype u  x p tau p' tau' ->
    gettype u' x p tau p' tau'.
Proof.
  intros.
  induction H3; auto.
  apply gettype_etype with (tau'':= tau''); auto.
Qed.

Function A_2_Term_Weakening_prop (In : Type) (H : TypJudgement In)
         (d : Delta) (u : Upsilon) (g : Gamma) (s : In) (t : Tau)
         (st : typ' d u g s t) :=
    typ' d u g s t ->
    WFC d u g ->
      forall (u' : Upsilon) (g' : Gamma),
        WFC d u' g' ->
        LVPE.extends u u' ->
        extends g g' ->
        typ' d u' g' s t.
Hint Unfold A_2_Term_Weakening_prop.

Ltac solve_typ :=
 match goal with
 | |- (styp _ _ _ (letx _ _) _)
	=> idtac "1"; apply_fresh_from styp_let_3_6 with fv_of_static_goal
 | |- (styp _ _ _ (openx _ _) _)
	=> idtac "2"; apply_fresh_from styp_open_3_7 with fv_of_static_goal
 | |- (styp _ _ _ (openstar _ _) _)
	=> idtac "3"; apply_fresh_from styp_openstar_3_8 with fv_of_static_goal
 | |- (rtyp _ _ _ (pack _ _ _) _)
	=> idtac "4"; apply_fresh_from SR_3_12 with fv_of_static_goal
 | |- (rtyp _ _ _ (f_e (ufun _ _)) _)
	=> idtac "5"; apply_fresh_from SR_3_14 with fv_of_static_goal
 | |- (rtyp _ _ _ (f_e (dfun _ _ _ )) _)
	=> idtac "6"; apply_fresh_from SR_3_13 with fv_of_static_goal
 | |- (ltyp _ _ _ (p_e _ _) _) =>
   idtac "12"; applys SL_3_1
 | |- (rtyp ?a ?b ?c (p_e ?d ?e) ?f) =>
   idtac "13 a b c d e f"; applys SR_3_1
 | |- (ltyp _ _ _  (dot (p_e _ _) zero_pe) _) =>
   idtac "14"; applys SL_3_3
 | |- (ltyp _ _ _ (dot (p_e _ _) one_pe)  _)  =>
   idtac "15"; applys SL_3_4
 | |- (rtyp _ _ _ (dot _ zero_pe) _)          =>
   idtac "16"; applys SR_3_3
 | |- (rtyp _ _ _ (dot _ one_pe)  _)          =>
   idtac "17"; applys SR_3_4
 | |- (styp _ _ _ (e_s _) _)                  =>
   idtac "18"; applys styp_e_3_1
 | |- (rtyp _ _ _ (appl _ _) _)               =>
   idtac "19"; applys SR_3_9
end.

Lemma gettype_weakening:
  forall u u' x tau' p tau,
  gettype u x nil tau' p tau ->
  LVPE.extends u u' ->
  gettype u' x nil tau' p tau.
Admitted.

Lemma A_2_Term_Weakening_2:
  forall (d : Delta) (u : Upsilon) (g : Gamma) (s : E) (t : Tau) (ty : typ' d u g s t),
   A_2_Term_Weakening_prop LtypJudgement d u g s t ty.
Proof.
  intros.
  Typ_Induction ltyp_ind_mutual A_2_Term_Weakening_prop; intros; auto.
  admit.
  admit.
  admit.
  apply SL_3_1 with (tau':=tau'); auto.
  apply gettype_weakening with (u:= u0); auto.
  apply SL_3_3 with (t1:= t1); auto.
  apply SL_3_4 with (t0:= t0); auto.
  apply SR_3_1 with (tau':= tau'); auto.
  apply gettype_weakening with (u:= u0); auto.
  apply SR_3_3 with (t1:= t1); auto.
  apply SR_3_4 with (t0:= t0); auto.
  apply SR_3_9 with (tau':= tau'); auto.
  apply SR_3_11 with (k:=k) (tau':= tau'); auto.
  admit.
  apply SR_3_13 with (L:=        ((((((((((((((L \u T.fv t) \u T.fv tau) \u T.fv tau') \u TM.fv_st s0) \u TM.fv_e s) \u
                TTM.fv_st s0) \u TTM.fv_e s) \u fv_delta d) \u
             fv_delta d0) \u fv_gamma g) \u fv_gamma g0) \u fv_gamma g') \u
         fv_upsilon u) \u fv_upsilon u0) \u fv_upsilon u'). auto.

  apply styp_let_3_6 with (tau':= tau') (L:=
((((((((((((((((L \u T.fv t) \u T.fv tau) \u T.fv tau') \u TM.fv_st s0) \u
                   TM.fv_e s) \u TM.fv_e e) \u TTM.fv_st s0) \u
                TTM.fv_e s) \u TTM.fv_e e) \u fv_delta d) \u fv_delta d0) \u
            fv_gamma g) \u fv_gamma g0) \u fv_gamma g') \u fv_upsilon u) \u
        fv_upsilon u0) \u fv_upsilon u').
  intros.
  auto.
  apply_fresh_from styp_let_3_6 with fv_of_static_goal.
  solve_typ.

  admit.
  admit.
  admit.

  admit.
  apply SL_3_3 with (t1:= t1); auto.
  apply SL_3_4 with (t0:= t0); auto.

barrier .

Lemma A_2_Term_Weakening_3:
  forall (d: Delta) (u : Upsilon) (g : Gamma)  (e : E) (tau : Tau),
    rtyp d u g e tau ->
    WFC d u g ->
      forall (u' : Upsilon) (g' : Gamma),
        WFC d u' g' ->
        U.extends u u' = true ->
        G.extends g g' = true ->
        WFC d u g' ->
        rtyp d u' g' e tau.
Proof.
(*
  intros d u g e tau ltypder.
  apply (rtyp_ind_mutual
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (t : Tau) (s : St)
                (st : styp d u g t s) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                styp d (u ++ u') (g ++ g') t s)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (lt : ltyp d u g  e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                ltyp d (u ++ u') (g ++ g') e t)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (rt : rtyp d u g e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                rtyp d (u ++ u') (g ++ g') e t)).
(*
  Case "styp_e_3_1".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_return_3_2".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_seq_3_3".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_while_3_4".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_if_3_5".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H2; try assumption.
   apply H0 with (u':= u') (g':= g') in H2; try assumption.
   apply H1 with (u':= u') (g':= g') in H2; try assumption.
  Case "styp_let_3_6".
   intros.
   apply styp_let_3_6 with (tau':=tau'); try assumption.
   AdmitAlphaConversion.
   inversion H2; try assumption.
   assert (Z: WFC d0 u0 ([(x, tau')] ++ g0)). (* How do I get this ? *)
   constructor; try assumption.
   constructor; try assumption.
   admit.
   admit.
   admit.
   admit.
   admit.
   (*
   apply H with (u':= u') (g':= g') in Z; try assumption.
   admit.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
   *)
  Case "styp_open_3_7".
   admit. (* Will have the similar problems with let. *)
  Case "styp_openstar_3_8".
   admit. (* Will have the similar problems with let. *)
  Case "SL_3_1".
  (* Should use the previous theorem.
   intros.
   apply SL_3_1 with (tau':= tau0); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
   *)
  admit.
  Case "SL_3_2".
   intros.
   admit. (* constructor; try assumption. *)
   (* apply H with (u':= u') (g':= g') in H0; try assumption. *)
  Case "SL_3_3".
   intros.
   apply SL_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_4".
   intros.
   apply SL_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_1".
   intros.
   apply SR_3_1 with (tau':= tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SR_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_3".
   intros.
   apply SR_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_4".
   intros.
   apply SR_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_5".
   intros.
   constructor; try assumption.
  Case "SR_3_6".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_7".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_8".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_9".
   intros.
   apply SR_3_9 with (tau':= tau'); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_10".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_11".
   intros.
   apply SR_3_11 with (k:=k); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_12".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_13".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   AdmitAlphaConversion.
   admit.
   admit.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   admit.
   admit.
  Case "SR_3_14".
   admit.
  Case "base".
   assumption.
Qed.
*)
*)
Admitted.

Lemma A_2_Term_Weakening_4:
  forall (d: Delta) (u : Upsilon) (g : Gamma)  (s : St) (tau : Tau),
    styp d u g tau s ->
    WFC d u g ->
      forall (u' : Upsilon) (g' : Gamma),
        WFC d u' g' ->
        U.extends u u' = true ->
        G.extends g g' = true ->
        WFC d u' g' ->
        styp d u' g' tau s.
Proof.
(*
  intros d u g e tau ltypder.
  apply (styp_ind_mutual
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (t : Tau) (s : St)
                (st : styp d u g t s) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                styp d (u ++ u') (g ++ g') t s)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (lt : ltyp d u g  e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                ltyp d (u ++ u') (g ++ g') e t)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (rt : rtyp d u g e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                rtyp d (u ++ u') (g ++ g') e t)).
  Case "styp_e_3_1".
   intros.
   apply styp_e_3_1 with (tau':= tau').
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_return_3_2".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_seq_3_3".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_while_3_4".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_if_3_5".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H2; try assumption.
   apply H0 with (u':= u') (g':= g') in H2; try assumption.
   apply H1 with (u':= u') (g':= g') in H2; try assumption.
  Case "styp_let_3_6".
   admit.
   (*
   intros.
   apply styp_let_3_6 with (tau':=tau'); try assumption.
   AdmitAlphaConversion.
   inversion H2; try assumption.
   assert (Z: WFC d0 u0 ([(x, tau')] ++ g0)). (* How do I get this ? *)
   constructor; try assumption.
   constructor; try assumption.

   apply H with (u':= u') (g':= g') in Z; try assumption.
   admit.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
    *)
  Case "styp_open_3_7".
   admit. (* Will have the similar problems with let. *)
  Case "styp_openstar_3_8".
   admit. (* Will have the similar problems with let. *)
  Case "SL_3_1".
   intros.
   apply SL_3_1 with (tau':=tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SL_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_3".
   intros.
   apply SL_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_4".
   intros.
   apply SL_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_1".
   intros.
   apply SR_3_1 with (tau':= tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SR_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_3".
   intros.
   apply SR_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_4".
   intros.
   apply SR_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_5".
   intros.
   constructor; try assumption.
  Case "SR_3_6".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_7".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_8".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_9".
   intros.
   apply SR_3_9 with (tau':= tau'); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_10".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_11".
   intros.
   apply SR_3_11 with (k:=k); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_12".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_13".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   AdmitAlphaConversion.
   admit.
   admit.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   admit.
   admit.
  Case "SR_3_14".
   admit.
  Case "base".
   assumption.
*)
Admitted.


(*** Boolean Utility Lemmas and Databases *)
Require Import Coq.Bool.Bool.
Require Import Coq.Classes.Morphisms.

(* We would use [Scheme Minimality for bool Sort Type.], but we want
   [bool_rect_nodep] to unfold directly to [bool_rect] so that
   unification doesn't have a hard time unifying [bool_rect] and
   [bool_rect_nodep] on large arguments. *)
Definition bool_rect_nodep {P} := @bool_rect (fun _ => P).
Global Instance bool_rect_nodep_Proper {P}
  : Proper (eq ==> eq ==> eq ==> eq) (@bool_rect_nodep P) | 10.
Proof. repeat intro; subst; reflexivity. Qed.
Module Thunked.
  Definition bool_rect P (t f : Datatypes.unit -> P) (b : bool) : P
    := Datatypes.bool_rect (fun _ => P) (t tt) (f tt) b.
  Global Instance bool_rect_Proper {P}
    : Proper ((eq ==> eq) ==> (eq ==> eq) ==> eq ==> eq) (@bool_rect P) | 10.
  Proof. cbv; intros ??? ??? [] ??; subst; eauto. Qed.
End Thunked.
(** Strongly prefer unfolding these versions of [bool_rect] to the
    underlying [bool_rect] principle.  Possibly -1 would suffice rather
    than expand, but I don't think there's harm in [expand] because
    [bool_rect] ought not be much more complicated than any of these *)
Global Strategy expand [bool_rect_nodep Thunked.bool_rect].

(** For equalities of booleans *)
Create HintDb bool_congr discriminated.
(** For properties of booleans, with, e.g., [iff] *)
Create HintDb bool_congr_setoid discriminated.
(** For generic simplifications of things involving booleans, e.g., if-statements *)
Create HintDb boolsimplify discriminated.

#[global] Hint Extern 1 => progress autorewrite with boolsimplify in * : boolsimplify.
#[global] Hint Extern 1 => progress autorewrite with bool_congr in * : bool_congr.
#[global] Hint Extern 1 => progress autorewrite with bool_congr_setoid in * : bool_congr_setoid.
#[global] Hint Extern 2 => progress rewrite_strat topdown hints bool_congr_setoid : bool_congr_setoid.

#[global] Hint Rewrite Bool.andb_diag Bool.orb_diag Bool.eqb_reflx Bool.negb_involutive Bool.eqb_negb1 Bool.eqb_negb2 Bool.orb_true_r Bool.orb_true_l Bool.orb_false_r Bool.orb_false_l Bool.orb_negb_r Bool.andb_false_r Bool.andb_false_l Bool.andb_true_r Bool.andb_false_r Bool.andb_negb_r Bool.xorb_false_r Bool.xorb_false_l Bool.xorb_true_r Bool.xorb_true_l Bool.xorb_nilpotent : bool_congr.
#[global] Hint Rewrite Bool.negb_if : boolsimplify.
#[global] Hint Rewrite <- Bool.andb_if Bool.andb_lazy_alt Bool.orb_lazy_alt : boolsimplify.
#[global] Hint Rewrite Bool.not_true_iff_false Bool.not_false_iff_true Bool.eqb_true_iff Bool.eqb_false_iff Bool.negb_true_iff Bool.negb_false_iff Bool.orb_true_iff Bool.orb_false_iff Bool.andb_true_iff Bool.andb_false_iff Bool.xorb_negb_negb : bool_congr_setoid.

Create HintDb push_orb discriminated.
Create HintDb pull_orb discriminated.
Create HintDb push_andb discriminated.
Create HintDb pull_andb discriminated.
Create HintDb push_negb discriminated.
Create HintDb pull_negb discriminated.
#[global] Hint Extern 1 => progress autorewrite with push_orb in * : push_orb.
#[global] Hint Extern 1 => progress autorewrite with pull_orb in * : pull_orb.
#[global] Hint Extern 1 => progress autorewrite with push_andb in * : push_andb.
#[global] Hint Extern 1 => progress autorewrite with pull_andb in * : pull_andb.
#[global] Hint Extern 1 => progress autorewrite with push_negb in * : push_negb.
#[global] Hint Extern 1 => progress autorewrite with pull_negb in * : pull_negb.
#[global] Hint Rewrite Bool.negb_orb Bool.negb_andb : push_negb.
#[global] Hint Rewrite Bool.xorb_negb_negb : pull_negb.
#[global] Hint Rewrite <- Bool.negb_orb Bool.negb_andb Bool.negb_xorb_l Bool.negb_xorb_r : pull_negb.
#[global] Hint Rewrite Bool.andb_orb_distrib_r Bool.andb_orb_distrib_l : push_andb.
#[global] Hint Rewrite <- Bool.orb_andb_distrib_r Bool.orb_andb_distrib_l : push_andb.
#[global] Hint Rewrite Bool.orb_andb_distrib_r Bool.orb_andb_distrib_l : pull_andb.
#[global] Hint Rewrite <- Bool.andb_orb_distrib_r Bool.andb_orb_distrib_l : pull_andb.
#[global] Hint Rewrite Bool.orb_andb_distrib_r Bool.orb_andb_distrib_l : push_orb.
#[global] Hint Rewrite <- Bool.andb_orb_distrib_r Bool.andb_orb_distrib_l : push_orb.
#[global] Hint Rewrite <- Bool.orb_andb_distrib_r Bool.orb_andb_distrib_l : pull_orb.
#[global] Hint Rewrite Bool.andb_orb_distrib_r Bool.andb_orb_distrib_l : pull_orb.

Definition pull_bool_if_dep {A B} (f : forall b : bool, A b -> B b) (b : bool) (x : A true) (y : A false)
  : (if b return B b then f _ x else f _ y) = f b (if b return A b then x else y)
  := if b return ((if b return B b then f _ x else f _ y) = f b (if b return A b then x else y))
     then eq_refl
     else eq_refl.

Definition pull_bool_if {A B} (f : A -> B) (b : bool) (x : A) (y : A)
  : (if b then f x else f y) = f (if b then x else y)
  := @pull_bool_if_dep (fun _ => A) (fun _ => B) (fun _ => f) b x y.

Definition reflect_iff_gen {P b} : reflect P b -> forall b' : bool, (if b' then P else ~P) <-> b = b'.
Proof.
  intros H; apply reflect_iff in H; intro b'; destruct b, b';
    intuition congruence.
Qed.

Definition andb_prop : forall a b : bool, a && b = true -> a = true /\ b = true. (* transparent version *)
Proof. destruct a, b; simpl; split; try reflexivity; assumption. Defined.

Definition andb_true_intro : forall a b : bool, a = true /\ b = true -> a && b = true. (* transparent version *)
Proof. destruct a, b; simpl; try reflexivity; intros [? ?]; assumption. Defined.

Definition andb_true_rect {a b : bool} (P : a && b = true -> Type) (f : forall p q, P (andb_true_intro a b (conj p q)))
  : forall p, P p.
Proof.
  destruct a, b; try specialize (f eq_refl eq_refl); cbn in *; intro p;
    first [ refine match p with eq_refl => f end
          | refine match p with eq_refl => I end ].
Defined.
Definition andb_true_rec {a b : bool} (P : a && b = true -> Set) := @andb_true_rect a b P.
Definition andb_true_ind {a b : bool} (P : a && b = true -> Prop) := @andb_true_rec a b P.

Definition andb_is_true_intro : forall a b : bool, is_true a /\ is_true b -> is_true (a && b)
  := andb_true_intro.

Definition andb_is_true_rect {a b : bool} (P : is_true (a && b) -> Type) (f : forall p q, P (andb_is_true_intro a b (conj p q)))
  : forall p, P p
  := @andb_true_rect a b P f.
Definition andb_is_true_rec {a b : bool} (P : is_true (a && b) -> Set) := @andb_is_true_rect a b P.
Definition andb_is_true_ind {a b : bool} (P : is_true (a && b) -> Prop) := @andb_is_true_rec a b P.

Ltac split_andb_step :=
  match goal with
  | [ H : andb _ _ = true |- _ ] => induction H using (@andb_true_rect _ _)
  | [ H : is_true (andb _ _) |- _ ] => induction H using (@andb_is_true_rect _ _)
  end.
Ltac split_andb := repeat split_andb_step.
Ltac split_andb_in_context_step :=
  match goal with
  | _ => split_andb_step
  | [ H : context[andb ?x ?y = true] |- _ ]
    => rewrite (Bool.andb_true_iff x y) in H
  | [ H : context[is_true (andb ?x ?y)] |- _ ]
    => change (is_true (andb x y)) with (andb x y = true) in H;
       rewrite Bool.andb_true_iff in H;
       change (x = true /\ y = true) with (is_true x /\ is_true y) in H
  end.
Ltac split_andb_in_context := repeat split_andb_in_context_step.

Lemma if_const A (b : bool) (x : A) : (if b then x else x) = x.
Proof. case b; reflexivity. Qed.

Lemma ex_bool_iff_or P : @ex bool P <-> (or (P true) (P false)).
Proof.
  split; [ intros [ [] ? ] | intros [?|?]; eexists ]; eauto.
Qed.

Lemma eqb_true_l x : Bool.eqb x true = x. Proof. now destruct x. Qed.
Lemma eqb_true_r x : Bool.eqb true x = x. Proof. now destruct x. Qed.
Lemma eqb_false_l x : Bool.eqb x false = negb x. Proof. now destruct x. Qed.
Lemma eqb_false_r x : Bool.eqb false x = negb x. Proof. now destruct x. Qed.
#[global] Hint Rewrite eqb_true_l eqb_true_r eqb_false_l eqb_false_r : boolsimplify.