(******************************************************************************)
(** * Definition of execution graph events and labels *)
(******************************************************************************)

Require Import List.
From hahn Require Import Hahn.

Set Implicit Arguments.

Definition thread_id := nat.
Definition tid_init := 0.

Definition location := nat.
Definition value := nat.

(******************************************************************************)
(** ** Execution graph events  *)
(******************************************************************************)

Inductive actid :=
  | InitEvent (l : location)
  | ThreadEvent (thread : thread_id) (index : nat).

Definition tid a :=
  match a with
    | InitEvent l => tid_init
    | ThreadEvent i _ => i
  end.

Definition is_tid i a : Prop := tid a = i.

Definition index a :=
  match a with
    | InitEvent l => 0
    | ThreadEvent _ n => n
  end.

Definition is_init a :=
  match a with
    | InitEvent _ => true
    | ThreadEvent _ _ => false
  end.

(******************************************************************************)
(** ** Same tid restriction *)
(******************************************************************************)

Definition same_tid := (fun x y => tid x = tid y).

Lemma restr_eq_rel_same_tid r :  restr_eq_rel tid r  ≡ r ∩ same_tid.
Proof. unfold same_tid; basic_solver. Qed.

Lemma loceq_same_tid (r: relation actid) (H: funeq tid r):
 r ⊆ r ∩ same_tid.
Proof.
unfold same_tid; basic_solver.
Qed.

Lemma same_tid_loceq (r: relation actid) (H: r ⊆ r ∩ same_tid):
 funeq tid r.
Proof.
unfold same_tid; unfolder; firstorder.
Qed.

(******************************************************************************)
(** ** Decidable equality *)
(******************************************************************************)

Lemma eq_dec_actid :
  forall x y : actid, {x = y} + {x <> y}.
Proof.
repeat decide equality.
Qed.

(******************************************************************************)
(** ** Labels  *)
(******************************************************************************)

Inductive mode :=
  | Opln
  | Orlx
  | Oacq
  | Orel
  | Oacqrel
  | Osc.

Definition mode_le lhs rhs :=
  match lhs, rhs with
    | Opln, _ => true
    | _, Opln => false
    | Orlx, _ => true
    | _, Orlx => false
    | Oacq, Oacq
    | Oacq, Oacqrel
    | Orel, Orel
    | Orel, Oacqrel
    | Oacqrel, Oacqrel
    | _, Osc => true
    | _ , _ => false
  end.

Inductive x_mode :=
  | Xpln
  | Xacq.

Inductive label :=
  | Aload  (ex:bool) (o:mode) (l:location) (v:value)
  | Astore (s:x_mode) (o:mode) (l:location) (v:value)
  | Afence (o:mode).

(*
   The meaning of the modes in each case:
   (currently Opln is redundant, easy to remove in the future)

                  IMM        POWER      ARM
   =================================================
   Aload Opln       rlx       ld         ldr
   Aload Orlx       rlx       ld         ldr
   Aload Oacq       acq       ld         ldapr (?)
   Aload Orel       rlx       ld         ldr
   Aload Oacqrel    acq       ld         ldapr (?)
   Aload Osc        acq       ld         ldapr (?)

   Astore Opln      rlx       st         str
   Astore Orlx      rlx       st         str
   Astore Oacq      rlx       st         str
   Astore Orel      rel       st         stlr
   Astore Oacqrel   rel       st         stlr
   Astore Osc       rel       st         stlr

   Afence Opln      no-op     no-op      no-op
   Afence Orlx      no-op     isync      F-ld
   Afence Oacq      acq       lwsync     F-ld
   Afence Orel      rel       lwsync     F-sy
   Afence Oacqrel   acq-rel   lwsync     F-sy
   Afence Osc       sc        sync       F-sy

 *)

Section Labels.

Variable A : Type.
Variable lab : A -> label.

Definition loc a :=
  match lab a with
  | Aload _ _ l _
  | Astore _ _ l _ => Some l
  | _ => None
  end.

Definition val a :=
  match lab a with
  | Aload  _ _ _ v
  | Astore _ _ _ v => Some v
  | _ => None
  end.

Definition mod a :=
  match lab a with
  | Aload  _ o _ _
  | Astore _ o _ _
  | Afence o => o
  end.

Definition xmod a :=
  match lab a with
  | Astore x _ _ _ => Some x
  | _ => None
  end.

Definition is_r a :=
  match lab a with
  | Aload  _ _ _ _ => true
  | _ => false
  end.

Definition is_w a :=
  match lab a with
  | Astore _ _ _ _ => true
  | _ => false
  end.

Definition is_f a :=
  match lab a with
  | Afence _ => true
  | _ => false
  end.

Definition is_only_pln a : bool :=
  match mod a with
  | Opln => true
  | _ => false
  end.

Definition is_only_rlx a : bool :=
  match mod a with
  | Orlx => true
  | _ => false
  end.

Definition is_rlx a : bool := mode_le Orlx (mod a).
Definition is_acq a : bool := mode_le Oacq (mod a).
Definition is_rel a : bool := mode_le Orel (mod a).
Definition is_acqrel a : bool := mode_le Oacqrel (mod a).
Definition is_sc a : bool :=
  match mod a with
  | Osc => true
  | _ => false
  end.

Definition is_ra a : bool := is_acq a || is_rel a.

Lemma lab_rwf a : is_r a \/ is_w a \/ is_f a.
Proof. unfold is_r, is_w, is_f; destruct (lab a); auto. Qed.

Definition is_xacq a :=
  match xmod a with
  | Some Xacq => true
  | _ => false
  end.

Definition R_ex a :=
  match lab a with
  | Aload r _ _ _ => r
  | _ => false
  end.

Lemma R_ex_in_R : R_ex ⊆₁ is_r.
Proof.
unfold R_ex, is_r; basic_solver.
Qed.

Definition rmwmod a :=
  match lab a with
  | Aload r _ _ _ => Some r
  | _ => None
  end.

(******************************************************************************)
(** ** Same location restriction *)
(******************************************************************************)

Definition same_loc := (fun x y => loc x = loc y).

Lemma restr_eq_rel_same_loc r :  restr_eq_rel loc r  ≡ r ∩ same_loc.
Proof. unfold same_loc; basic_solver. Qed.

Lemma loceq_same_loc (r: relation A) (H: funeq loc r):
 r ⊆ r ∩ same_loc.
Proof.
unfold same_loc; basic_solver.
Qed.

Lemma same_loc_loceq (r: relation A) (H: r ⊆ r ∩ same_loc):
 funeq loc r.
Proof.
unfold same_loc; unfolder; firstorder.
Qed.

Lemma same_loc_trans : transitive same_loc.
Proof. unfold same_loc; red; ins. by rewrite H. Qed.

Lemma same_loc_sym : symmetric same_loc.
Proof. unfold same_loc; red; ins. Qed.

(******************************************************************************)
(** ** Values and locations getters  *)
(******************************************************************************)

Lemma is_w_val x (WX : is_w x) : exists v, val x = Some v.
Proof. unfold is_w, val in *; desf. eexists; eauto. Qed.

Lemma is_w_loc x (WX : is_w x) : exists l, loc x = Some l.
Proof. unfold is_w, loc in *; desf. eexists; eauto. Qed.

Lemma is_r_val x (WX : is_r x) : exists v, val x = Some v.
Proof. unfold is_r, val in *; desf. eexists; eauto. Qed.

Lemma is_r_loc x (WX : is_r x) : exists l, loc x = Some l.
Proof. unfold is_r, loc in *; desf. eexists; eauto. Qed.

End Labels.

(******************************************************************************)
(** ** Identical labeling up to value  *)
(******************************************************************************)

Definition same_label_u2v label1 label2 :=
  match label1, label2 with
  | Aload  r1 o1 l1 _, Aload  r2 o2 l2 _ => r1 = r2 /\ o1 = o2 /\ l1 = l2
  | Astore s1 o1 l1 _, Astore s2 o2 l2 _ => s1 = s2 /\ o1 = o2 /\ l1 = l2
  | Afence o1, Afence o2 => o1 = o2
  | _,_ => False
  end.

(******************************************************************************)
(** ** Sequenced-Before *)
(******************************************************************************)

Require Import Lia.

Definition ext_sb a b :=
  match a, b with
    | _, InitEvent _ => False
    | InitEvent _, ThreadEvent _ _ => True
    | ThreadEvent t i, ThreadEvent t' i' => t = t' /\ i < i'
   end.

Lemma ext_sb_trans : transitive ext_sb.
Proof.
unfold ext_sb; red; ins.
destruct x,y,z; ins; desf; splits; eauto.
by rewrite H2.
Qed.

Lemma ext_sb_irr : irreflexive ext_sb.
Proof.
unfold ext_sb; red; ins.
destruct x; firstorder. intuition.
Qed.

Lemma ext_sb_to_non_init : ext_sb ⊆ ext_sb ⨾  ⦗fun x => ~ is_init x⦘.
Proof.
unfold is_init, ext_sb; basic_solver.
Qed.

Lemma ext_sb_semi_total_l x y z
  (N: ~ is_init x) (NEQ: index y <> index z) (XY: ext_sb x y) (XZ: ext_sb x z):
  ext_sb y z \/ ext_sb z y.
Proof.
unfold ext_sb in *.
destruct x,y,z; ins; desf.
cut(index1 < index2 \/ index2 < index1).
tauto.
lia.
Qed.

Lemma ext_sb_semi_total_r x y z
  (NEQ: index y <> index z) (XY: ext_sb y x) (XZ: ext_sb z x):
  ext_sb y z \/ ext_sb z y.
Proof.
unfold ext_sb in *.
destruct x,y,z; ins; desf; eauto.
cut(index1 < index2 \/ index2 < index1).
tauto.
lia.
Qed.

Lemma ext_sb_tid_init x y (SB : ext_sb x y): tid x = tid y \/ is_init x.
Proof.
unfold ext_sb in *; desf; ins; desf; eauto.
Qed.

Lemma ext_sb_tid_init': ext_sb ⊆ ext_sb ∩ same_tid ∪ ⦗is_init⦘ ⨾ ext_sb.
Proof.
generalize ext_sb_tid_init; firstorder.
Qed.

Lemma tid_ext_sb: same_tid ⊆ ext_sb^? ∪ ext_sb^{-1} ∪ (is_init × is_init).
Proof.
unfold ext_sb, same_tid, tid, is_init, cross_rel; unfolder.
ins; destruct x, y; desf; eauto.
cut(index0 < index1 \/ index1 < index0 \/ index0 = index1).
by ins; desf; eauto.
lia.
Qed.

Lemma tid_n_init_ext_sb: same_tid ⨾ ⦗set_compl is_init⦘ ⊆ ext_sb^? ∪ ext_sb^{-1}.
Proof.
rewrite tid_ext_sb at 1.
unfold cross_rel.
basic_solver 12.
Qed.

(******************************************************************************)
(** ** Tactics *)
(******************************************************************************)

#[global]
Hint Unfold set_union set_inter is_r is_w is_f R_ex : type_unfolderDb.
Tactic Notation "type_unfolder" :=  repeat autounfold with type_unfolderDb in *.

Tactic Notation "type_solver" int_or_var(index) :=
  type_unfolder; basic_solver index.

Tactic Notation "type_solver" :=  type_solver 4.

#[global]
Hint Unfold set_union set_inter is_r is_w is_f R_ex : mode_unfolderDb.
#[global]
Hint Unfold is_only_pln is_only_rlx is_rlx is_rel is_acq is_acqrel is_sc is_ra is_xacq : mode_unfolderDb.
Tactic Notation "mode_unfolder" :=  repeat autounfold with mode_unfolderDb in *.

Tactic Notation "mode_solver" int_or_var(index) :=
  mode_unfolder; basic_solver index.

Tactic Notation "mode_solver" :=  mode_solver 4.


Extraction Language Scheme.

Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Bag.
Require Import Dict.
Require Import CpdtTactics.
Require Import JamesTactics.
Require Import KonneTactics.
Require Import Coq.Program.Basics.
Require Import EqDec.
Require Import Enumerable.
Require Import BGPSpec.
Require Import Equality.
Require Import SymbolicExecution.
Require Import Graph.
Require Import SingleAS.
Require Import BGPV.
Require Import SpaceSearch.
Require Import Rosette.
Require Import Misc.
Import ListNotations.
Import EqNotations.

(* LOCAL_PREF nat does not match the ones used in Racket *)
(* router lists do not match the one used in Racket *)

  Instance freeList `{SpaceSearch} {A} (l:list A) : Free {a | In a l}.
    induction l.
    - refine {| free := empty |}.
      intros [? []].
    - refine {| free := _ |}.
      + refine (union _ _).
        * refine (single (exist _ a _)).
          cbn.
          left.
          reflexivity.
        * refine (bind (free {a | In a l}) _).
          intros [a' ?].
          refine (single (exist _ a' _)).
          cbn in *.
          right.
          trivial.
      + intros [a' inl'].
        cbn in *.
        rewrite <- unionOk.
        destruct inl' as [|inl'].
        * left.
          subst_max.
          apply singleOk.
          reflexivity.
        * right.
          rewrite <- bindOk.
          exists (exist _ a' inl').
          constructor; [apply freeOk|].
          apply singleOk.
          reflexivity.
  Defined.

  Instance enumerableFree {A} {h:forall (S:SpaceSearch), @Free S A} : enumerable A.
    specialize (h listSpaceSearch).
    destruct h.
    cbn in *.
    refine {|enumerate := free|}.
    trivial.
  Defined.

Parameter IP : Type.
Parameter eqDecideIP : forall (r r':IP), decide (r = r').

Extract Constant IP => "__".
Extract Constant eqDecideIP => "eq-dec?".

Instance eqDecIP : eqDec IP.
  constructor.
  apply eqDecideIP.
Defined.

Parameter CIDR : Type.
Parameter eqDecideCIDR : forall (r r':CIDR), decide (r = r').
Parameter freeCIDR : Space CIDR.
Axiom freeCIDROk : forall p, contains p freeCIDR.

Extract Constant CIDR => "__".
Extract Constant eqDecideCIDR => "eq-dec?".
Extract Constant freeCIDR => "(lambda (_) (symbolic-prefix))".

Instance FreeCIDR : Free CIDR := {|
  free := freeCIDR;
  freeOk := freeCIDROk
|}.

Instance eqDecCIDR : eqDec CIDR.
  constructor.
  apply eqDecideCIDR.
Defined.

Instance cidrPrefix : PrefixClass := {|
  Prefix := CIDR
|}.

Section BGPV.
  Existing Instance freeUnit.

  Parameter AS : Type.
  Parameter BGPAttributes : AS -> Type.

  Variable setup:AS.

  Definition LOCAL_PREF (_:BGPAttributes setup) := 0.  (* TODO local-pref is still broken *)
  (* Parameter LOCAL_PREF : BGPAttributes -> nat. *)
  Parameter eqDecideBGPAttributes : forall (r r':BGPAttributes setup), decide (r = r').

  Instance eqDecBGPAttributes : eqDec (BGPAttributes setup).
    constructor.
    apply eqDecideBGPAttributes.
  Defined.

  Instance bgpAttributes : PathAttributesClass := {|
    PathAttributes := BGPAttributes setup;
    localPref := LOCAL_PREF
  |}.

  Parameter freeBGPAttributes : Space (BGPAttributes setup).
  Parameter freeBGPAttributesOk : forall p, contains p (freeBGPAttributes).
  Instance FreeBGPAttributes : Free (BGPAttributes setup) := {|
    free := freeBGPAttributes;
    freeOk := freeBGPAttributesOk
  |}.

  Parameter internals : AS -> list IP.
  Parameter neighbors : {ri | In ri (internals setup)} -> list IP.

  Definition bagpipeRouter (t:RouterType) :=
    match t with
    | internal => {ri | In ri (internals setup)}
    | external => {re | exists riOk, In re (neighbors riOk)}
    end.

  Definition bagpipeNeighbor (ri:bagpipeRouter internal) (re:bagpipeRouter external) : Type.
    cbn in *.
    destruct re as [re ?].
    exact (In re (neighbors ri)).
  Defined.

  Instance freeRouter `{SpaceSearch} : forall t, Free (bagpipeRouter t).
    intros []; cbn.
    - refine {| free := bind (free {a | In a (internals setup)}) single |}.
      intros i.
      rewrite <- bindOk.
      exists i.
      constructor; [apply freeOk|].
      rewrite <- singleOk.
      reflexivity.
    - refine {| free := _ |}.
      + refine (bind (free {a | In a (internals setup)}) _).
        intros ri.
        refine (bind (free {a | In a (neighbors ri)}) _).
        intros [re ?].
        apply single.
        refine (exist _ re _).
        exists ri.
        intuition.
      + intros [re [riOk reOk]].
        rewrite <- bindOk.
        exists riOk.
        constructor; [apply freeOk|].
        rewrite <- bindOk.
        exists (exist _ re reOk).
        constructor; [apply freeOk|].
        apply singleOk.
        reflexivity.
  Defined.

  Instance freeNeighbors `{SpaceSearch} : forall s, Free {d : bagpipeRouter external & bagpipeNeighbor s d}.
    intro r.
    refine {| free := bind (free {a | In a (neighbors r)}) _ |}. {
      cbn in *.
      intros [d n].
      refine (single [exist _ d _ & n]).
      exists r.
      exact n.
    }
  Proof.
    intros [[d [r' n']] n].
    cbn in *.
    apply bindOk.
    exists (exist _ d n).
    constructor; [apply freeOk|].
    apply singleOk.
    generalize_proofs.
    reflexivity.
  Defined.

  Instance freeNeighbor `{SpaceSearch} : forall s d, Free (bagpipeNeighbor s d).
    unfold bagpipeNeighbor.
    cbn.
    intros riOk [re reOk'].
    cbn.
    refine {| free := _ |}.
    - destruct (@in_dec _ eqDecide re (neighbors riOk)).
      + apply single.
        trivial.
      + apply empty.
    - intros reOk.
      cbn.
      break_match.
      + proof_irrelevance.
        apply singleOk.
        reflexivity.
      + intuition.
  Defined.

  Instance bagpipeTopology : SingleASTopologyClass.
    refine {|
      router := bagpipeRouter;
      neighbor := bagpipeNeighbor
    |}.
  Proof.
  - intros []; constructor; apply eqDecide.
  - cbn.
    intros [s ?] [d ?].
    cbn.
    constructor.
    intros c c'.
    left.
    proof_irrelevance.
    reflexivity.
  Defined.

  Existing Instance singleASTopology.

  Parameter denoteImport : forall r:router internal, incoming [internal & r] -> Prefix -> PathAttributes -> RoutingInformation.
  Parameter denoteExport : forall r:router internal, outgoing [internal & r] -> Prefix -> PathAttributes -> RoutingInformation.

  Parameter Query : Type.
  Parameter denoteQuery : Query -> forall r, incoming [internal & r] -> outgoing [internal & r] -> Prefix ->
                          @RoutingInformation trackingAttributes' ->
                          @RoutingInformation trackingAttributes' ->
                          @RoutingInformation trackingAttributes' -> bool.

  Instance bagpipeConfiguration : SingleASConfigurationClass.
    refine {|
      intImport := denoteImport;
      intExport r i := denoteExport r
    |}.
  Defined.

  Definition bgpvCore' := @bgpvCore rosette _ _ _ _ _ _ Query denoteQuery.

  Definition listSearch {A} := @search listSpaceSearch A.
  Definition listBind {A B} := @bind listSpaceSearch A B.

  Parameter bgpvScheduler : forall Q v, {o | o = listSearch (listBind v (compose optionToSpace (bgpvCore' Q)))}.

  Definition bgpv := @parallelBGPV rosette _ _ _ _ _ _ _ _ Query denoteQuery listSpaceSearch bgpvScheduler.
  Definition bgpvImport := @parallelBGPVImport rosette _ _ _ _ _ _ _ _ Query denoteQuery listSpaceSearch bgpvScheduler.

(* Definition bgpv := @fastPolicyDec' rosette _ _ _ _ _ _ _ _ Query denoteQuery. *)
End BGPV.

Extract Constant Query => "__".
Extract Constant denoteQuery => "(lambdas (_) denote-query)".

Extract Constant AS => "__".
Extract Constant BGPAttributes => "__".
Extract Constant eqDecideBGPAttributes => "(lambdas (_) eq-dec?)".
Extract Constant freeBGPAttributes => "(lambdas (as _) (symbolic-announcement (as->environment as)))".
Extract Constant denoteImport => "denote-import".
Extract Constant denoteExport => "denote-export".
Extract Constant internals => "denote-internals".
Extract Constant neighbors => "denote-neighbors".

(* Extract Constant LOCAL_PREF => "announcement-pref". *)

Extract Constant bgpvScheduler => "distributed-bgpv-scheduler".

Extraction "bgpv" bgpv bgpvImport bgpvCore' optionToSpace.


Require Import Lia.
Require Import Bool.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Require Import PromiseConsistent.
Require Import Trace.
Require Import MemoryProps.
Require Import JoinedView.

Require Import PFStep.
Require Import OrdStep.
Require Import Writes.
Require Import WStep.
Require Import Stable.
Require Import PFtoAPFSim.
Require Import APFtoRASim.
Require Import PFtoRAThread.

Set Implicit Arguments.

Module PFtoRA.
  Section PFtoRA.
    Variable L: Loc.t -> bool.

    (* well-formedness *)

    Inductive wf_pf (c: Configuration.t): Prop :=
    | wf_pf_intro
        (WF: Configuration.wf c)
        (PF: PF.pf_configuration L c)
    .

    Definition wf_j := JConfiguration.wf.

    Inductive wf_ra (rels: Writes.t) (c: Configuration.t): Prop :=
    | wf_ra_intro
        (WF: Configuration.wf c)
        (PROMISES: forall tid lang st lc
                     (TH: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)),
            OrdLocal.reserve_only L (Local.promises lc))
        (RELS: forall tid lang st lc
                 (TH: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)),
            Writes.wf L rels (Configuration.memory c))
    .

    Lemma wf_pf_thread
          c tid lang st lc
          (WF: wf_pf c)
          (FIND: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)):
      PFtoRAThread.wf_pf (Thread.mk _ st lc (Configuration.sc c) (Configuration.memory c)).
    Proof.
      inv WF. inv WF0. inv WF.
      hexploit THREADS; eauto. i.
      econs; eauto.
    Qed.

    Lemma wf_j_thread
          views c tid lang st lc
          (WF: wf_j views c)
          (FIND: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)):
      PFtoRAThread.wf_j views (Thread.mk _ st lc (Configuration.sc c) (Configuration.memory c)).
    Proof.
      inv WF. inv WF0. inv WF.
      hexploit THREADS; eauto. i.
      hexploit REL; eauto. i.
      econs; eauto.
    Qed.

    Lemma wf_ra_thread
          rels c tid lang st lc
          (WF: wf_ra rels c)
          (FIND: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)):
      PFtoRAThread.wf_ra L rels (Thread.mk _ st lc (Configuration.sc c) (Configuration.memory c)).
    Proof.
      inv WF. inv WF0. inv WF.
      econs; eauto.
    Qed.

    Lemma step_pf_future
          e tid c1 c2
          (WF1: wf_pf c1)
          (STEP: PFConfiguration.step L e tid c1 c2):
      <<WF2: wf_pf c2>>.
    Proof.
      exploit PFConfiguration.step_future; eauto; try apply WF1. i. des. ss.
    Qed.

    Lemma step_j_future
          e tid c1 c2 views1 views2
          (WF1: wf_j views1 c1)
          (STEP: JConfiguration.single_step e tid c1 c2 views1 views2):
      <<WF2: wf_j views2 c2>>.
    Proof.
      eapply JConfiguration.single_step_future; eauto.
    Qed.

    Lemma step_ra_future
          ordr ordw
          e tid rels1 rels2 c1 c2
          (WF1: wf_ra rels1 c1)
          (ORD: Ordering.le Ordering.plain ordw)
          (STEP: WConfiguration.step L ordr ordw e tid rels1 rels2 c1 c2):
      <<WF2: wf_ra rels2 c2>>.
    Proof.
      exploit WConfiguration.step_future; try eapply WF1; eauto. i. des.
      inv STEP. ss.
      assert (STEPS': WThread.steps L ordr ordw rels1 rels2
                                    (Thread.mk _ st1 lc1 (Configuration.sc c1) (Configuration.memory c1))
                                    (Thread.mk _ st4 lc4 sc4 memory4)).
      { exploit WThread.tau_steps_steps;
          try eapply WThread.cancel_steps_tau_steps; try exact CANCELS. i.
        exploit WThread.opt_step_steps; try exact STEP0. i.
        exploit WThread.tau_steps_steps;
          try eapply WThread.reserve_steps_tau_steps; try exact RESERVES. i.
        eapply WThread.steps_trans; [eauto|].
        eapply WThread.steps_trans; eauto.
      }
      exploit wf_ra_thread; eauto. i.
      hexploit WThread.steps_writes_wf; try exact STEPS'; try apply x1; ss. i.
      econs; ss. i. Configuration.simplify; ss.
      - hexploit OrdThread.rtc_cancel_step_reserve_only; try eapply x1; eauto. i. des.
        hexploit WThread.opt_step_ord_opt_step; eauto. i.
        hexploit OrdThread.opt_step_reserve_only; try exact H1; eauto. i. des.
        hexploit OrdThread.rtc_reserve_step_reserve_only; eauto.
      - exploit wf_ra_thread; try eapply TH; eauto. i. apply x2.
    Qed.

    Lemma steps_pf_future
          c1 c2
          (WF1: wf_pf c1)
          (STEPS: rtc (PFConfiguration.all_step L) c1 c2):
      <<WF2: wf_pf c2>>.
    Proof.
      exploit PFConfiguration.rtc_all_step_future; try apply WF1; eauto. i. des.
      econs; ss.
    Qed.

    Lemma steps_j_future
          c1 c2 views1 views2
          (WF1: wf_j views1 c1)
          (STEPS: JConfiguration.single_steps c1 c2 views1 views2):
      <<WF2: wf_j views2 c2>>.
    Proof.
      eapply JConfiguration.single_steps_future; eauto.
    Qed.

    Lemma steps_ra_future
          ordr ordw
          rels1 rels2 c1 c2
          (WF1: wf_ra rels1 c1)
          (ORD: Ordering.le Ordering.plain ordw)
          (STEPS: WConfiguration.steps L ordr ordw rels1 rels2 c1 c2):
      <<WF2: wf_ra rels2 c2>>.
    Proof.
      revert WF1. induction STEPS; i; ss.
      exploit step_ra_future; eauto.
    Qed.

    (* sim *)

    Inductive sim_thread_sl (views: Loc.t -> Time.t -> list View.t) (rels: Writes.t)
              (sc_pf sc_j sc_apf sc_ra: TimeMap.t) (mem_pf mem_j mem_apf mem_ra: Memory.t):
      forall (sl_pf sl_j sl_apf sl_ra: {lang: language & Language.state lang} * Local.t), Prop :=
    | sim_thread_sl_intro
        lang st_pf lc_pf st_j lc_j st_apf lc_apf st_ra lc_ra
        (SIM: PFtoRAThread.sim_thread L views rels
                                      (Thread.mk lang st_pf lc_pf sc_pf mem_pf)
                                      (Thread.mk lang st_j lc_j sc_j mem_j)
                                      (Thread.mk lang st_apf lc_apf sc_apf mem_apf)
                                      (Thread.mk lang st_ra lc_ra sc_ra mem_ra)):
        sim_thread_sl views rels sc_pf sc_j sc_apf sc_ra mem_pf mem_j mem_apf mem_ra
                      (existT _ lang st_pf, lc_pf) (existT _ lang st_j, lc_j)
                      (existT _ lang st_apf, lc_apf) (existT _ lang st_ra, lc_ra)
    .

    Definition option_rel4 {A B C D} (P: A -> B -> C -> D -> Prop):
      option A -> option B -> option C -> option D -> Prop :=
      fun a b c d =>
        match a, b, c, d with
        | Some x, Some y, Some z, Some w => P x y z w
        | None, None, None, None => True
        | _, _, _, _ => False
        end.

    Inductive sim_conf (views: Loc.t -> Time.t -> list View.t) (rels: Writes.t):
      forall (c_pf c_j c_apf c_ra: Configuration.t), Prop :=
    | sim_conf_intro
        ths_pf sc_pf mem_pf
        ths_j sc_j mem_j
        ths_apf sc_apf mem_apf
        ths_ra sc_ra mem_ra
        (THS: forall tid,
            option_rel4
              (sim_thread_sl views rels sc_pf sc_j sc_apf sc_ra mem_pf mem_j mem_apf mem_ra)
              (IdentMap.find tid ths_pf)
              (IdentMap.find tid ths_j)
              (IdentMap.find tid ths_apf)
              (IdentMap.find tid ths_ra)):
        sim_conf views rels
                 (Configuration.mk ths_pf sc_pf mem_pf)
                 (Configuration.mk ths_j sc_j mem_j)
                 (Configuration.mk ths_apf sc_apf mem_apf)
                 (Configuration.mk ths_ra sc_ra mem_ra)
    .

    Lemma init_wf_pf syn:
      wf_pf (Configuration.init syn).
    Proof.
      econs; eauto using Configuration.init_wf, PF.configuration_init_pf.
    Qed.

    Lemma init_wf_j syn:
      wf_j (fun _ => fun _ => []) (Configuration.init syn).
    Proof.
      econs; eauto using Configuration.init_wf.
      - i. ss.
        unfold Threads.init in *.
        rewrite IdentMap.Facts.map_o in *.
        destruct (@UsualFMapPositive.UsualPositiveMap'.find
                    (@sigT _ (@Language.syntax ProgramEvent.t)) tid syn); inv TH.
        apply inj_pair2 in H1. subst. ss. ii.
        rewrite Memory.bot_get in *. ss.
      - ss. econs; ss. i.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0.
      - ss.
    Qed.

    Lemma init_wf_ra syn:
      wf_ra [] (Configuration.init syn).
    Proof.
      econs; eauto using Configuration.init_wf; i; ss.
      - unfold Threads.init in *.
        rewrite IdentMap.Facts.map_o in *.
        destruct (@UsualFMapPositive.UsualPositiveMap'.find
                    (@sigT _ (@Language.syntax ProgramEvent.t)) tid syn); inv TH.
        apply inj_pair2 in H1. subst. ss. ii.
        rewrite Memory.bot_get in *. ss.
      - econs; i; ss.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0. ss.
    Qed.

    Lemma init_sim_conf syn:
      sim_conf (fun _ => fun _ => []) []
               (Configuration.init syn) (Configuration.init syn)
               (Configuration.init syn) (Configuration.init syn).
    Proof.
      econs; ss. i. unfold option_rel3.
      destruct (IdentMap.find tid (Threads.init syn)) as [[[lang st] lc]|] eqn:FIND; ss.
      unfold Threads.init in *.
      rewrite IdentMap.Facts.map_o in *.
      destruct (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) tid syn); inv FIND.
      apply inj_pair2 in H1. subst.
      econs. econs; ss.
      - econs; ss; try refl. econs; try refl. ii.
        rewrite Memory.bot_get. ss.
      - econs; ss. econs; ss; eauto. i.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0. ss.
      - econs; ss.
        + econs; ss. econs; ss. i. condtac; ss. refl.
        + econs; ss; i.
          * unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
            apply DOMap.singleton_find_inv in GET_SRC. des. inv GET_SRC0.
            esplits; ss. econs. condtac; ss.
          * unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
            apply DOMap.singleton_find_inv in GET_TGT. des. inv GET_TGT0.
            esplits; ss. econs. condtac; ss.
      - econs; ss. ii.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0.
      - econs; ss. ii.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0.
      - econs; ss. ii. des; ss.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET1.
    Qed.

    Lemma sim_conf_terminal
          views rrels c_pf c_j c_apf c_ra
          (SIM: sim_conf views rrels c_pf c_j c_apf c_ra)
          (TERMINAL: Configuration.is_terminal c_pf):
      Configuration.is_terminal c_ra.
    Proof.
      ii. inv SIM. specialize (THS tid).
      unfold option_rel4 in *. ss. des_ifs.
      destruct p as [[]], p0 as [[]], p1 as [[]]. inv THS.
      apply inj_pair2 in H7, H4, H1, H10. subst.
      inv SIM. inv SIM_JOINED. inv SIM_APF. inv SIM_RA. ss.
      apply inj_pair2 in H2, H6. subst.
      exploit TERMINAL; eauto. i. des.
      split; ss.
      inv THREAD. econs.
      inv LOCAL1. rewrite PROMISES0.
      eapply JSim.sim_local_memory_bot; eauto.
    Qed.

    (* step *)

    Lemma sim_conf_step
          views1 rels1 c1_pf c1_j c1_apf c1_ra
          tid e_pf c2_pf
          (SIM1: sim_conf views1 rels1 c1_pf c1_j c1_apf c1_ra)
          (WF1_PF: wf_pf c1_pf)
          (WF1_J: wf_j views1 c1_j)
          (WF1_APF: wf_ra rels1 c1_apf)
          (WF1_RA: wf_ra rels1 c1_ra)
          (STEP: PFConfiguration.step L e_pf tid c1_pf c2_pf):
      (exists e_j c2_j e_apf c2_apf views2 e_ra rels2 c2_ra,
          (<<STEP_J: JConfiguration.single_step e_j tid c1_j c2_j views1 views2>>) /\
          (<<STEP_APF: WConfiguration.step L Ordering.na Ordering.plain
                                           e_apf tid rels1 rels2 c1_apf c2_apf>>) /\
          (<<STEP_RA: WConfiguration.step L Ordering.acqrel Ordering.acqrel
                                          e_ra tid rels1 rels2 c1_ra c2_ra>>) /\
          (<<EVENT_J: JSim.sim_event e_j e_pf>>) /\
          (<<EVENT_APF: PFtoAPFSim.sim_event e_apf e_j>>) /\
          (<<EVENT_RA: APFtoRASim.sim_event e_ra e_apf>>) /\
          (<<SIM2: sim_conf views2 rels2 c2_pf c2_j c2_apf c2_ra>>)) \/
      (<<RACE: RARaceW.ra_race_steps L Ordering.acqrel Ordering.acqrel rels1 c1_ra>>).
    Proof.
      dup SIM1. inv SIM0. inv STEP. ss.
      dup THS. specialize (THS0 tid). unfold option_rel4 in THS0. des_ifs.
      inv THS0. apply inj_pair2 in H1. subst.
      exploit wf_pf_thread; eauto. s. i.
      exploit wf_j_thread; eauto. s. i.
      exploit wf_ra_thread; try exact WF1_APF; eauto. s. i.
      exploit wf_ra_thread; try exact WF1_RA; eauto. s. i.
      exploit PFtoRAThread.sim_thread_cancel_steps; eauto.
      { exploit PFtoRAThread.cancel_steps_pf_future; eauto. i.
        exploit PFtoRAThread.opt_step_pf_future; eauto. i.
        exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
        destruct (classic (ThreadEvent.get_machine_event e_pf = MachineEvent.failure)).
        - inv STEP0; ss. inv STEP; inv STEP0; ss.
          inv LOCAL; ss; inv LOCAL0; ss.
        - eapply opt_step_promise_consistent; eauto; try apply x4.
          eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent;
            try eapply PF.pf_consistent_consistent; eauto; try apply x6.
      }
      i. des.
      exploit PFtoRAThread.cancel_steps_pf_future; eauto. i.
      exploit PFtoRAThread.cancel_steps_j_future; eauto. i.
      exploit PFtoRAThread.cancel_steps_ra_future; try exact x2; eauto. i.
      exploit PFtoRAThread.cancel_steps_ra_future; try exact x3; eauto. i.
      exploit PFtoRAThread.sim_thread_opt_step; eauto.
      { exploit PFtoRAThread.opt_step_pf_future; eauto. i.
        exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
        destruct (classic (ThreadEvent.get_machine_event e_pf = MachineEvent.failure)).
        - inv STEP0; ss. inv STEP; inv STEP0; ss.
          inv LOCAL; ss; inv LOCAL0; ss.
        - eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent;
            try eapply PF.pf_consistent_consistent; eauto; try apply x9.
      }
      i. des; cycle 1.
      { right. unfold RARaceW.ra_race_steps.
        esplits; [econs 1|..]; eauto. s.
        eapply WThread.tau_steps_steps.
        eapply WThread.cancel_steps_tau_steps; eauto.
      }
      exploit PFtoRAThread.opt_step_pf_future; eauto. i.
      exploit PFtoRAThread.opt_step_j_future; eauto. i.
      exploit PFtoRAThread.opt_step_ra_future; try exact x6; eauto; ss. i.
      exploit PFtoRAThread.opt_step_ra_future; try exact x7; eauto; ss. i.
      exploit PFtoRAThread.sim_thread_reserve_steps; eauto.
      { exploit PFtoRAThread.reserve_steps_pf_future; eauto. s. i.
        destruct (classic (ThreadEvent.get_machine_event e_pf = MachineEvent.failure)).
        - hexploit rtc_reserve_step_promise_consistent2; eauto.
          inv STEP0; ss. inv STEP; inv STEP0; ss.
          inv LOCAL; ss; inv LOCAL0; ss.
        - hexploit consistent_promise_consistent;
            try eapply PF.pf_consistent_consistent; eauto; try apply x12.
      }
      i. des.
      exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
      exploit PFtoRAThread.reserve_steps_j_future; eauto. i.
      exploit PFtoRAThread.reserve_steps_ra_future; try exact x10; eauto. i.
      exploit PFtoRAThread.reserve_steps_ra_future; try exact x11; eauto. i.
      assert (STEPS': WThread.steps L Ordering.acqrel Ordering.acqrel
                                    rels1 rels2 (Thread.mk _ st_ra lc_ra sc_ra mem_ra) e2_ra1).
      { exploit WThread.tau_steps_steps;
          try eapply WThread.cancel_steps_tau_steps; try exact STEP_RA. i.
        exploit WThread.opt_step_steps; eauto. i.
        exploit WThread.tau_steps_steps;
          try eapply WThread.reserve_steps_tau_steps; try exact STEP_RA1. i.
        eapply WThread.steps_trans; eauto.
        eapply WThread.steps_trans; eauto.
      }

      destruct (classic (ThreadEvent.get_machine_event e_pf = MachineEvent.failure)).
      { destruct e2_j1 as [st4_j lc4_j sc4_j mem4_j],
                 e2_apf1 as [st4_apf lc4_apf sc4_apf mem4_apf],
                 e2_ra1 as [st4_ra lc4_ra sc4_ra mem4_ra].
        left. esplits.
        - econs; eauto. inv EVENT_J; ss.
        - econs; eauto. inv EVENT_J; inv EVENT_APF; ss.
        - econs; eauto. inv EVENT_J; inv EVENT_APF; inv EVENT_RA; ss.
        - ss.
        - ss.
        - ss.
        - econs; ss. i.
          repeat rewrite IdentMap.gsspec. condtac; ss.
          specialize (THS tid0). unfold option_rel4 in THS. des_ifs. inv THS. ss.
          inv SIM4. ss. econs. econs; s; eauto; try apply SIM3.
          * inv SIM_JOINED.
            apply inj_pair2 in H3, H7. subst.
            econs; s; eauto; try by (inv SIM3; inv SIM_JOINED; ss).
            exploit JThread.rtc_cancel_step_future; eauto; try apply x1. s. i. des.
            exploit JThread.opt_step_future; eauto; try apply x1. s. i. des.
            exploit JThread.rtc_reserve_step_future; eauto. s. i. des.
            eapply JSim.sim_local_le; try exact LOCAL.
            etrans; eauto. refl.
          * inv SIM_APF. ss. subst.
            econs; s; eauto; try by (inv SIM3; inv SIM_APF; ss).
          * inv SIM_RA. ss. subst.
            econs; s; eauto; try by (inv SIM3; inv SIM_RA; ss).
          * econs; try apply SIM3; try apply NORMAL_APF.
          * econs; try apply SIM3; try apply NORMAL_RA.
          * econs; s; try apply SIM3; try apply STABLE_RA.
            exploit WThread.steps_future; try exact STEPS'; try apply x3. s. i. des.
            exploit wf_ra_thread; try exact WF1_RA; try eapply Heq6. s. i.
            exploit Stable.future_stable_tview; try eapply STABLE_RA; try apply x16; eauto.
      }

      exploit PFtoRAThread.sim_thread_consistent; try eapply CONSISTENT; eauto. i. des; cycle 1.
      { right. unfold RARaceW.ra_race_steps.
        esplits; [econs 1|..]; try eapply RACE; eauto. s.
        eapply WThread.steps_trans; eauto.
        eapply WThread.tau_steps_steps; eauto.
      }
      destruct e2_j1 as [st4_j lc4_j sc4_j mem4_j],
               e2_apf1 as [st4_apf lc4_apf sc4_apf mem4_apf],
               e2_ra1 as [st4_ra lc4_ra sc4_ra mem4_ra].
      left. esplits.
      - econs; eauto.
      - econs; eauto.
      - econs; eauto.
      - ss.
      - ss.
      - ss.
      - econs; ss. i.
        repeat rewrite IdentMap.gsspec. condtac; ss.
        specialize (THS tid0). unfold option_rel4 in THS. des_ifs. inv THS. ss.
        inv SIM4. ss. econs. econs; s; eauto; try apply SIM3.
        * inv SIM_JOINED.
          apply inj_pair2 in H3, H7. subst.
          econs; s; eauto; try by (inv SIM3; inv SIM_JOINED; ss).
          exploit JThread.rtc_cancel_step_future; eauto; try apply x1. s. i. des.
          exploit JThread.opt_step_future; eauto; try apply x1. s. i. des.
          exploit JThread.rtc_reserve_step_future; eauto. s. i. des.
          eapply JSim.sim_local_le; try exact LOCAL.
          etrans; eauto. refl.
        * inv SIM_APF. ss. subst.
          econs; s; eauto; try by (inv SIM3; inv SIM_APF; ss).
        * inv SIM_RA. ss. subst.
          econs; s; eauto; try by (inv SIM3; inv SIM_RA; ss).
        * econs; try apply SIM3; try apply NORMAL_APF.
        * econs; try apply SIM3; try apply NORMAL_RA.
        * econs; s; try apply SIM3; try apply STABLE_RA.
          exploit WThread.steps_future; try exact STEPS'; try apply x3. s. i. des.
          exploit wf_ra_thread; try exact WF1_RA; try eapply Heq6. s. i.
          exploit Stable.future_stable_tview; try eapply STABLE_RA; try apply x16; eauto.
    Qed.

    Lemma sim_conf_steps
          views1 rels1 c1_pf c1_j c1_apf c1_ra
          c2_pf
          (SIM1: sim_conf views1 rels1 c1_pf c1_j c1_apf c1_ra)
          (WF1_PF: wf_pf c1_pf)
          (WF1_J: wf_j views1 c1_j)
          (WF1_APF: wf_ra rels1 c1_apf)
          (WF1_RA: wf_ra rels1 c1_ra)
          (STEPS: rtc (PFConfiguration.all_step L) c1_pf c2_pf):
      (exists c2_j c2_apf views2 rels2 c2_ra,
          (<<STEPS_J: JConfiguration.single_steps c1_j c2_j views1 views2>>) /\
          (<<STEPS_APF: WConfiguration.steps L Ordering.na Ordering.plain rels1 rels2 c1_apf c2_apf>>) /\
          (<<STEPS_RA: WConfiguration.steps L Ordering.acqrel Ordering.acqrel rels1 rels2 c1_ra c2_ra>>) /\
          (<<SIM2: sim_conf views2 rels2 c2_pf c2_j c2_apf c2_ra>>)) \/
      (<<RACE: RARaceW.ra_race_steps L Ordering.acqrel Ordering.acqrel rels1 c1_ra>>).
    Proof.
      revert views1 rels1 c1_j c1_apf c1_ra SIM1 WF1_PF WF1_J WF1_APF WF1_RA.
      induction STEPS; i.
      { left. esplits; try by econs 1. ss. }
      inv H. exploit sim_conf_step; eauto. i. des; eauto.
      exploit step_pf_future; eauto. i. des.
      exploit step_j_future; eauto. i. des.
      exploit step_ra_future; try exact STEP_APF; eauto. i. des.
      exploit step_ra_future; try exact STEP_RA; eauto. i. des.
      exploit IHSTEPS; eauto. i. des.
      - left. esplits; (try by econs 2; eauto); ss.
      - right. unfold RARaceW.ra_race_steps in *. des.
        esplits; [econs 2; eauto|..]; eauto.
    Qed.

    (* racefree *)
    Lemma sim_conf_racy_read
          views1 rels1 c1_pf c1_j c1_apf c1_ra
          loc ts e_pf tid c2_pf ts_aux
          (SIM1: sim_conf views1 rels1 c1_pf c1_j c1_apf c1_ra)
          (WF1_PF: wf_pf c1_pf)
          (WF1_J: wf_j views1 c1_j)
          (WF1_APF: wf_ra rels1 c1_apf)
          (WF1_RA: wf_ra rels1 c1_ra)
          (STEP: PFRace.racy_read_step L loc ts e_pf tid c1_pf c2_pf)
          (LOC: L loc)
          (TSAUX: Time.le ts ts_aux)
          (RELS: exists ord, List.In (loc, ts_aux, ord) rels1 /\ Ordering.le ord Ordering.strong_relaxed):
      (<<RACE: RARaceW.ra_race_steps L Ordering.acqrel Ordering.acqrel rels1 c1_ra>>).
    Proof.
      inv STEP. inv SIM1. ss.
      specialize (THS tid). unfold option_rel4 in THS. des_ifs.
      inv THS. apply inj_pair2 in H1. subst.
      exploit wf_pf_thread; eauto. s. i.
      exploit wf_j_thread; eauto. s. i.
      exploit wf_ra_thread; try exact WF1_APF; eauto. s. i.
      exploit wf_ra_thread; try exact WF1_RA; eauto. s. i.
      exploit PFtoRAThread.sim_thread_cancel_steps; eauto.
      { destruct (classic (ThreadEvent.get_machine_event e_pf = MachineEvent.failure)).
        - inv STEP0; ss. inv STEP; inv STEP0; ss. inv LOCAL; ss; inv LOCAL0; ss.
        - exploit PFtoRAThread.cancel_steps_pf_future; eauto. i.
          exploit PFtoRAThread.opt_step_pf_future; eauto. i.
          exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
          eapply opt_step_promise_consistent; eauto; try eapply x4.
          eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent; try eapply PF.pf_consistent_consistent;
            try eapply CONSISTENT; try eapply x6; eauto.
      }
      i. des.
      exploit PFtoRAThread.cancel_steps_pf_future; try eapply x0; eauto. i.
      exploit PFtoRAThread.cancel_steps_j_future; try eapply x1; eauto. i.
      exploit PFtoRAThread.cancel_steps_ra_future; try eapply x2; eauto. i.
      exploit PFtoRAThread.cancel_steps_ra_future; try eapply x3; eauto. i.
      exploit PFtoRAThread.sim_thread_opt_step; eauto.
      { destruct (classic (ThreadEvent.get_machine_event e_pf = MachineEvent.failure)).
        - inv STEP0; ss. inv STEP; inv STEP0; ss. inv LOCAL; ss; inv LOCAL0; ss.
        - exploit PFtoRAThread.opt_step_pf_future; eauto. i.
          exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
          eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent; try eapply PF.pf_consistent_consistent;
            try eapply CONSISTENT; try eapply x9; eauto.
      }
      i. unfold RARaceW.ra_race_steps. des; cycle 1.
      { esplits; [econs 1|..]; eauto. s.
        eapply WThread.tau_steps_steps; eapply WThread.cancel_steps_tau_steps; eauto.
      }
      hexploit PFtoAPFSim.sim_thread_promise_consistent; try eapply SIM2; i.
      { inv SIM2. inv SIM_JOINED.
        apply inj_pair2 in H2, H3. subst. ss.
        eapply JSim.sim_local_promise_consistent; eauto.
        exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
        destruct (classic (ThreadEvent.get_machine_event e_pf = MachineEvent.failure)).
        - inv STEP0; ss. inv STEP; inv STEP0; ss. inv LOCAL0; ss; inv LOCAL1; ss.
        - exploit PFtoRAThread.opt_step_pf_future; eauto. i. des.
          exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
          hexploit consistent_promise_consistent; try eapply PF.pf_consistent_consistent;
            try eapply CONSISTENT; try eapply x10; eauto. s. i.
          hexploit rtc_reserve_step_promise_consistent; try exact H1; eauto. i.
          hexploit opt_step_promise_consistent; try eapply x8; eauto.
      }
      hexploit APFtoRASim.sim_local_promise_consistent; try eapply SIM2; eauto. i.
      inv READ; inv EVENT_J; inv EVENT_APF; inv EVENT_RA; ss.
      - inv STEP_RA0. inv STEP; ss. inv STEP1; inv STEP; ss. inv LOCAL; ss.
        esplits; [econs 1|..].
        + eauto.
        + eapply WThread.tau_steps_steps; eapply WThread.cancel_steps_tau_steps; eauto.
        + ss.
        + eauto.
        + unfold RARaceW.ra_race.
          left. esplits; eauto; ss.
          inv SIM2. inv SIM_JOINED. inv SIM_APF. inv SIM_RA. ss.
          apply inj_pair2 in H4, H5. subst. ss.
          unfold RARaceW.wr_race.
          inv LOCAL2. inv TVIEW. rewrite CUR.
          esplits; eauto.
          eapply TimeFacts.lt_le_lt; [|eapply TSAUX].
          eapply TimeFacts.le_lt_lt; eauto. condtac.
          * inv LOCAL. inv TVIEW. inv CUR0. apply RLX.
          * inv LOCAL. inv TVIEW. inv CUR0.
            inv NORMAL_APF. inv NORMAL_TVIEW. ss.
            destruct e2_apf; ss. subst. ss.
            rewrite CUR0; ss.
      - inv STEP_RA0. inv STEP; ss. inv STEP1; inv STEP; ss. inv LOCAL; ss.
        esplits; [econs 1|..].
        + eauto.
        + eapply WThread.tau_steps_steps; eapply WThread.cancel_steps_tau_steps; eauto.
        + ss.
        + eauto.
        + unfold RARaceW.ra_race.
          left. esplits; eauto; ss.
          inv SIM2. inv SIM_JOINED. inv SIM_APF. inv SIM_RA. ss.
          apply inj_pair2 in H4, H5. subst. ss.
          unfold RARaceW.wr_race.
          inv LOCAL3. inv TVIEW. rewrite CUR.
          esplits; eauto.
          eapply TimeFacts.lt_le_lt; [|eapply TSAUX].
          eapply TimeFacts.le_lt_lt; eauto. condtac.
          * inv LOCAL. inv TVIEW. inv CUR0. apply RLX.
          * inv LOCAL. inv TVIEW. inv CUR0.
            inv NORMAL_APF. inv NORMAL_TVIEW. ss.
            destruct e2_apf; ss. subst. ss.
            rewrite CUR0; ss.
      - inv STEP_RA0. inv STEP; ss. inv STEP1; inv STEP; ss. inv LOCAL; ss.
        esplits; [econs 1|..].
        + eauto.
        + eapply WThread.tau_steps_steps; eapply WThread.cancel_steps_tau_steps; eauto.
        + ss.
        + eauto.
        + unfold RARaceW.ra_race.
          left. esplits; eauto; ss.
          inv SIM2. inv SIM_JOINED. inv SIM_APF. inv SIM_RA. ss.
          apply inj_pair2 in H4, H5. subst. ss.
          unfold RARaceW.wr_race.
          inv LOCAL2. inv TVIEW. rewrite CUR.
          esplits; eauto. inv LOCAL0. inv STEP. inv RACE.
          unfold TView.racy_view in RACE0.
          eapply TimeFacts.lt_le_lt; [|eapply TSAUX].
          eapply TimeFacts.le_lt_lt; eauto.
          * inv LOCAL. inv TVIEW. inv CUR0.
            inv NORMAL_APF. inv NORMAL_TVIEW. ss.
            destruct e2_apf; ss. subst. ss.
            rewrite CUR0; ss. rewrite CUR. refl.
    Qed.

    Lemma memory_write_na_time_max ts prom0 mem0 loc from to val prom1 mem1 msgs kinds kind
          (WRITE: Memory.write_na ts prom0 mem0 loc from to val prom1 mem1 msgs kinds kind)
      :
        List.Forall (fun '(_, to0, _) => Time.lt to0 to) msgs.
    Proof.
      induction WRITE; eauto. econs; eauto. eapply Memory.write_na_times; eauto.
    Qed.

    Lemma sim_conf_racefree
          views rels c_pf c_j c_apf c_ra
          (SIM: sim_conf views rels c_pf c_j c_apf c_ra)
          (WF_PF: wf_pf c_pf)
          (WF_J: wf_j views c_j)
          (WF_APF: wf_ra rels c_apf)
          (WF_RA: wf_ra rels c_ra)
          (RA_RACEFREE: RARaceW.racefree L Ordering.acqrel Ordering.acqrel rels c_ra):
      PFRace.racefree_view L c_pf.
    Proof.
      ii. exploit sim_conf_steps; eauto. i. des; cycle 1.
      { unfold RARaceW.ra_race_steps in *. des. eauto. }
      exploit steps_pf_future; eauto. i. des.
      exploit steps_j_future; eauto. i. des.
      exploit steps_ra_future; try exact WF_APF; eauto; ss. i. des.
      exploit steps_ra_future; try exact WF_RA; eauto; ss. i. des.
      inv WRITE.
      exploit sim_conf_step; try exact STEP; eauto. i. des; cycle 1.
      { unfold RARaceW.ra_race_steps in *. des.
        eapply RA_RACEFREE; cycle 1; eauto.
        eapply WConfiguration.steps_trans; eauto.
      }
      assert (WRITE_RA: exists ts_aux ord, List.In (loc, ts_aux, ord) rels0 /\ Ordering.le ord Ordering.strong_relaxed /\ (<<WRITE: PFRace.writing_event loc ts_aux e0>>) /\ (<<TSAUX: Time.le ts ts_aux>>)).
      { inv WRITE0; inv EVENT_J; inv EVENT_APF; inv EVENT_RA; ss.
        - inv STEP_APF. ss. inv STEP0; ss. inv STEP1.
          unfold Writes.append. ss. condtac; ss.
          esplits; [left|..]; eauto.
          { econs; eauto. }
          { refl. }
        - inv STEP_APF. ss. inv STEP0; ss. inv STEP1.
          unfold Writes.append. ss. condtac; ss.
          esplits; [left|..]; eauto.
          { econs; eauto. }
          { refl. }
        - inv STEP_APF. ss. inv STEP0; ss. inv STEP1.
          unfold Writes.append. ss. condtac; ss. esplits; eauto.
          { econs; eauto. }
          { inv STEP. inv STEP1. inv STEP; inv STEP1. inv LOCAL.
            inv LOCAL0. des.
            { subst. refl. }
            { eapply memory_write_na_time_max in WRITE; eauto.
              eapply List.Forall_forall in IN0; eauto. ss. left. auto.
            }
          }
      }
      exploit step_pf_future; try exact STEP; eauto. i. des.
      exploit step_j_future; try exact STEP_J; eauto. i. des.
      exploit step_ra_future; try exact STEP_APF; eauto. i. des.
      exploit step_ra_future; try exact STEP_RA; eauto. i. des.
      exploit sim_conf_steps; try exact CSTEPS2; eauto. i. des; cycle 1.
      { unfold RARaceW.ra_race_steps in *. des.
        eapply RA_RACEFREE; cycle 1; eauto.
        eapply WConfiguration.steps_trans; [eauto|].
        econs 2; eauto.
      }
      exploit steps_pf_future; try exact CSTEPS2; eauto. i. des.
      exploit steps_j_future; try exact STEPS_J0; eauto. i. des.
      exploit steps_ra_future; try exact STEPS_APF0; eauto. i. des.
      exploit steps_ra_future; try exact STEPS_RA0; eauto. i. des.
      assert (READ_RA: exists ord, List.In (loc, ts_aux, ord) rels1 /\ Ordering.le ord Ordering.strong_relaxed).
      { exploit WConfiguration.steps_rels_incl; try exact STEPS_APF0. i. des. subst.
        esplits.
        - apply List.in_or_app. right. eauto.
        - ss.
      }
      exploit sim_conf_racy_read; eauto. unfold RARaceW.ra_race_steps. i. des.
      eapply RA_RACEFREE; cycle 1; eauto.
      eapply WConfiguration.steps_trans; eauto.
      eapply WConfiguration.steps_trans; eauto.
      econs 2; eauto.
    Qed.

    (* behaviors *)

    Lemma sim_conf_behavior
          views rels c_pf c_j c_apf c_ra
          (SIM: sim_conf views rels c_pf c_j c_apf c_ra)
          (WF_PF: wf_pf c_pf)
          (WF_J: wf_j views c_j)
          (WF_APF: wf_ra rels c_apf)
          (WF_RA: wf_ra rels c_ra)
          (RACEFREE: RARaceW.racefree L Ordering.acqrel Ordering.acqrel rels c_ra):
      behaviors (PFConfiguration.machine_step L) c_pf <2=
      behaviors (@OrdConfiguration.machine_step L Ordering.acqrel Ordering.acqrel) c_ra.
    Proof.
      i. revert views rels c_j c_apf c_ra SIM WF_PF WF_J WF_APF WF_RA RACEFREE.
      induction PR; i.
      - econs 1. eapply sim_conf_terminal; eauto.
      - inv STEP. exploit sim_conf_step; eauto. i. des.
        + exploit WConfiguration.step_ord_step; eauto. i.
          inv EVENT_J; inv EVENT_APF; inv EVENT_RA; ss. inv H0.
          econs 2.
          { replace (MachineEvent.syscall e2) with
                (ThreadEvent.get_machine_event (ThreadEvent.syscall e2)) by ss.
            econs; eauto.
          }
          hexploit RARaceW.step_racefree; eauto. i.
          exploit step_pf_future; eauto. i. des.
          exploit step_j_future; eauto. i. des.
          exploit step_ra_future; try exact STEP_APF; eauto. i. des.
          exploit step_ra_future; try exact STEP_RA; eauto. ss.
        + exfalso. unfold RARaceW.ra_race_steps in *. des. eauto.
      - inv STEP. exploit sim_conf_step; eauto. i. des.
        + exploit WConfiguration.step_ord_step; eauto. i.
          econs 3.
          replace MachineEvent.failure with (ThreadEvent.get_machine_event e_ra); [econs; eauto|].
          inv EVENT_J; inv EVENT_APF; inv EVENT_RA; ss.
        + exfalso. unfold RARaceW.ra_race_steps in *. des. eauto.
      - inv STEP. exploit sim_conf_step; eauto. i. des.
        + exploit WConfiguration.step_ord_step; eauto. i.
          econs 4.
          { replace MachineEvent.silent with (ThreadEvent.get_machine_event e_ra); cycle 1.
            { inv EVENT_J; inv EVENT_APF; inv EVENT_RA; ss. }
            econs; eauto.
          }
          hexploit RARaceW.step_racefree; eauto. i.
          exploit step_pf_future; eauto. i. des.
          exploit step_j_future; eauto. i. des.
          exploit step_ra_future; try exact STEP_APF; eauto. i. des.
          exploit step_ra_future; try exact STEP_RA; eauto.
        + exfalso. unfold RARaceW.ra_race_steps in *. des. eauto.
      - econs 5.
    Qed.
  End PFtoRA.
End PFtoRA.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime Eprimeprime A B C Bprime Bprimeprime : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ O Eprimeprime /\ (wd_ E Eprimeprime /\ (wd_ B E /\ (wd_ A E /\ (wd_ Bprime O /\ (wd_ Eprime Eprimeprime /\ (wd_ Bprime Bprimeprime /\ (wd_ Bprime Eprime /\ (wd_ Eprimeprime A /\ (wd_ Eprime A /\ (wd_ Eprime Bprimeprime /\ (wd_ Eprimeprime Bprime /\ (wd_ Eprimeprime Bprimeprime /\ (wd_ Eprime C /\ (wd_ A Bprime /\ (wd_ A C /\ (wd_ Bprime C /\ (wd_ E Bprime /\ (wd_ Eprime B /\ (wd_ B Bprime /\ (wd_ B Bprimeprime /\ (wd_ B Eprimeprime /\ (wd_ Bprimeprime E /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ (col_ O Eprimeprime Bprimeprime /\ col_ E Eprime Eprimeprime)))))))))))))))))))))))))))))))))) -> col_ O A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import List.
Require Import ZArith.

Require Import Utils.
Require Import Lattices.
Require Import CLattices.
Require Import Instr.
Require Import AbstractCommon.
Require Import AbstractMachine.
Require Import NIAbstractMachine.
Require Import Concrete.
Require Import ConcreteMachine.
Require Import ConcreteExecutions.
Require Import Semantics.
Require Import Refinement.
Require Import RefinementAC.
Require Import Encodable.
Require TINI.

(** The concrete machine enjoys TINI. *)

Open Scope Z_scope.

Set Implicit Arguments.

Section NI.

Context {observer: Type}
        {Latt: JoinSemiLattice observer}
        {CLatt: ConcreteLattice observer}
        {ELatt : Encodable observer}
        {WFCLatt: WfConcreteLattice observer Latt CLatt ELatt}.

Inductive concrete_i_equiv (o : observer) :
  init_data tini_concrete_machine -> init_data tini_concrete_machine -> Prop :=
  | ci_equiv : forall p n l s1 s2,
                 low_equiv_list (low_equiv_atom o) s1 s2 ->
                 concrete_i_equiv o
                   (p, (mem_labToZ s1), n, (labToZ l))
                   (p, (mem_labToZ s2), n, (labToZ l)).

Definition abstract_event' {L} (CLatt : ConcreteLattice L) (ce : CEvent) :=
  match ce with
    | CEInt ca => EInt (atom_ZToLab ca)
  end.

Instance CMObservation : TINI.Observation tini_concrete_machine := {
  e_low := fun o e => TINI.e_low o (abstract_event' _ e);
  e_low_dec := fun o e => TINI.e_low_dec o (abstract_event' _ e);
  i_equiv := concrete_i_equiv
}.

Lemma ac_low_compatible :
  forall o e1 e2,
    ref_match_events abstract_concrete_ref e1 e2 ->
    (TINI.e_low o e1 <-> TINI.e_low (S:=tini_concrete_machine) o e2).
Proof.
  simpl.
  intros o [a1] [a2] H; simpl.
  inv H.
  rewrite <- atom_ZToLab_labToZ_id.
  intuition.
Qed.

Lemma concrete_equiv_abstract_equiv :
  forall o ci1 ci2,
    concrete_i_equiv o ci1 ci2 ->
    exists ai1 ai2,
      abstract_i_equiv o ai1 ai2 /\
      ac_match_initial_data ai1 ci1 /\
      ac_match_initial_data ai2 ci2.
Proof.
  intros o [[[p1 d1] n1] z1] [[[p2 d2] n2] z2] H.
  inv H.
  exists (p2,s1,n2,l).
  exists (p2,s2,n2,l).
  repeat split; simpl; eauto.
Qed.

Lemma ac_match_events_equiv : forall o e11 e12 e21 e22,
                                @TINI.a_equiv abstract_machine _ o (E e11) (E e12) ->
                                ref_match_events abstract_concrete_ref e11 e21 ->
                                ref_match_events abstract_concrete_ref e12 e22 ->
                                @TINI.a_equiv tini_concrete_machine _ o (E e21) (E e22).
Proof.
  unfold match_events.
  intros.
  destruct e11; destruct e12; simpl in *.
  subst.
  inv H; constructor; simpl in *.
  generalize (abstract_action_concretize_action (E (EInt a))); simpl; congruence.
  generalize (abstract_action_concretize_action (E (EInt a0))); simpl; congruence.
Qed.

Lemma ac_tini_preservation_premises :
  tini_preservation_hypothesis abstract_concrete_ref.
Proof.
  intros o. exists o.
  split. { apply ac_low_compatible. }
  split. { apply concrete_equiv_abstract_equiv. }
  apply ac_match_events_equiv.
Qed.

Lemma concrete_noninterference :
  TINI.tini CMObservation.
Proof.
   exact (@refinement_preserves_noninterference
          abstract_machine tini_concrete_machine
          _ _
          abstract_concrete_ref
          abstract_noninterference
          ac_tini_preservation_premises).
Qed.

End NI.


From fae_gtlc_mu.refinements.static_gradual Require Export compat_cast.defs.
From fae_gtlc_mu.cast_calculus Require Export lang.

Section compat_cast_sum_sum.
  Context `{!implG Σ,!specG Σ}.

  Local Hint Resolve to_of_val : core.

  (** The case `throughSum` in our proof by induction on the alternative consistency relation. *)
  Lemma back_cast_ar_sum_sum:
    ∀ (A : list (type * type)) (τ1 τ1' τ2 τ2' : type) (pC1 : alternative_consistency A τ1 τ1') (pC2 : alternative_consistency A τ2 τ2')
      (IHpC1 : back_cast_ar pC1) (IHpC2 : back_cast_ar pC2),
      back_cast_ar (throughSum A τ1 τ1' τ2 τ2' pC1 pC2).
  Proof.
    intros A τ1 τ1' τ2 τ2' pC1 pC2 IHpC1 IHpC2.
    rewrite /back_cast_ar. iIntros (ei' K' v v' fs) "(#Hfs & #Hvv' & #Hei' & Hv')".
    (* get small lemma length fs *)
    iDestruct "Hfs" as "[% Hfs']"; iAssert (rel_cast_functions A fs) with "[Hfs']" as "Hfs". iSplit; done. iClear "Hfs'".
    rewrite /𝓕c /𝓕. fold (𝓕 pC1) (𝓕 pC2). rewrite between_TSum_subst_rewrite.
    (* step wp *)
    wp_head.
    asimpl.
    (* rewrite with what we know in Hvv' *)
    rewrite interp_rw_TSum.
    iDestruct "Hvv'" as "[H1 | H2]".
    + iDestruct "H1" as ((v1 , v1')) "[% Hv1v1']". inversion H0. clear H0 H2 H3 v v'.
      (* step in gradual side *)
      iMod (step_pure _ ei' K' _ (InjL (Cast v1' τ1 τ1')) with "[Hv']") as "Hv'". eapply SumCast1. eauto. eauto. eauto.
      (* step in wp *)
      wp_head. asimpl. fold (stlc_mu.lang.of_val v1).
      (* apply first IH *)
      iApply (wp_bind (stlc_mu.lang.fill_item stlc_mu.lang.InjLCtx)).
      iApply (wp_wand with "[-]").
      iApply (IHpC1 ei' (InjLCtx :: K') with "[Hv']").
      eauto.
      (* finish *)
      iIntros (v1f) "HHH". iDestruct "HHH" as (v1f') "[Hv1f' Hv1fv1f']".
      iApply wp_value.
      iExists (InjLV v1f').
      iSplitL "Hv1f'". done.
      rewrite interp_rw_TSum.
      iLeft. iExists (v1f , v1f'). by iFrame.
    + iDestruct "H2" as ((v2 , v2')) "[% Hv2v2']". inversion H0. clear H0 H2 H3 v v'.
      (* step in gradual side *)
      iMod (step_pure _ ei' K' _ (InjR (Cast v2' τ2 τ2')) with "[Hv']") as "Hv'". by eapply SumCast2; eauto. eauto. eauto.
      (* apply first IH *)
      wp_head. asimpl. fold (stlc_mu.lang.of_val v2).
      (* apply first IH *)
      iApply (wp_bind (stlc_mu.lang.fill_item stlc_mu.lang.InjRCtx)).
      iApply (wp_wand with "[-]").
      iApply (IHpC2 ei' (InjRCtx :: K') with "[Hv']").
      eauto.
      (* finish *)
      iIntros (v1f) "HHH". iDestruct "HHH" as (v1f') "[Hv1f' Hv1fv1f']".
      iApply wp_value.
      iExists (InjRV v1f').
      iSplitL "Hv1f'". done.
      rewrite interp_rw_TSum.
      iRight. iExists (v1f , v1f'). eauto.
  Qed.

End compat_cast_sum_sum.


Require Import GHC.Base.
Require Import Fix.
Require Import Fix.WFFunctor.
Require Import ProofAlgebra.ProofAlgebra.

Require Import Adverb.Composable.Purely.
Require Import Adverb.Composable.Streamingly.
Require Import Adverb.Composable.Statically.
Require Import Adverb.Composable.Dynamically.

(** * Proof Algebras *)

Section ProofAlgebras.

  Variable F : (Set -> Set) -> Set -> Set.
  Variable P : forall (A : Set), Fix1 F A -> Prop.
  Context `{Functor1 F}.

  (** * Functor *)

  Section FunctorT.

    Context `{StreaminglyAdv -≪ F}.
    Context `{@WFFunctor1 StreaminglyAdv F Functor1__StreaminglyAdv _ _}.

    Variable Hm : forall (A B : Set) (g : A -> B) f, P _ f -> P _ (fmap g f).

    Definition p_alg1_StreaminglyAdv : Alg1 StreaminglyAdv (fun T => sig (P T)).
      intros ? t. destruct t.
      destruct f as [f ?]. exists (fmap g f). auto.
    Defined.

    Program Instance FunctorT_ProofAlgebra
      : ProofAlg1 StreaminglyAdv P :=
      {| p_alg1 := p_alg1_StreaminglyAdv |}.
    Next Obligation.
      destruct e. destruct f as [f ?].
      cbn. reflexivity.
    Defined.

  End FunctorT.

  Context `{PurelyAdv -≪ F}.
  Context `{@WFFunctor1 PurelyAdv F Functor1__PurelyAdv _ _}.

  Variable Hp : forall (A : Set) (a : A), P _ (@inF1 _ _ _ (inj1 (Pure a))).

  Definition p_alg1_PurelyAdv : Alg1 PurelyAdv (fun T => sig (P T)).
    intros ? t. destruct t.
    exists (@inF1 _ _ _ (inj1 (Pure r))).
    apply Hp.
  Defined.

  Program Instance Pure_ProofAlgebra
    : ProofAlg1 PurelyAdv P :=
    {| p_alg1 := p_alg1_PurelyAdv |}.
  Next Obligation.
    destruct e. cbn. reflexivity.
  Defined.

  Section ApT.

    Context `{StaticallyAdv -≪ F}.
    Context `{@WFFunctor1 StaticallyAdv F Functor1__StaticallyAdv _ _}.

    (* Variable Hp : forall (A : Set) (a : A), P _ (pure a). *)
    Variable Ha : forall (A B C : Set) (f : A -> B -> C) (a : Fix1 F A) (b : Fix1 F B),
        P _ a -> P _ b -> P _ (liftA2 f a b).

    Definition p_alg1_StaticallyAdv : Alg1 StaticallyAdv (fun T => sig (P T)).
      intros ? t. destruct t.
      destruct g as [g ?]. destruct a as [a ?].
      exists (liftA2 f g a). apply Ha; eauto.
    Defined.

    Program Instance ApT_ProofAlgebra
      : ProofAlg1 StaticallyAdv P :=
      {| p_alg1 := p_alg1_StaticallyAdv |}.
    Next Obligation.
      destruct e.
      destruct g as [g ?]. destruct a as [a ?].
      cbn. reflexivity.
    Defined.
  End ApT.

  Section MonadT.

    Context `{DynamicallyAdv -≪ F}.
    Context `{@WFFunctor1 DynamicallyAdv F Functor1__DynamicallyAdv _ _}.

    Variable Hb : forall (A B : Set) (g : A -> Fix1 F B) m,
        P _ m -> (forall a, P _ (g a)) -> P _ (m >>= g).

    Definition p_alg1_DynamicallyAdv : Alg1 DynamicallyAdv (fun T => sig (P T)).
      intros ? t. destruct t.
      destruct m as [m ?].
      pose (@proj1_sig _ _ ∘ g) as k.
      exists (m >>= k). apply Hb; eauto.
      intros. unfold k, "∘". apply proj2_sig.
    Defined.

    Program Instance MonadT_ProofAlgebra
      : ProofAlg1 DynamicallyAdv P :=
      {| p_alg1 := p_alg1_DynamicallyAdv |}.
    Next Obligation.
      destruct e.
      destruct m as [m ?]. cbn. reflexivity.
    Defined.
  End MonadT.

End ProofAlgebras.


Require Import VST.msl.Extensionality.
Require Import VST.msl.sepalg.
Require Import RamifyCoq.msl_ext.abs_addr.
Require Import RamifyCoq.msl_ext.ramify_tactics.

Set Implicit Arguments.

Lemma join_identity{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
  forall a b c, join a b c -> identity a -> identity b -> identity c.
Proof.
  intros.
  hnf; intros x y ?.
  try_join b x bx.
  apply H1 in H3.
  apply H0 in H4.
  subst; auto.
Qed.

(*

Class Mem_alg (AV: AbsAddr) (A: Type) {J: Join A} {SA: Sep_alg A} := mkMem_alg {
  exact_mem: A -> Addr -> Val -> Prop;
  joins_no_conflict: forall {a1 a2 p1 p2 v1 v2},
     exact_mem a1 p1 v1 -> exact_mem a2 p2 v2 -> joins a1 a2 -> addr_conflict p1 p2 = true -> False;
  addr_uniq: forall a p1 p2 v1 v2, exact_mem a p1 v1 -> exact_mem a p2 v2 -> p1 = p2;
  mem_uniq: forall a1 a2 a p v1 v2, exact_mem a1 p v1 -> exact_mem a2 p v2 -> join_sub a1 a -> join_sub a2 a -> join a a a
}.

Implicit Arguments Mem_alg [[J][SA]].
Implicit Arguments mkMem_alg [[AV] [A] [J] [SA]].

Lemma exact_mem_non_unit: forall (AV: AbsAddr) {ANE: AddrNonEmpty AV} (A: Type) {J: Join A} {SA: Sep_alg A} {MA: Mem_alg AV A} a p v, exact_mem a p v -> unit_for a a -> False.
Proof.
  intros.
  unfold unit_for in H0.
  assert (joins a a) by eauto.
  eapply joins_no_conflict; eauto.
Qed.

Lemma exact_mem_alignable: forall (AV: AbsAddr) {Al: Alignable AV} (A: Type) {J: Join A} {SA: Sep_alg A} {MA: Mem_alg AV A} a a1 a2 p v1 v2, exact_mem a1 p v1 -> exact_mem a2 p v2 -> join_sub a a1 -> join_sub a a2 -> unit_for a a1 /\ unit_for a a2.
Proof.
  intros.

*)


Require Import Lia Framework TotalMem CryptoDiskLayer.

  Fixpoint read_consecutive a count:=
    match count with
    | 0 => Ret nil
    | S count' =>
      v <- |DO| Read a;
      vl <- read_consecutive (S a) count';
    Ret (v::vl)
  end.

Fixpoint write_batch al vl :=
  match al, vl with
  | a::al', v::vl' =>
    _ <- |DO| Write a v;
    _ <- write_batch al' vl';
    Ret tt
  | _, _ => Ret tt
  end.

Definition write_consecutive a vl := write_batch (seq a (length vl)) vl.

Fixpoint encrypt_all k vl :=
  match vl with
  | nil => Ret nil
  | v::vl' =>
    ev <- |CO| Encrypt k v;
    evl' <- encrypt_all k vl';
    Ret (ev::evl')
  end.

Fixpoint decrypt_all k evl :=
  match evl with
  | nil => Ret nil
  | ev::evl' =>
    v <- |CO| Decrypt k ev;
    vl' <- decrypt_all k evl';
    Ret (v::vl')
  end.

Fixpoint hash_all h vl :=
  match vl with
  | nil => Ret h
  | v::vl' =>
    h' <- |CO| Hash h v;
    h'' <- hash_all h' vl';
    Ret h''
  end.

(** Specs **)

Theorem write_batch_finished:
  forall al vl o t s s' u,
    length al = length vl ->
    exec CryptoDiskLang u o s (write_batch al vl) (Finished s' t) ->
    (forall a, In a al -> a < disk_size) /\
    fst s' = fst s /\ snd s' = upd_batch_set (snd s) al vl.
Proof.
  induction al; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.
  intuition eauto.

  eapply IHal in H0; try lia; cleanup.
  simpl in *; cleanup.
  intuition eauto.
  subst; congruence.
Qed.

Theorem write_batch_crashed:
  forall al vl o s s' u,
    length al = length vl ->
    exec CryptoDiskLang u o s (write_batch al vl) (Crashed s') ->
    exists n,
      n <= length al /\
      (forall a, In a (firstn n al) -> a < disk_size) /\
      fst s' = fst s /\ snd s' = upd_batch_set (snd s) (firstn n al) (firstn n vl).
Proof.
  induction al; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.

  {
    exists 0; split; intuition eauto.
    simpl in *; intuition.
  }

  split_ors; cleanup; repeat invert_exec; simpl.
  {
    exists 0; split; intuition eauto; simpl in *.
    lia.
    intuition.
  }

  split_ors; cleanup; repeat invert_exec; simpl in *.
  {
    eapply IHal in H0; try lia.
    cleanup; simpl in *; cleanup.
    exists (S x); split; intuition eauto; simpl in *.
    lia.
    split_ors; cleanup; eauto.
  }
  {
    eapply write_batch_finished in H1; eauto; cleanup.
    simpl in *; cleanup.
    exists (S (length al)).
    simpl.
    repeat rewrite firstn_oob by lia.
    cleanup; split; intuition eauto; simpl in *.
    cleanup.
    eauto.
  }
Qed.

Import Mem.

Theorem decrypt_all_finished:
  forall key evl o s s' t u,
    exec CryptoDiskLang u o s (decrypt_all key evl) (Finished s' t) ->
    t = map (decrypt key) evl /\
    consistent_with_upds (snd (fst s)) evl (map (fun ev => (key, decrypt key ev)) evl) /\
    fst (fst s') = fst (fst s) /\
    snd (fst s') = upd_batch (snd (fst s)) evl (map (fun ev => (key, decrypt key ev)) evl) /\
    snd s' = snd s.
Proof.
  induction evl; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.
  edestruct IHevl; eauto; cleanup.
  eexists; intuition eauto.
  repeat cleanup_pairs; eauto.
Qed.

Theorem decrypt_all_crashed:
  forall key evl o s s' u,
    exec CryptoDiskLang u o s (decrypt_all key evl) (Crashed s') ->
    exists n,
      consistent_with_upds (snd (fst s)) (firstn n evl) (firstn n (map (fun ev => (key, decrypt key ev)) evl)) /\
      fst (fst s') = fst (fst s) /\
      snd (fst s') = upd_batch (snd (fst s)) (firstn n evl) (firstn n (map (fun ev => (key, decrypt key ev)) evl)) /\
    snd s' = snd s.
Proof.
  induction evl; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.
  exists 0; simpl; eauto.

  split_ors; cleanup; repeat invert_exec.
  exists 0; simpl; eauto.

  split_ors; cleanup; repeat invert_exec.
  {
    apply IHevl in H; cleanup.
    exists (S x); simpl; intuition eauto.
    repeat cleanup_pairs; eauto.
    destruct p; eauto.
  }
  {
    eapply decrypt_all_finished in H0; cleanup; eauto.
    exists (S (length evl)); simpl.
    repeat rewrite firstn_oob; try lia.
    intuition eauto.
    repeat cleanup_pairs; eauto.
    destruct p; eauto.
    rewrite map_length; eauto.
  }
Qed.

Theorem hash_all_finished:
  forall vl h o s t s' u,
    exec CryptoDiskLang u o s (hash_all h vl) (Finished s' t) ->
    t = rolling_hash h vl /\
    consistent_with_upds (snd (fst (fst s))) (rolling_hash_list h vl) (combine (h:: rolling_hash_list h vl) vl) /\
    (snd (fst (fst s'))) = upd_batch (snd (fst (fst s))) (rolling_hash_list h vl) (combine (h:: rolling_hash_list h vl) vl) /\
    fst (fst (fst s')) = fst (fst (fst s)) /\
    snd (fst s') = snd (fst s) /\
    snd s' = snd s.
Proof.
  induction vl; simpl; intros.
  repeat invert_exec; cleanup; intuition eauto.
  repeat invert_exec; cleanup.
  edestruct IHvl; eauto; cleanup.
  simpl in *; intuition eauto.
Qed.

Theorem hash_all_crashed:
  forall vl h o s s' u,
    exec CryptoDiskLang u o s (hash_all h vl) (Crashed s') ->
    exists n,
      n <= length (rolling_hash_list h vl) /\
    consistent_with_upds (snd (fst (fst s))) (firstn n (rolling_hash_list h vl)) (firstn n (combine (h:: rolling_hash_list h vl) vl)) /\
    (snd (fst (fst s'))) = upd_batch (snd (fst (fst s))) (firstn n (rolling_hash_list h vl)) (firstn n (combine (h:: rolling_hash_list h vl) vl)) /\
    fst (fst (fst s')) = fst (fst (fst s)) /\
    snd (fst s') = snd (fst s) /\
    snd s' = snd s.
Proof.
  induction vl; simpl; intros.
  repeat invert_exec; cleanup; simpl; eauto.
  exists 0; simpl; intuition eauto.

  repeat invert_exec; cleanup.
  repeat (split_ors; cleanup; repeat invert_exec; simpl; eauto).
  exists 0; simpl; intuition eauto.
  lia.

  edestruct IHvl; eauto; cleanup.
  simpl in *; repeat cleanup_pairs; eauto.
  exists (S x); simpl; intuition eauto.
  lia.

  eapply hash_all_finished in H0; cleanup; eauto;
  simpl in *; intuition eauto.
  repeat cleanup_pairs; eauto.
  exists (length (hash_function h a :: rolling_hash_list (hash_function h a) vl)).
  repeat rewrite firstn_oob;
  simpl; intuition eauto.

  generalize vl (hash_function h a).
  induction vl0; simpl; intros; eauto.
  destruct vl0; simpl in *; eauto.
  specialize (IHvl0 (hash_function h1 a0)); lia.
Qed.

Theorem encrypt_all_finished:
  forall key vl o s s' t u,
    exec CryptoDiskLang u o s (encrypt_all key vl) (Finished s' t) ->
    t = map (encrypt key) vl /\
    consistent_with_upds (snd (fst s)) (map (encrypt key) vl) (map (fun v => (key, v)) vl) /\
    fst (fst s') = fst (fst s) /\
    snd (fst s') = upd_batch (snd (fst s)) (map (encrypt key) vl) (map (fun v => (key, v)) vl) /\
    snd s' = snd s.
Proof.
  induction vl; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.

  - edestruct IHvl; eauto; cleanup.
    eexists; intuition eauto.
    repeat cleanup_pairs; eauto.
Qed.

Theorem encrypt_all_crashed:
  forall key vl o s s' u,
    exec CryptoDiskLang u o s (encrypt_all key vl) (Crashed s') ->
    exists n,
      consistent_with_upds (snd (fst s)) (firstn n (map (encrypt key) vl)) (firstn n (map (fun v => (key, v)) vl)) /\
      fst (fst s') = fst (fst s) /\
      snd (fst s') = upd_batch (snd (fst s)) (firstn n (map (encrypt key) vl)) (firstn n (map (fun v => (key, v)) vl)) /\
    snd s' = snd s.

Proof.
  induction vl; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.
  {
    exists 0; simpl; eauto.
  }

  split_ors; cleanup; repeat invert_exec.
  {
    exists 0; simpl; eauto.
  }
  split_ors; cleanup; repeat invert_exec.
  {
    eapply IHvl in H; eauto; cleanup; eauto.
    exists (S x); simpl; intuition eauto.
    repeat cleanup_pairs; eauto.
    destruct p; simpl in *; eauto.
  }
  {
    eapply encrypt_all_finished in H0; cleanup.
    exists (S (length vl)); simpl.
    repeat rewrite firstn_oob; try lia.
    intuition eauto.
    repeat cleanup_pairs; eauto.
    destruct p; simpl; eauto.
    all: rewrite map_length; eauto.
  }
Qed.

Theorem read_consecutive_finished:
  forall count a o s s' t u,
    exec CryptoDiskLang u o s (read_consecutive a count) (Finished s' t) ->
    length t = count /\
    (forall i,
       i < count ->
       exists vs,
         (snd s) (a + i) = vs /\
         fst vs = seln t i value0) /\
    s' = s.
Proof.
  induction count; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try solve [intuition eauto; lia].

  edestruct IHcount; eauto; cleanup.
  split; intros; eauto.
  split; intros; eauto.
  destruct i; eauto.
  rewrite PeanoNat.Nat.add_0_r.
  simpl; eexists; eauto.
  simpl.
  rewrite <- PeanoNat.Nat.add_succ_comm.
  eapply H1; lia.
  destruct s; eauto.
Qed.

Theorem read_consecutive_crashed:
  forall count a o s s' u,
    exec CryptoDiskLang u o s (read_consecutive a count) (Crashed s') ->
    s' = s.
Proof.
  induction count; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try solve [intuition eauto; lia].
  repeat (split_ors; cleanup; repeat invert_exec; simpl; eauto).
  destruct s; simpl; eauto.

  eapply IHcount; eauto; cleanup.
  destruct s; simpl in *; eauto.
  apply read_consecutive_finished in H0; cleanup; eauto.
  destruct s; eauto.
Qed.

Definition write_consecutive_finished := write_batch_finished.
Definition write_consecutive_crashed := write_batch_crashed.

(* Oracle length versions*)
Theorem decrypt_all_finished_oracle:
  forall key evl o s s' t u,
    exec CryptoDiskLang u o s (decrypt_all key evl) (Finished s' t) ->
    t = map (decrypt key) evl /\
    consistent_with_upds (snd (fst s)) evl (map (fun ev => (key, decrypt key ev)) evl) /\
    fst (fst s') = fst (fst s) /\
    snd (fst s') = upd_batch (snd (fst s)) evl (map (fun ev => (key, decrypt key ev)) evl) /\
    snd s' = snd s /\
    length o = (length evl * 2) + 1.
Proof.
  induction evl; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; simpl; eauto.
  intuition eauto.

  edestruct IHevl; eauto; cleanup.
  eexists; intuition eauto.
  repeat cleanup_pairs; eauto.
  rewrite app_length; simpl.
  setoid_rewrite H5; lia.
Qed.

Theorem decrypt_all_crashed_oracle:
  forall key evl o s s' u,
    exec CryptoDiskLang u o s (decrypt_all key evl) (Crashed s') ->
    exists n,
      consistent_with_upds (snd (fst s)) (firstn n evl) (firstn n (map (fun ev => (key, decrypt key ev)) evl)) /\
      fst (fst s') = fst (fst s) /\
      snd (fst s') = upd_batch (snd (fst s)) (firstn n evl) (firstn n (map (fun ev => (key, decrypt key ev)) evl)) /\
      snd s' = snd s /\
      n <= length evl /\
      length o >= 1 /\
      length o <= (length evl * 2) + 1.
Proof.
  induction evl; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.
  exists 0; simpl; eauto.
  intuition eauto.

  split_ors; cleanup; repeat invert_exec.
  exists 0; simpl; eauto.
  intuition eauto.
  lia.
  lia.

  split_ors; cleanup; repeat invert_exec.
  {
    apply IHevl in H; cleanup.
    exists (S x); simpl; intuition eauto.
    repeat cleanup_pairs; eauto.
    destruct p; eauto.
    lia.
    lia.
  }
  {
    eapply decrypt_all_finished_oracle in H0; cleanup; eauto.
    exists (S (length evl)); simpl.
    repeat rewrite firstn_oob; try lia.
    intuition eauto.
    repeat cleanup_pairs; eauto.
    destruct p; eauto.
    lia.
    rewrite app_length; simpl.
    setoid_rewrite H4; lia.
    rewrite map_length; eauto.
  }
Qed.

Theorem read_consecutive_finished_oracle:
  forall count a o s s' t u,
    exec CryptoDiskLang u o s (read_consecutive a count) (Finished s' t) ->
    length t = count /\
    (forall i,
       i < count ->
       exists vs,
         (snd s) (a + i) = vs /\
         fst vs = seln t i value0) /\
    s' = s /\
    length o = (count * 2) + 1.
Proof.
  induction count; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try solve [intuition eauto; lia].

  edestruct IHcount; eauto; cleanup.
  split; intros; eauto.
  split; intros; eauto.
  destruct i; eauto.
  rewrite PeanoNat.Nat.add_0_r.
  simpl; eexists; eauto.
  simpl.
  rewrite <- PeanoNat.Nat.add_succ_comm.
  eapply H1; lia.
  simpl in *.
  rewrite app_length; simpl in *.
  setoid_rewrite H3.
  destruct s; intuition eauto.
  lia.
Qed.

Theorem read_consecutive_crashed_oracle:
  forall count a o s s' u,
    exec CryptoDiskLang u o s (read_consecutive a count) (Crashed s') ->
    s' = s /\
    length o >= 1 /\
    length o <= (count * 2) + 1.
Proof.
  induction count; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try solve [intuition eauto; lia].
  repeat (split_ors; cleanup; repeat invert_exec; simpl; eauto).
  destruct s; simpl; intuition eauto.
  lia.

  eapply IHcount in H; eauto; cleanup.
  destruct s; simpl in *; intuition eauto.
  lia.
  apply read_consecutive_finished_oracle in H0; cleanup; eauto.
  destruct s; intuition eauto.
  repeat rewrite app_length; simpl in *.
  lia.
  repeat rewrite app_length; simpl in *.
  setoid_rewrite H2; lia.
Qed.

Theorem encrypt_all_finished_oracle:
  forall key vl o s s' t u,
    exec CryptoDiskLang u o s (encrypt_all key vl) (Finished s' t) ->
    t = map (encrypt key) vl /\
    consistent_with_upds (snd (fst s)) (map (encrypt key) vl) (map (fun v => (key, v)) vl) /\
    fst (fst s') = fst (fst s) /\
    snd (fst s') = upd_batch (snd (fst s)) (map (encrypt key) vl) (map (fun v => (key, v)) vl) /\
    snd s' = snd s /\
    length o = (length vl * 2) + 1.
Proof.
  induction vl; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; simpl; eauto.
  - intuition eauto.
  - edestruct IHvl; eauto; cleanup.
    eexists; intuition eauto.
    repeat cleanup_pairs; eauto.
    rewrite app_length; simpl.
    setoid_rewrite H5; simpl.
    lia.
Qed.

Theorem encrypt_all_crashed_oracle:
  forall key vl o s s' u,
    exec CryptoDiskLang u o s (encrypt_all key vl) (Crashed s') ->
    exists n,
      consistent_with_upds (snd (fst s)) (firstn n (map (encrypt key) vl)) (firstn n (map (fun v => (key, v)) vl)) /\
      fst (fst s') = fst (fst s) /\
      snd (fst s') = upd_batch (snd (fst s)) (firstn n (map (encrypt key) vl)) (firstn n (map (fun v => (key, v)) vl)) /\
      snd s' = snd s /\
      length o >= 1 /\
      length o <= (length vl * 2) + 1.
Proof.
  induction vl; simpl; intros;
  cleanup_no_match; simpl in *;
  repeat invert_exec_no_match;
  cleanup_no_match; try lia; eauto.
  {
    exists 0; simpl; intuition eauto.
  }
  split_ors; cleanup_no_match;
  repeat invert_exec_no_match.
  {
    exists 0; simpl; intuition eauto.
    lia.
  }
  split_ors; cleanup_no_match;
  repeat invert_exec_no_match.
  {
    eapply IHvl in H; eauto;
    cleanup_no_match;
    eauto; simpl.
    exists (S x); simpl; cleanup_no_match; intuition eauto;
    repeat cleanup_pairs; eauto;
    destruct p; simpl in *; eauto; try lia.
  }
  {
    eapply encrypt_all_finished_oracle in H0; cleanup_no_match.

    exists (S(S (length vl + length vl))); intuition eauto;
    repeat rewrite firstn_oob; simpl; eauto;
    try solve [rewrite map_length; simpl; lia];
    repeat cleanup_pairs; eauto.
    destruct p; simpl; eauto.

    lia.
    rewrite app_length; simpl.
    setoid_rewrite H4; simpl.
    lia.
  }
Qed.

Theorem hash_all_finished_oracle:
  forall vl h o s t s' u,
    exec CryptoDiskLang u o s (hash_all h vl) (Finished s' t) ->
    t = rolling_hash h vl /\
    consistent_with_upds (snd (fst (fst s))) (rolling_hash_list h vl) (combine (h:: rolling_hash_list h vl) vl) /\
    (snd (fst (fst s'))) = upd_batch (snd (fst (fst s))) (rolling_hash_list h vl) (combine (h:: rolling_hash_list h vl) vl) /\
    fst (fst (fst s')) = fst (fst (fst s)) /\
    snd (fst s') = snd (fst s) /\
    snd s' = snd s /\
    length o = (length vl * 2) + 1.
Proof.
  induction vl; simpl; intros.
  repeat invert_exec; cleanup; intuition eauto.
  repeat invert_exec; cleanup.
  edestruct IHvl; eauto; cleanup.
  simpl in *; intuition eauto.
  rewrite app_length; simpl.
  setoid_rewrite H6; lia.
Qed.

Lemma rolling_hash_list_length :
forall l h,
length (rolling_hash_list h l) = length l.
Proof.
  induction l; simpl; intuition eauto.
Qed.

Theorem hash_all_crashed_oracle:
  forall vl h o s s' u,
    exec CryptoDiskLang u o s (hash_all h vl) (Crashed s') ->
    exists n,
      n <= length (rolling_hash_list h vl) /\
    consistent_with_upds (snd (fst (fst s))) (firstn n (rolling_hash_list h vl)) (firstn n (combine (h:: rolling_hash_list h vl) vl)) /\
    (snd (fst (fst s'))) = upd_batch (snd (fst (fst s))) (firstn n (rolling_hash_list h vl)) (firstn n (combine (h:: rolling_hash_list h vl) vl)) /\
    fst (fst (fst s')) = fst (fst (fst s)) /\
    snd (fst s') = snd (fst s) /\
    snd s' = snd s /\
    length o >= 1 /\
    length o <= (length (rolling_hash_list h vl) * 2) + 1.
Proof.
  induction vl; simpl; intros.
  repeat invert_exec; cleanup; simpl; eauto.
  exists 0; simpl; intuition eauto.

  repeat invert_exec; cleanup.
  repeat (split_ors; cleanup; repeat invert_exec; simpl; eauto).
  exists 0; simpl; intuition eauto.
  lia.
  lia.

  edestruct IHvl; eauto; cleanup.
  simpl in *; repeat cleanup_pairs; eauto.
  exists (S x); simpl; intuition eauto.
  lia.
  lia.

  eapply hash_all_finished_oracle in H0; cleanup; eauto;
  simpl in *; intuition eauto.
  repeat cleanup_pairs; eauto.
  exists (length (hash_function h a :: rolling_hash_list (hash_function h a) vl)).
  repeat rewrite firstn_oob;
  simpl; intuition eauto.

  repeat rewrite app_length.
  simpl.
  setoid_rewrite H5; lia.
  repeat rewrite rolling_hash_list_length, app_length.
  simpl.
  setoid_rewrite H5; lia.

  generalize vl (hash_function h a).
  induction vl0; simpl; intros; eauto.
  destruct vl0; simpl in *; eauto.
  specialize (IHvl0 (hash_function h1 a0)); lia.
Qed.

Theorem write_batch_finished_oracle:
  forall al vl o t s s' u,
    length al = length vl ->
    exec CryptoDiskLang u o s (write_batch al vl) (Finished s' t) ->
    (forall a, In a al -> a < disk_size) /\
    fst s' = fst s /\ snd s' = TotalMem.upd_batch_set (snd s) al vl /\
    length o = (length al * 2) + 1.
Proof.
  induction al; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.
  intuition eauto.

  eapply IHal in H0; try lia; cleanup.
  simpl in *; cleanup.
  intuition eauto.
  subst; congruence.
  rewrite app_length; simpl.
  setoid_rewrite H3; lia.
Qed.

Theorem write_batch_crashed_oracle:
  forall al vl o s s' u,
    length al = length vl ->
    exec CryptoDiskLang u o s (write_batch al vl) (Crashed s') ->
    exists n,
      n <= length al /\
      (forall a, In a (firstn n al) -> a < disk_size) /\
      fst s' = fst s /\
      snd s' = TotalMem.upd_batch_set (snd s) (firstn n al) (firstn n vl) /\
      length o >= 1 /\
      length o <= (length al * 2) + 1.
Proof.
  induction al; simpl; intros;
  cleanup; simpl in *; repeat invert_exec;
  cleanup; try lia; eauto.
  {
    exists 0; split; intuition eauto.
    simpl in *; intuition.
  }

  split_ors; cleanup; repeat invert_exec; simpl.
  {
    exists 0; split; intuition eauto; simpl in *.
    lia.
    intuition.
    lia.
  }

  split_ors; cleanup; repeat invert_exec; simpl in *.
  {
    eapply IHal in H0; try lia.
    cleanup; simpl in *; cleanup.
    exists (S x); split; intuition eauto; simpl in *.
    lia.
    split_ors; cleanup; eauto.
    lia.
  }
  {
    eapply write_batch_finished_oracle in H1; eauto; cleanup.
    simpl in *; cleanup.
    exists (S (length al)).
    simpl.
    repeat rewrite firstn_oob by lia.
    cleanup; split; intuition eauto; simpl in *.
    cleanup.
    eauto.
    lia.
    rewrite app_length; simpl.
    setoid_rewrite H3; lia.
  }
Qed.

Definition write_consecutive_finished_oracle := write_batch_finished_oracle.
Definition write_consecutive_crashed_oracle := write_batch_crashed_oracle.