From Coq Require Import String Ensembles Sorted Mergesort Permutation Classical_Prop.
From RelationAlgebra Require Import prop monoid kat relalg kat_tac.
From Catincoq.lib Require Import defs proprel Cat acyclic co linearext tactics relalglaws.
From Catincoq.models Require rc11 sc.
From Catincoq.zoo Require sc_nosm tso_nosm lamport.
From Catincoq.zoo Require x86tso. (* NOT the one in models/, since we need MFENCE to be defined: *)

Open Scope string_scope.

Ltac destr :=
  match goal with
  | c : candidate |- _ =>
    destruct c as
     [events W R IW FW B RMW F po addr data ctrl rmw amo
              rf loc ext int uset urel fin]
  end.

Ltac destrunfold := destr; repeat autounfold with * in *.

Definition in_at {A} (l : list A) : nat -> A -> Prop :=
  fun n x => List.nth_error l n = Some x.

Definition in_before {A} (l : list A) : A -> A -> Prop :=
  fun x y => x = y \/ exists n, exists m, n <= m /\ in_at l n x /\ in_at l m y.

(** Cat idiom for inclusion *)
Lemma is_empty_included {A} (R S : relation A) : is_empty (R ⊓ !S) <-> R ≦ S.
Proof.
  symmetry.
  unfold is_empty.
  split; destruct_rel. firstorder.
  destruct (classic (S x y)); firstorder.
Qed.

Instance linearisations_weq_ (A : Type) :
  Proper (weq --> weq --> weq --> iff) (Cat.linearisations : set A -> relation A -> set (relation A)).
Proof.
  unfold Cat.linearisations, linear_extension_on, strict_total_order_on, strict_order, total_on, Proper, respectful, flip.
  intros ? ? e1 ? ? e2 ? ? e3.
  rewrite ?e1, ?e2, ?e3; tauto.
Qed.

Lemma linearisations_weq {A : Type} (E1 E2 : set A) (R1 R2 S1 S2 : relation A) :
  E1 ≡ E2 ->
  R1 ≡ R2 ->
  S1 ≡ S2 ->
  Cat.linearisations E1 R1 S1 <->
  Cat.linearisations E2 R2 S2.
Proof.
  intros -> -> ->; tauto.
Qed.

Ltac hkat_help :=
  repeat
    match goal with
    | H : ?r ≦ [?a] ⋅ ?r ⋅ [?b] |- _ =>
      let H1 := fresh H in
      let H2 := fresh H in
      assert (H1 : [!a] ⋅ r ≦ 0) by (rewrite H; kat);
      assert (H2 : r ⋅ [!b] ≦ 0) by (rewrite H; kat);
      clear H
    end.

Lemma transitive_dot_tst_l {X} (R : relation X) (E : set X) :
  is_transitive R -> is_transitive (R ⋅ [E]).
Proof.
  unfold is_transitive.
  assert (R⋅[E]⋅(R⋅[E]) ≦ R⋅R⋅[E]) as -> by kat.
  intros ->; auto.
Qed.

Lemma transitive_dot_tst_r {X} (R : relation X) (E : set X) :
  is_transitive R -> is_transitive ([E] ⋅ R).
Proof.
  unfold is_transitive.
  assert ([E]⋅R⋅([E]⋅R) ≦ [E]⋅(R⋅R)) as -> by kat.
  intros ->; auto.
Qed.

Lemma transitive_cap {X} (R S : relation X) :
  is_transitive R -> is_transitive S -> is_transitive (R ⊓ S).
Proof.
  unfold is_transitive.
  rewrite dotxcap, 2dotcapx.
  intros -> ->.
  lattice.
Qed.

Notation " x :: X " := ((X : set _) x). (* TODO move/remove *)

Lemma ranging_spec {A} (R : relation A) (X : set A) :
  R ≦ R ⋅ [X] <-> (forall x y, R x y -> X y).
Proof.
  split; intros r x y xy.
  - apply r in xy. types.
  - relate. eauto.
Qed.

Lemma ranging_itr {A} (R : relation A) (X : set A) :
  (forall x y, R x y -> y :: X) ->
  (forall x y, (R^+) x y -> y :: X).
Proof.
  rewrite <-!ranging_spec.
  intros e; rewrite e at 1. kat.
Qed.

Lemma ranging_cup {A} (R S : relation A) (X : set A) :
  (forall x y, R x y -> y :: X) ->
  (forall x y, S x y -> y :: X) ->
  (forall x y, (R ⊔ S) x y -> y :: X).
Proof.
  rewrite <-!ranging_spec.
  intros e f; rewrite e, f at 1. kat.
Qed.

Lemma ranging_capl {A} (R S : relation A) (X : set A) :
  (forall x y, R x y -> y :: X) ->
  (forall x y, (R ⊓ S) x y -> y :: X).
Proof.
  rewrite <-!ranging_spec.
  intros e; rewrite e at 1. destruct_rel. relate.
Qed.

Lemma ranging_capr {A} (R S : relation A) (X : set A) :
  (forall x y, S x y -> y :: X) ->
  (forall x y, (R ⊓ S) x y -> y :: X).
Proof.
  rewrite <-!ranging_spec.
  intros e; rewrite e at 1. destruct_rel. relate.
Qed.

Lemma domrng_char {A} (R : relation A) (X Y : set A) :
  R ≦ [X] ⋅  R  ⋅ [Y] <->
  R ≦ [X] ⋅ top ⋅ [Y].
Proof.
  split. intros ->. ra. intros r x y xy. spec r x y xy. relate; types.
Qed.

Lemma itr_ext' {X} (R : relation X) x y : R x y -> R^+ x y.
Proof.
  revert x y.
  change (R ≦ R^+).
  ka.
Qed.

Lemma sc_lamport c
      (no_atomic : rmw c ≡ bot)
      (no_mixed_size : unknown_relation c "sm" ≡ 1) :
  sc.valid c <-> lamport.valid c.
Proof.
  unfold sc.valid, lamport.valid.
  (* maybe once the problem of location is solved, those will not
  depend on the candidate so we won't need those 'pose proof's *)
  pose proof @generate_orders_spec_3 c as GOS.
  pose proof @generate_orders_total c as GOT.
  pose proof @generate_orders_total' c as GOT'.
  pose proof @generate_orders_order c as GOO.
  pose proof @location_of_spec c as LOS.
  destrunfold.
  assert (loc_sym' : loc° ≡ loc).
  { clear GOS GOT GOT' GOO LOS; split; destruct_rel; firstorder. }
  split.

  - (** Suppose we have a "sc.cat" execution, with a generated co *)
    intros (co & Hco & atomic & sc).
    rewrite no_mixed_size, dotx1 in sc. clear no_mixed_size no_atomic.
    change @Cat.co_locs with @co_locs in Hco.
    pose proof Hco as co_total%GOT.
    pose proof Hco as co_total'%GOT'.
    pose proof Hco as co_order%GOO.
    apply GOS in Hco.
    destruct Hco as (co_iwfw & co_loc & co_lin).
    (* assert (co_loc : co ≦ loc). *)
    (* { transitivity ([W]⋅loc⋅[W]). rewrite co_total; ka. kat. } *)
    assert (co_final : [W ⊓ !FW]⋅loc⋅[FW] ≦ co).
    { rewrite <-co_iwfw. intros x y. destruct_rel. relate. right. relate. }
    (* assert (co_total' : [W] ⋅ (!1 ⊓ loc) ⋅ [W] ≦ co ⊔ co°). *)
    (* { rewrite capC, dotcap1_rel, co_total; try kat. *)
    (*   destruct_rel. now left. now right. clear GOS. firstorder. } *)
    assert (co_ww : co ≦ [W] ⋅ co ⋅ [W]).
    { apply domrng_char. transitivity ([W]⋅loc⋅[W]). 2:ra.
      transitivity (co ⊔ co°). ra. rewrite <-co_total'. ra. }
    assert (co_iw : co ⋅ [IW] ≦ 0).
    { intros w1 w2.
      assert (([IW] ⊔ [!IW]) w1 w1).
      { assert (a: 1 ≦ [IW] ⊔ [!IW]) by kat. now apply a. }
      destruct_rel.
      - (* w1 and w2 related through IW;co;IW? no contradiction? *)
        assert (w1 = w2) as <-. apply iw_uniq. relate. now apply co_loc.
        assert ((co ⊔ co°) w1 w1) as f%co_total'%tst_dot_tst by (left; auto).
        now apply f.
      - (* w1 is not initial: then, cycle in co *)
        exfalso.
        assert (co w2 w1).
        { apply co_iwfw. split. relate. now apply loc_sym, co_loc. left. relate. relate.
          now apply loc_sym, co_loc. }
        assert (c : co w1 w1) by now apply co_order; exists w2; auto.
        exfalso.
        eapply co_order. relate. eauto.
    }
    remember (rf° ⋅ co ⊓ !id) as fr.
    set (com := fr ⊔ (rf ⊔ co)).
    set (M := R ⊔ W).
    set (M' := M ⊓ !IW).
    (** We know po+com is acyclic, so we can extend it a total order *)
    destruct (every_strict_order_can_be_total_on top (po ⊔ com)^+)
      as (S & (St & Sirr) & lame & Stot & Sincl).
    { intros; apply classic. }
    { intros; apply classic. }
    { destruct fin as [l]. exists l. intuition. }
    { split. kat. revert sc. apply irreflexive_leq. unfold com. kat. }
    assert (poS : po ≦ S) by (rewrite <-Sincl; kat).
    assert (coS : co ≦ S) by (rewrite <-Sincl; unfold com; kat).
    assert (frS : fr ≦ S). now rewrite <-Sincl; unfold com; kat.
    (** This total order is the "S" of the Lamport-style definition,
     with some subtlety about initial writes *)
    set (S' := [!IW] ⋅ S ⋅ [!IW]).
    exists S'.
    repeat apply conj; try rewrite is_empty_included.
    (** S is indeed a "linearisation" *)
    + (* transitive *)
      unfold S'. transitivity ([!IW] ⋅ (S ⋅ S) ⋅ [!IW]).
      kat. rewrite St. auto.
    + (* irreflexive *)
      unfold S'. destruct_rel. apply Sirr. split. auto. reflexivity.
    + (* domain/range *)
      unfold S'. ra.
    + (* totality *) unfold S', total_on. rewrite 2cnvdot, cnvtst, dotA.
      transitivity ([!IW] ⋅ (S ⊔ S°) ⋅ [!IW]). 2:ka. unfold total_on in Stot.
      rewrite <-Stot.
      kat.
    + (* extends [w]loc[fw] *)
      rewrite cap_cartes.
      cut ([W ⊓ !FW]⋅loc⋅[FW] ≦ S). now intros ->; auto.
      rewrite co_final. auto.
    + (** S extends po *)
      unfold S'. rewrite <-poS.
      rewrite po_iw at 1.
      kat.
    + (** rf can be expressed in terms of S: inclusion 1 *)
      rewrite cap_cartes.
      rewrite cap_cartes_l.
      set (S'' := S' ⊔ [IW]⋅loc⋅[M']).
      set (WRS := [W]⋅(S'' ⊓ loc)⋅[R]).
      change (rf ≦ WRS ⊓ !(S''⋅WRS)).
      apply leq_xcap.
      * (* r <= WRS *)
        assert (rf ≦ loc ⊓ rf ⊓ rf) as -> by lattice.
        assert (e: rf ≦ (([IW] ⊔ [W ⊓ !IW]) ⋅ rf ⋅ [R] ⋅ ([IW] ⊔ [R ⊓ !IW]))).
        { clear GOS GOT GOO GOT' co_lin LOS.
          hkat_help. (* Fail hkat. *) clear -rf_wr0 rf_wr1. hkat. }
        rewrite e at 2.
        ra_normalise.
        subst WRS S'' S' M' M.
        intros w r. destruct_rel.
        -- relate. right. relate. left. types.
        -- relate. exfalso. assert (w = r) as <- by now apply iw_uniq; relate.
           apply (sc w w). relate.
           assert (rf ≦ (po ⊔ (fr ⊔ (rf ⊔ co)))^+) as a by ka.
           now apply a.
        -- relate. left. relate. apply Sincl. relate.
           unfold com.
           assert (rf ≦ (po ⊔ (fr ⊔ (rf ⊔ co)))^+) as a by ka.
           now apply a.
        -- exfalso.
           apply (sc w w). relate.
           assert (rf ⋅ co ≦ (po ⊔ (fr ⊔ (rf ⊔ co)))^+) as a by ka.
           apply a.
           exists r; auto. apply co_iwfw. relate. left. relate. now apply loc_sym.
      * (* r <= !(S'' WRS) *)
        intros w1 r w1r [w2 w1w2 w2r].
        assert (w1 <> w2).
        { intros <-. unfold S'', S' in w1w2. destruct_rel.
          eapply Sirr; split; eauto; reflexivity.
          firstorder. }
        types r.
        types w1.
        assert (w2 :: W) by (unfold WRS in *; types).
        assert (loc w1 w2). { apply loc_trans with r. now apply rf_loc.
          apply loc_sym. subst WRS. destruct_rel. apply loc_sym. auto. }
        apply weq_spec, proj1 in co_total'.
        destruct (co_total' w1 w2) as [D|D]. now relate.
        -- assert (fr r w2).
           { rewrite Heqfr. split. exists w1. apply w1r. apply D. intros ->.
             (* WRS is acyclic *) subst WRS S'' S'. destruct_rel.
             now apply (Sirr w2 w2); relate.
             now types.
             now apply (Sirr w2 w2); relate.
             now types.
           }
           subst WRS S'' S'. clear w1w2.
           destruct_rel.
           ++ (* left component of WRS : S *)
              assert (S r w2). now apply frS.
              assert (S r r). now eapply St; exists w2; auto.
              eapply Sirr with r r. relate.
           ++ (* right component of WRS: IW loc M' *)
              apply co_iw with w1 w2. exists w2; auto; relate.
        -- subst WRS S'' S'. clear w2r.
           destruct_rel.
           ++ (* left component of WRS : S *)
              assert (S w2 w1). now apply coS.
              assert (S w1 w1). eapply St; exists w2; auto.
              eapply Sirr with w1 w1. relate.
           ++ (* right component of WRS: IW loc M' *)
              apply co_iw with w2 w1. exists w1; auto. relate.
    + (** Inclusion 2 *)
      rewrite cap_cartes, cap_cartes_l.
      subst S'.
      intros w1 r [w1r short].
      assert (r :: R). types.
      destruct (r_rf r r ltac:(split; auto)) as [w2 _ qw].
      types w2.
      destruct (classic (w1 = w2)). congruence.
      apply weq_spec, proj1 in co_total'.
      destruct (co_total' w1 w2) as [D|D].
      { relate. types. apply loc_trans with r. now destruct_rel.
        apply loc_sym. now apply rf_loc. }
      * (* w1 -co-> w2 -rf-> r, which should contradict the "short" hypothesis *)
        destruct short. exists w2.
        -- (* w1 to w2 *)
           destruct (classic (IW w1)).
           ++ (* w1 is initial *)
              right. exists w2. exists w1. now split; auto. now apply co_loc.
              split; auto. split. unfold M. right; auto.
              intro. apply co_iw with w1 w2.
              rewrite dot_tst. split. auto. relate.
           ++ (* w1 is not initial *)
              left. exists w2. exists w1. now split; auto. now apply coS.
              split; auto. intro. apply co_iw with w1 w2.
              rewrite dot_tst. split. auto. relate.
        -- (* w2 to r *)
           exists r. 2: now split; auto. exists w2. now split; auto.
           split. 2: now apply rf_loc.
           assert (r :: !IW). now types.
           destruct (classic (IW w2)).
           ++ (* w2 is initial *)
              right. exists r. exists w2. now split; auto. now apply rf_loc.
              split; auto. split. unfold M. left; auto. auto.
           ++ (* w2 is not initial *)
              left. exists r. exists w2. now split; auto.
              assert (a: rf ≦ S). rewrite <-Sincl. unfold com. kat. now apply a.
              split; auto.
      * (* w1 <-co- w2 -rf-> r, so r-fr->w1, and so r-WRS->w1 *)
        exfalso.
        change (co w2 w1) in D.
        assert (fr r w1). { subst. split. now exists w2; auto.
          unfold id. simpl. types r. types w1. intros ->. Fail now type.
          (* cycle in w1r *) destruct_rel. now apply (Sirr w1 w1); relate.
          types. }
        clear short. destruct_rel.
        -- (* in S *) apply Sirr with r r. split. apply St. exists w1.
           now apply frS. assumption. reflexivity.
        -- (* in IW loc M', but w1 cannot be in IW since w2 -co->w1 *)
           eapply co_iw. exists w1. eauto. now split.

  - (** Now suppose we have an execution with a Lamport-style "S"
    total relation, we build a sc.cat execution, and in particular the
    co between writes, which is S restricted to pairs of writes on the
    same variable, with some detail accounting to initial variables *)
    intros (S & ((Sirr, St) & Sdom & Stot & Sincl) & Spo & Srf & rfS).
    rewrite is_empty_included in Srf, rfS, Spo.
    pose proof antisym _ _ Srf rfS as S_rf. clear Srf rfS.
    rewrite cap_cartes in S_rf.
    rewrite cap_cartes_l in S_rf.
    (** S doesn't touch any IW, so we add IW->W\IW and ^+ *)
    set (S_ := (S ⊔ [IW]⋅loc⋅[(R ⊔ W) ⊓ !IW])^+).
    (* set (S_ := ([IW]⋅loc⋅[(R ⊔ W) ⊓ !IW] ⊔ 1) ⋅ S). *)
    fold S_ in S_rf.
    (* set (co_init := loc ⊓ [IW]⋅top⋅[(R ⊔ W) ⊓ !IW]). *)
    set (co := [W] ⋅ (S_ ⊓ loc) ⋅ [W]).  (* ⊔ co_init). *)
    exists co.
    rewrite no_mixed_size, dotx1. clear no_mixed_size.
    repeat apply conj.
    + (** Properties of co *)
      (* TODO : those are properties of co needed in the older
      characterization of generate_orders, so we keep them here in
      order to help proving the new characterization *)
      assert (co_ww : co ≦ [W]⋅co⋅[W]). {
        unfold co. now kat.
      }
      assert (co_irr : co ⊓ 1 ≦ 0). {
        unfold co, S_.
        destruct_rel.
        cut (acyclic (S ⊔ [IW]⋅loc⋅[(R ⊔ W) ⊓ !IW])). now intros a; apply a.
        apply acyclic_cup_excl2_l.
        -- now rewrite Sdom; kat.
        -- now kat.
        -- now apply transitive_irreflexive_acyclic; auto.
      }
      assert (co_trans : co⋅co ≦ co). {
        apply transitive_dot_tst_l.
        apply transitive_dot_tst_r.
        apply transitive_cap.
        now apply transitive_itr.
        intros x y [z ? ?]. eapply loc_trans; eauto.
      }
      assert (co_loc : co ≦ loc). {
        subst co. rewrite leq_cap_r. kat.
      }
      assert (co_TODO_find_name :
      forall x y : events, loc x y -> x :: W -> y :: W ->
    ((loc ⊓ ([IW]⋅top⋅[W ⊓ !IW] ⊔ [W ⊓ !FW]⋅top⋅[FW])) x y -> co x y) /\
    (x <> y -> co x y \/ co y x)). {
        assert (co1 : loc ⊓ ([IW]⋅top⋅[W ⊓ !IW] ⊔ [W ⊓ !FW]⋅top⋅[FW]) ≦ co).
        { subst co S_.
          rewrite <-Sincl, <-itr_ext.
          rewrite <-(capI loc) at 1; rewrite <-capA.
          rewrite capcup, !dotcap1_rel, !cap_cartes; try kat.
          rewrite capC. apply cap_leq; auto.
          apply join_leq.
          - clear -iw_w fw_w.
            hkat.
          - clear -iw_w fw_w iw_fw loc_sym.
            transitivity ([W ⊓ !FW]⋅loc⋅[FW]⋅([IW] ⊔ [!IW])). now kat.
            ra_normalise.
            apply join_leq. now hkat.
            rewrite capC, inj_cap.
            enough (E : [W]⋅loc⋅[FW]⋅[IW] ≦ [FW]⋅[IW]⋅top). now mrewrite E; kat.
            apply cnv_leq_iff. ra_simpl. rewrite !cnvtst.
            rewrite inj_cap, dotA in iw_fw. rewrite <-iw_fw.
            destruct_rel. relate. firstorder.
        }
        assert (co2 : [W] ⋅ (!1 ⊓ loc) ⋅ [W] ≦ co ⊔ co°). {
          subst S_ co.
          transitivity (([IW] ⊔ [W ⊓ !IW]) ⋅ (!1 ⊓ loc) ⋅ ([IW] ⊔ [W ⊓ !IW])).
          now kat.
          ra_normalise.
          elim_cnv.
          rewrite loc_sym'.
          repeat apply join_leq.
          - rewrite dotcap1_rel; try kat.
            assert ([W ⊓ !IW]⋅!1⋅[W ⊓ !IW] ≡ [W]⋅([!IW]⋅!1⋅[!IW])⋅[W]) as -> by kat.
            unfold total_on in Stot.
            rewrite Stot.
            destruct_rel.
            + left. relate. apply itr_ext'. left. relate.
            + right. relate. apply itr_ext'. left. relate.
          - rewrite <-leq_cup_r, <-leq_cup_r, <-itr_ext.
            destruct_rel. relate. right; types.
          - rewrite <-leq_cup_l, <-leq_cup_r, <-itr_ext.
            destruct_rel. relate. right; types.
          - rewrite <-cap_cartes, <-capA, cap_cartes, iw_uniq, capC, capneg.
            ra.
        }
        intros w1 w2 w1w2 Ww1 Ww2; split. apply co1.
        intros d; apply co2.
        relate.
      }
      change @Cat.cross with @cross.
      change @Cat.co_locs with @co_locs.
      apply GOS.
      clear GOS GOT GOT' GOO.
      split. 2:split. 2:easy. 2:intros l; split; [ split | split ].
      * intros x y xy. relate.
        apply co_TODO_find_name.
        now apply xy.
        now destruct_rel; relate.
        now destruct_rel; relate.
        now apply xy.
      * apply is_irreflexive_spec2.
        intros x y. destruct_rel. destruct (co_irr x x); relate.
      * intros x z [y xy yz]. relate. apply co_trans. exists y; destruct_rel; auto.
      * intros x y. destruct_rel. relate.
      * intros x y. destruct_rel. relate.
        (* assert (location_of x = location_of y). *)
        (* assert (loc x y) by now apply LOS; congruence. *)
        specialize (co_TODO_find_name x y).
        destruct co_TODO_find_name as [_ [tot|tot]]; try relate.
        now apply LOS; congruence.
        now left; relate.
        now right; relate.
    + (** atomic. *)
      unfold is_empty.
      rewrite no_atomic; ra.
    + (** Main acyclicity requirement, on po+com *)
      apply acyclic_leq with S_.
      * repeat apply join_leq.
        -- (** po *) unfold S_. rewrite <-Spo. ka.
        -- (** fr *)
           intros r w2 ([w1 rw1 w1w2] & rw2). destruct_rel.
           (** We use the totality of S *)
           destruct (Stot r w2) as [T|T].
           { (* Checking it's the right domain *)
             relate.
             - rewrite S_rf in rw1.
               destruct_rel; try relate.
             - subst co S_.
               destruct_rel.
               eapply ranging_itr; eauto.
               apply ranging_cup.
               + intros x y xy. apply Sdom in xy. types.
               + intros x y xy. destruct_rel. types. relate.
           }
           ++ (** first case: S r w2. Then, S_ r w2 *)
              assert (a : forall S : relation events, S ≦ S^+) by (intro;ka). apply a.
              left; auto.
           ++ (** first case: S w2 r. Then rf w1 r can be shortcut
                through w2, contradiction. *)
              exfalso.
              change (S w2 r) in T.
              rewrite S_rf in rw1. destruct rw1 as [rw1 rw1']. apply rw1'.
              exists w2.
              ** (** First part of the path: co w1 w2 *)
                 destruct (classic (IW w1)) as [w1i | w1ni].
                 (* w1 initial *)
                 { subst co. right. apply domrng_char in Sdom.
                   relate. now destruct_rel. right; types. }
                 (* w1 not initial *)
                 assert (a: ([!IW] ⋅ co) w1 w2) by relate.
                 left. cut ([!IW]⋅co ≦ S). intros H; now apply H.
                 subst co S_.
                 assert (S^+ ≡ S) as <- by now apply itr_transitive.
                 apply domrng_char in Sdom.
                 rewrite Sdom at 1.
                 rewrite leq_cap_l.
                 kat.
              ** (** Second part: we know S w2 r *)
                 subst co.
                 relate.
                 now left.
                 now apply loc_trans with w1; destruct_rel; auto; symmetry.
        -- (** rf*) subst S_.
           rewrite S_rf, 2leq_cap_l, <-itr_ext. kat.
        -- (** co *)
           unfold co. rewrite leq_cap_l. kat.
      * (** S_ is indeed acyclic *)
        unfold S_. rewrite acyclic_itr.
        apply acyclic_cup. repeat apply conj.
        -- apply transitive_irreflexive_acyclic; auto.
        -- apply acyclic_incompatible_domain_range. now firstorder.
        -- apply empty_acyclic. unfold is_empty.
           rewrite itr_str_r.
           rewrite itr_str_l.
           clear no_atomic.
           hkat.
Qed.

Lemma sc_nosm_stronger_than_x86tso c : is_transitive (po c) -> sc_nosm.valid c -> x86tso.valid c.
Proof.
  intros Hpo.
  unfold sc_nosm.valid, x86tso.valid.
  intros (co & Hco & Hatom & Hsc). exists co. split. apply Hco. clear Hco.

  destr; repeat autounfold with * in *.

  split; [ | split ].
  - (* sc => uniproc *)
    revert Hsc.
    apply acyclic_leq.
    (* note: goal solvable by lattice *)
    assert (po ⊓ loc ≦ po) as -> by lattice.
    ka.
  - (* atomics *)
    auto.
  - (* sc => tso *)
    revert Hsc.
    apply acyclic_leq.
    rewrite !cap_cartes.
    assert (E0 : [empty ⊔ empty : set _] ≡ (0 : relation events)) by kat.
    assert (E1 : [top : set _] ≡ (1 : relation events)) by kat.
    rewrite E0, E1.
    rewrite !leq_tst_1.
    ra_normalise.
    unfold is_transitive in Hpo. rewrite Hpo.
    (* note: goal solvable by lattice *)
    assert (rf ⊓ ext ≦ rf) as -> by lattice.
    ka.
Qed.

Lemma sc_nosm_stronger_than_tso_nosm c : is_transitive (po c) -> sc_nosm.valid c -> tso_nosm.valid c.
Proof.
  intros Hpo.
  unfold sc_nosm.valid, tso_nosm.valid.
  intros (co & Hco & Hatom & Hsc). exists co. split. apply Hco. clear Hco.

  destr.
  repeat autounfold with * in *.

  split; [ | split ].
  - (* sc => uniproc *)
    revert Hsc.
    apply acyclic_leq.
    assert (po ⊓ loc ≦ po) as -> by lattice.
    ka.
  - (* atomics *)
    auto.
  - (* sc => tso *)
    revert Hsc.
    apply acyclic_leq.
    ra_normalise.
    rewrite !leq_tst_1.
    unfold is_transitive in Hpo. ra_normalise. rewrite Hpo.
    (* note: goal solvable by lattice *)
    assert (rf ⊓ ext ≦ rf) as -> by lattice.
    ka.
Qed.

(*
can sometimes be replaced with assert _ as -> by _.
Tactic Notation "rew" constr(e) :=
  let E := fresh in assert (E : e); [ | rewrite E; clear E].
Tactic Notation "rew" constr(e) "by" tactic(t) :=
  let E := fresh in assert (E : e) by t; rewrite E; clear E.
Tactic Notation "rew" constr(e) "in" hyp(H) :=
  let E := fresh in assert (E : e); [ | rewrite E in H; clear E].
Tactic Notation "rew" constr(e) "in" hyp(H) "by" tactic(t) :=
  let E := fresh in assert (E : e) by t; rewrite E in H; clear E.
/*)

Lemma x86tso_stronger_than_tso_nosm c :
  is_transitive (po c) ->
  x86tso.valid c -> tso_nosm.valid c.
Proof.
  intros Hpo.
  unfold x86tso.valid, tso_nosm.valid.

  intros (co & Hco & Huniproc & Hatom & Hghb). exists co; split; [ apply Hco | ].
  split; [ | split ].
  - (* uniproc *)
    destrunfold.
    revert Huniproc; apply acyclic_leq.
    ka.
  - (* atomic *)
    auto.
  - (* main *)
    destrunfold.
    revert Hghb; apply acyclic_leq.
    rewrite !cap_cartes.
    unfold empty.
    hkat.
Qed.

Lemma tso_nosm_stronger_than_x86tso c :
  [W c] ⋅ [R c] ≦ 0 ->
  rf c ≦ [W c] ⋅ rf c ⋅ [R c] ->
  irreflexive (po c) ->
  is_transitive (po c) ->
  tso_nosm.valid c -> x86tso.valid c.
Proof.
  intros wr rf_wr po_irr po_trans.
  unfold x86tso.valid, tso_nosm.valid.

  intros (co & Hco & Huniproc & Hatom & Hghb). exists co; split; [ apply Hco | ].
  split; [ | split ].
  - (* uniproc *)
    destrunfold.
    revert Huniproc; apply acyclic_leq.
    ka.
  - (* atomic *)
    auto.
  - (* main *)
    pose proof @generate_orders_dom c as god.
    destrunfold.
    set (MF := (uset _ : set _)) in Hghb. fold MF in Hghb.
    rewrite !cap_cartes.

    (* all of the complexity below is due to the fact that po[mf]po is
     surrounded by [R+W] in tso_nosm but not in x86tso. This does not
     matter in principle, because a cycle can escape po only through a
     com. This intuition is formalized in [acyclic_range_domain],
     which allows us to conclude, painfully, since range(rel) is not a
     test *)
    assert (E0 : [empty : set _] ≡ (0 : relation events)) by kat.
    assert (E1 : [top : set _] ≡ (1 : relation events)) by kat.
    (* simplication inside acyclic *)
    eapply acyclic_weq.
    { rewrite ?kat.inj_cup. ra_normalise. reflexivity. }
    (* some simplification in Hgb *)
    eapply acyclic_weq in Hghb; swap 1 2.
    { rewrite ?kat.inj_cup, E0. ra_normalise. reflexivity. }
    cut (acyclic (po⋅[MF]⋅po + (co + rf ∩ ext + rf°⋅co ∩ !id + [W]⋅po⋅[W] + [R]⋅po⋅[R ⊔ W]))).
    { rewrite ?kat.inj_cup. apply acyclic_weq. hkat. }
    rewrite acyclic_tst with (Dom := (R ⊔ W)) (Rng := (R ⊔ W)).
    + (* apply acyclic_range_domain. *)
      split.
      { rewrite leq_tst_1.
        apply acyclic_leq with po; ra_normalise; auto. apply acyclic_irreflexive.
        cut (po^+ ≡ po). intros ->; auto. apply itr_transitive; auto. }
      assert (Hpo : (po⋅[MF]⋅po)^+ ≦ po⋅[MF]⋅po).
      { transitivity (po^+⋅[MF]⋅po^+). kat. rewrite itr_transitive; auto. }
      rewrite Hpo.
      revert Hghb; apply acyclic_leq.
      assert ([!W] ⋅ rf ≦ 0) by (rewrite rf_wr; kat).
      assert (rf ⋅ [!R] ≦ 0) by (rewrite rf_wr; kat).
      hkat.
    + set (frd :=  rf°⋅co ⊓ !id).
      assert (co_ww : co ≦ [W] ⋅ co ⋅ [W]) by now eapply god; eauto.
      assert (frd_rw : frd ≦ [R] ⋅ frd ⋅ [W]). {
        unfold frd. rewrite co_ww, rf_wr at 1.
        clear.
        ra_normalise. rewrite !cnv_inj.
        rewrite (leq_tst_1 W) at 1 2. ra_normalise.
        rewrite dotcap1l_rel, dotcap1r_rel; kat || ra.
      }
      assert (rfe_wr : (rf ⊓ ext) ≦ [W] ⋅ (rf ⊓ ext) ⋅ [R]). {
        rewrite dotcap1l_rel, dotcap1r_rel. rewrite rf_wr at 1. auto. kat. kat.
      }
      rewrite rfe_wr, co_ww, frd_rw at 1.
      kat.
Qed.

Lemma sc_nosm_stronger_than_rc11 c :
  is_transitive (po c) ->
  sc_nosm.valid c -> rc11.valid c.
Proof.
  intros Hpo.
  unfold sc_nosm.valid, rc11.valid.

  intros (co & Hco & Hatom & Hsc). exists co; split; [ apply Hco | ].

  split; [ | split; [ | split; [ | split; [ | split ] ] ] ].
  - destrunfold.
    admit.
  - destrunfold.
    admit.
  - destrunfold.
    admit.
  - destrunfold.
    revert Hatom.
    apply is_empty_leq. unfold flip.
    assert (complement' : forall A (R : relation A), complement R ≡ !R).
    { reflexivity || (intros; unfold complement, diff, universal; lattice). }
    (* Fail fail rewrite complement'. *)
    ra_normalise.
(* c'est ça en fait ? c'est pas vrai a priori
 (⟦ RMW ⟧ ⊔ rmw ⊓ (fr ⊓ !id) ⋅ co
         ≦ rmw ⊓ (fre ⊓ !id) ⋅ coe *)
    admit.
  - destrunfold.
    repeat rewrite diag_inter.
    repeat rewrite diag_union.
    set (RLX := uset "RLX").
    set (ACQ := uset "ACQ").
    set (REL := uset "REL").
    set (SC := uset "SC").
    set (AR := uset "ACQ_REL").
    Fail fail ra_normalise. (* bad idea: 8000 lines or so *)
    set (ALL := ([ RLX ] ⊔ ([ REL ] ⊔ ([ AR ] ⊔ ([ ACQ ] ⊔ [ SC ]))))).
    admit.
  - destrunfold.
    revert Hsc. apply acyclic_leq. unfold flip.
    now lattice.
Abort.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.RefinementCommonDefinitions.

Require Import VerdiRaft.LeadersHaveLeaderLogsInterface.
Require Import VerdiRaft.EveryEntryWasCreatedInterface.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RefinementSpecLemmas.
Require Import VerdiRaft.CommonTheorems.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Section EveryEntryWasCreated.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {lhlli : leaders_have_leaderLogs_interface}.

  Hint Constructors in_any_log : core.
  (* proof sketch: prove for in_any_log. the only time new entries
  come into the system is on a leader, and leaders have leaderLogs in
  their term.  *)

  Definition in_any_log_term_was_created net :=
    forall e,
      in_any_log net e ->
      term_was_created net (eTerm e).

  Ltac iae_case :=
    match goal with
      | [ H : in_any_log _ _ |- _ ] => invcs H
    end.

  Lemma term_was_created_preserved :
    forall net net' t,
      term_was_created net t ->
      (forall h t ll,
         In (t, ll) (leaderLogs (fst (nwState net h))) ->
         In (t, ll) (leaderLogs (fst (nwState net' h)))) ->
      term_was_created net' t.
  Proof using.
    intros. unfold term_was_created in *.
    break_exists_exists. eauto.
  Qed.

  Ltac in_aer :=
    repeat find_rewrite; eapply in_aer; eauto; repeat find_rewrite; reflexivity.

  Lemma in_any_log_term_was_created_append_entries :
    refined_raft_net_invariant_append_entries in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    eapply term_was_created_preserved; [eapply_prop in_any_log_term_was_created|];
    [|
     intros; simpl in *;
     repeat find_higher_order_rewrite;
     destruct_update; simpl in *; eauto;
     rewrite update_elections_data_appendEntries_leaderLogs; eauto].
    iae_case.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_apply_lem_hyp handleAppendEntries_log. intuition; try in_aer.
      + repeat find_rewrite. eauto.
      + repeat find_rewrite. do_in_app. intuition; try in_aer.
        eauto using removeAfterIndex_in.
    - find_eapply_lem_hyp handleAppendEntries_not_append_entries.
      find_apply_hyp_hyp. intuition.
      + match goal with
          | _ : In ?p' (_ ++ _) |- _ => eapply @in_aer with (p := p'); eauto
        end.
      + subst. simpl in *.
        find_false. unfold mEntries in *.
        break_match; try congruence. subst.
        repeat eexists; eauto.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_rewrite_lem update_elections_data_appendEntries_leaderLogs.
      eauto.
  Qed.

  Lemma in_any_log_term_was_created_request_vote :
    refined_raft_net_invariant_request_vote in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    eapply term_was_created_preserved; [eapply_prop in_any_log_term_was_created|];
    [|
     intros; simpl in *;
     repeat find_higher_order_rewrite;
     destruct_update; simpl in *; eauto;
     rewrite leaderLogs_update_elections_data_requestVote; eauto].
    iae_case.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_apply_lem_hyp handleRequestVote_log.
      repeat find_rewrite. eauto.
    - find_eapply_lem_hyp handleRequestVote_no_append_entries.
      find_apply_hyp_hyp. intuition.
      + match goal with
          | _ : In ?p' (_ ++ _) |- _ => eapply @in_aer with (p := p'); eauto
        end.
      + subst. simpl in *.
        find_false. unfold mEntries in *.
        break_match; try congruence. subst.
        repeat eexists; eauto.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_rewrite_lem leaderLogs_update_elections_data_requestVote.
      eauto.
  Qed.

  Lemma in_any_log_term_was_created_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    eapply term_was_created_preserved; [eapply_prop in_any_log_term_was_created|];
    [|
     intros; simpl in *;
     repeat find_higher_order_rewrite;
     destruct_update; simpl in *; eauto].
    iae_case.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_apply_lem_hyp handleAppendEntriesReply_log.
      repeat find_rewrite. eauto.
    - find_eapply_lem_hyp handleAppendEntriesReply_packets.
      find_apply_hyp_hyp. intuition.
      + match goal with
          | _ : In ?p' (_ ++ _) |- _ => eapply @in_aer with (p := p'); eauto
        end.
      + subst. simpl in *. intuition.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
  Qed.

  Lemma in_any_log_term_was_created_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    eapply term_was_created_preserved; [eapply_prop in_any_log_term_was_created|];
    [|intros; simpl in *;
      repeat find_higher_order_rewrite;
      destruct_update; simpl in *; eauto;
      eapply update_elections_data_requestVoteReply_old; eauto].
    iae_case.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_rewrite_lem handleRequestVoteReply_log_rewrite; eauto.
    - find_apply_hyp_hyp.
      match goal with
        | _ : In ?p' (_ ++ _) |- _ => eapply @in_aer with (p := p'); eauto
      end.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_eapply_lem_hyp leaderLogs_update_elections_data_RVR; eauto.
      intuition; eauto. subst.
      find_rewrite_lem handleRequestVoteReply_log_rewrite. eauto.
  Qed.

  Ltac cr_in_log_in_leader_log :=
    find_eapply_lem_hyp in_log; eapply_prop_hyp in_any_log_term_was_created in_any_log;
    unfold term_was_created in *;
    break_exists_exists;
    find_higher_order_rewrite;
    destruct_update; simpl in *; eauto;
    rewrite update_elections_data_client_request_leaderLogs; eauto.

  Ltac cr_in_aer_in_leader_log :=
    find_eapply_lem_hyp in_aer; eauto; eapply_prop_hyp in_any_log_term_was_created in_any_log;
    unfold term_was_created in *;
    break_exists_exists;
    find_higher_order_rewrite;
    destruct_update; simpl in *; eauto;
    rewrite update_elections_data_client_request_leaderLogs; eauto.

  Ltac cr_in_ll_in_leader_log :=
    find_eapply_lem_hyp in_ll; eauto; eapply_prop_hyp in_any_log_term_was_created in_any_log;
    unfold term_was_created in *;
    break_exists_exists;
    find_higher_order_rewrite;
    destruct_update; simpl in *; eauto;
    rewrite update_elections_data_client_request_leaderLogs; eauto.

  Lemma in_any_log_term_was_created_client_request :
    refined_raft_net_invariant_client_request in_any_log_term_was_created.
  Proof using lhlli.
    red. intros. unfold in_any_log_term_was_created. intros.
    iae_case.
    - unfold term_was_created. simpl in *.
      find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      + find_apply_lem_hyp handleClientRequest_log.
        intuition; subst; repeat find_rewrite; try cr_in_log_in_leader_log.
        break_exists. intuition.
        repeat find_rewrite. simpl in *. intuition; subst.
        * find_eapply_lem_hyp leaders_have_leaderLogs_invariant; eauto.
          match goal with
            | [h : name |- _ ] => (exists h)
          end.
          break_exists_exists.
          repeat find_rewrite.
          repeat find_higher_order_rewrite.
          rewrite update_eq; auto. simpl.
          rewrite update_elections_data_client_request_leaderLogs.
          auto.
        * cr_in_log_in_leader_log.
      + cr_in_log_in_leader_log.
    - find_apply_hyp_hyp. intuition.
      + cr_in_aer_in_leader_log.
      + do_in_map. subst.
        find_eapply_lem_hyp handleClientRequest_no_append_entries; eauto.
        simpl in *.
        intuition. find_false.
        unfold mEntries in *. break_match; try congruence.
        repeat eexists; eauto.
    - find_higher_order_rewrite.
      destruct_update; simpl in *.
      + find_rewrite_lem update_elections_data_client_request_leaderLogs.
        cr_in_ll_in_leader_log.
      + cr_in_ll_in_leader_log.
  Qed.

  Lemma in_any_log_term_was_created_timeout :
    refined_raft_net_invariant_timeout in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    eapply term_was_created_preserved; [eapply_prop in_any_log_term_was_created|];
    [|intros; simpl in *;
      repeat find_higher_order_rewrite;
      destruct_update; simpl in *; eauto;
      rewrite update_elections_data_timeout_leaderLogs; eauto].
    iae_case.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_eapply_lem_hyp handleTimeout_log_same; eauto.
      repeat find_rewrite. eauto.
    - find_apply_hyp_hyp. intuition; eauto.
      do_in_map. subst. simpl in *.
      find_eapply_lem_hyp handleTimeout_not_is_append_entries; eauto.
      intuition. find_false.
      unfold mEntries in *. break_match; try congruence.
      repeat eexists; eauto.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_rewrite_lem update_elections_data_timeout_leaderLogs; eauto.
  Qed.

  Lemma in_any_log_term_was_created_do_leader :
    refined_raft_net_invariant_do_leader in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    eapply term_was_created_preserved; [eapply_prop in_any_log_term_was_created|];
    [|intros; simpl in *;
      repeat find_higher_order_rewrite;
      destruct_update; simpl in *; eauto].
    iae_case.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_eapply_lem_hyp doLeader_log; eauto.
      repeat find_rewrite. eauto.
    - find_apply_hyp_hyp. intuition; eauto.
      do_in_map. subst. simpl in *.
      unfold mEntries in *. break_match; try congruence.
      find_inversion.
      find_eapply_lem_hyp doLeader_message_entries; eauto.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
  Qed.

  Lemma in_any_log_term_was_created_do_generic_server :
    refined_raft_net_invariant_do_generic_server in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    eapply term_was_created_preserved; [eapply_prop in_any_log_term_was_created|];
    [|intros; simpl in *;
      repeat find_higher_order_rewrite;
      destruct_update; simpl in *; eauto].
    iae_case.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
      find_eapply_lem_hyp doGenericServer_log; eauto.
      repeat find_rewrite. eauto.
    - find_apply_hyp_hyp. intuition; eauto.
      do_in_map. subst. simpl in *.
      find_apply_lem_hyp doGenericServer_packets. subst.
      simpl in *. intuition.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *; eauto.
  Qed.

  Lemma in_any_log_term_was_created_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset in_any_log_term_was_created.
  Proof using.
    red. intros. unfold in_any_log_term_was_created. intros.
    unfold in_any_log_term_was_created, term_was_created in *.
    iae_case.
    - repeat find_reverse_higher_order_rewrite.
      find_eapply_lem_hyp in_log.
      eapply_prop_hyp in_any_log in_any_log.
      break_exists_exists; repeat find_higher_order_rewrite; eauto.
    - find_apply_hyp_hyp.
      find_eapply_lem_hyp in_aer; eauto.
      eapply_prop_hyp in_any_log in_any_log.
      break_exists_exists; repeat find_higher_order_rewrite; eauto.
    - repeat find_reverse_higher_order_rewrite.
      find_eapply_lem_hyp in_ll; eauto.
      eapply_prop_hyp in_any_log in_any_log.
      break_exists_exists; repeat find_higher_order_rewrite; eauto.
  Qed.

  Lemma in_any_log_term_was_created_reboot :
    refined_raft_net_invariant_reboot in_any_log_term_was_created.
  Proof using.
    red. unfold in_any_log_term_was_created, term_was_created. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    iae_case; eauto.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *;
      find_apply_lem_hyp in_log;
      eapply_prop_hyp in_any_log in_any_log;
      break_exists_exists;
      repeat find_higher_order_rewrite;
      destruct_update; simpl in *; eauto.
    - repeat find_reverse_rewrite.
      find_eapply_lem_hyp in_aer; eauto.
      eapply_prop_hyp in_any_log in_any_log;
      break_exists_exists;
      repeat find_higher_order_rewrite;
      destruct_update; simpl in *; eauto.
    - repeat find_higher_order_rewrite.
      destruct_update; simpl in *;
      find_eapply_lem_hyp in_ll; eauto;
      eapply_prop_hyp in_any_log in_any_log;
      break_exists_exists;
      repeat find_higher_order_rewrite;
      destruct_update; simpl in *; eauto.
  Qed.

  Lemma in_any_log_term_was_created_init :
    refined_raft_net_invariant_init in_any_log_term_was_created.
  Proof using.
    red. unfold in_any_log_term_was_created. intros.
    iae_case; intuition.
  Qed.

  Theorem in_any_log_term_was_created_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      in_any_log_term_was_created net.
  Proof using lhlli rri.
    intros.
    eapply refined_raft_net_invariant; eauto.
    - exact in_any_log_term_was_created_init.
    - exact in_any_log_term_was_created_client_request.
    - exact in_any_log_term_was_created_timeout.
    - exact in_any_log_term_was_created_append_entries.
    - exact in_any_log_term_was_created_append_entries_reply.
    - exact in_any_log_term_was_created_request_vote.
    - exact in_any_log_term_was_created_request_vote_reply.
    - exact in_any_log_term_was_created_do_leader.
    - exact in_any_log_term_was_created_do_generic_server.
    - exact in_any_log_term_was_created_state_same_packet_subset.
    - exact in_any_log_term_was_created_reboot.
  Qed.

  Instance eewci : every_entry_was_created_interface.
  split.
  - unfold every_entry_was_created. intros.
    apply in_any_log_term_was_created_invariant; eauto.
  - intros. apply in_any_log_term_was_created_invariant; auto.
  Qed.

End EveryEntryWasCreated.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Program.
Require Import String.
Require Import List.
Require Import Arith.
Require Import Utils.
Require Import DataSystem.
Require Import cNNRCSystem.
Require Import NNRC.
Require Import NNRCEq.
Require Import TNNRC.

Section TNNRCEq.
  (* A type-safe equivalence for rewrites *)

  Context {m:basic_model}.

  Definition tnnrc_rewrites_to (e1 e2:nnrc) : Prop :=
    forall (τcenv τenv : tbindings) (τout:rtype),
      nnrc_type τcenv τenv e1 τout ->
      (nnrc_type τcenv τenv e2 τout)
      /\ (forall (cenv:bindings),
          forall (env:bindings),
             bindings_type cenv τcenv ->
             bindings_type env τenv ->
             @nnrc_eval _ brand_relation_brands cenv env e1
             = @nnrc_eval _ brand_relation_brands cenv env e2).

  Notation "e1 ⇒ᶜ e2" := (tnnrc_rewrites_to e1 e2) (at level 80).

  Open Scope nnrc_scope.

  Lemma data_normalized_bindings_type_map env τenv :
    bindings_type env τenv ->
    Forall (data_normalized brand_relation_brands) (map snd env).
  Proof.
    rewrite Forall_map.
    apply bindings_type_Forall_normalized.
  Qed.

  Hint Resolve data_normalized_bindings_type_map : qcert.

  Lemma nnrc_rewrites_typed_with_untyped (e1 e2:nnrc) :
    e1 ≡ᶜ e2 ->
    (forall {τcenv: tbindings}
            {τenv: tbindings}
            {τout:rtype}, nnrc_type τcenv τenv e1 τout -> nnrc_type τcenv τenv e2 τout)
    -> e1 ⇒ᶜ e2.
  Proof.
    intros.
    unfold tnnrc_rewrites_to; simpl; intros.
    split; auto 2; intros.
    apply H; qeauto.
  Qed.

  (****************
   * Proper stuff *
   ****************)

  Hint Constructors nnrc_core_type : qcert.
  Hint Constructors unary_op_type : qcert.
  Hint Constructors binary_op_type : qcert.

  Global Instance tnnrc_rewrites_to_pre : PreOrder tnnrc_rewrites_to.
  Proof.
    constructor; red; intros.
    - unfold tnnrc_rewrites_to; intros.
      split; try assumption; intros.
      reflexivity.
    - unfold tnnrc_rewrites_to in *; intros.
      specialize (H τcenv τenv τout H1).
      elim H; clear H; intros.
      specialize (H0 τcenv τenv τout H).
      elim H0; clear H0; intros.
      split; try assumption; intros.
      rewrite (H2 cenv env); try assumption.
      rewrite (H3 cenv env); try assumption.
      reflexivity.
  Qed.
  (* NNRCGetConstant *)

  Global Instance tproper_NNRCGetConstant:
    Proper (eq ==> tnnrc_rewrites_to) NNRCGetConstant.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    rewrite <- H.
    split; try assumption.
    intros; reflexivity.
  Qed.

  (* NNRCVar *)

  Global Instance tproper_NNRCVar:
    Proper (eq ==> tnnrc_rewrites_to) NNRCVar.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    rewrite <- H.
    split; try assumption.
    intros; reflexivity.
  Qed.

  (* NNRCConst *)

  Global Instance tproper_NNRCConst:
    Proper (eq ==> tnnrc_rewrites_to) NNRCConst.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    rewrite <- H.
    split; try assumption.
    intros; reflexivity.
  Qed.

  (* NNRCBinop *)

  Global Instance tproper_NNRCBinop:
    Proper (eq ==> tnnrc_rewrites_to
               ==> tnnrc_rewrites_to
               ==> tnnrc_rewrites_to) NNRCBinop.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    rewrite H in *; clear H.
    inversion H2; clear H2; subst.
    econstructor; eauto.
    specialize (H0 τcenv τenv τ₁ H8); elim H0; clear H0 H8; intros.
    specialize (H1 τcenv τenv τ₂ H9); elim H1; clear H1 H9; intros.
    econstructor; eauto; intros.
    intros.
    specialize (H0 τcenv τenv τ₁ H8); elim H0; clear H0 H8; intros.
    specialize (H1 τcenv τenv τ₂ H9); elim H1; clear H1 H9; intros.
    unfold nnrc_eval in *.
    simpl.
    rewrite (H3 cenv env H H2); rewrite (H4 cenv env H H2); reflexivity.
  Qed.

  (* NNRCUnop *)

  Global Instance tproper_NNRCUnop :
    Proper (eq ==> tnnrc_rewrites_to ==> tnnrc_rewrites_to) NNRCUnop.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    rewrite H in *; clear H.
    inversion H1; clear H1; subst.
    econstructor; eauto.
    econstructor; eauto.
    specialize (H0 τcenv τenv τ₁ H6); elim H0; clear H0 H6; intros; assumption.
    intros.
    specialize (H0 τcenv τenv τ₁ H6); elim H0; clear H0 H6; intros.
    unfold nnrc_eval in *.
    simpl. rewrite (H2 cenv env H H1); reflexivity.
  Qed.

  (* NNRCLet *)

  Global Instance tproper_NNRCLet :
    Proper (eq ==> tnnrc_rewrites_to ==> tnnrc_rewrites_to ==> tnnrc_rewrites_to) NNRCLet.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    unfold nnrc_eval,nnrc_type in *.
    inversion H2; clear H2; subst.
    specialize (H0 τcenv τenv τ₁ H8); elim H0; clear H0 H8; intros.
    specialize (H1 τcenv ((y, τ₁) :: τenv) τout H9); elim H1; clear H1 H9; intros.
    econstructor; eauto.
    econstructor; eauto.
    intros; simpl.
    rewrite (H0 cenv env H3 H4).
    case_eq (nnrc_core_eval brand_relation_brands cenv env (nnrc_to_nnrc_base y0));
      intros; try reflexivity.
    rewrite (H2 cenv ((y, d) :: env) H3); try reflexivity.
    unfold bindings_type.
    apply Forall2_cons; try assumption.
    simpl; split; try reflexivity.
    generalize (@typed_nnrc_yields_typed_data _ τcenv τ₁ cenv env τenv y0 H3 H4 H); intros.
    elim H6; intros.
    elim H7; clear H7; intros.
    unfold nnrc_eval,nnrc_type in *.
    rewrite H5 in H7.
    inversion H7; assumption.
  Qed.

  (* NNRCFor *)

  Lemma dcoll_wt (l:list data) (τ:rtype) (τcenv τenv:tbindings) (cenv env:bindings) (e:nnrc):
    bindings_type cenv τcenv ->
    bindings_type env τenv ->
    nnrc_core_type τcenv τenv e (Coll τ) ->
    nnrc_core_eval brand_relation_brands cenv env e = Some (dcoll l) ->
    forall x:data, In x l -> (data_type x τ).
  Proof.
    intros.
    generalize (@typed_nnrc_core_yields_typed_data _ τcenv (Coll τ) cenv env τenv e H H0 H1); intros.
    elim H4; clear H4; intros.
    elim H4; clear H4; intros.
    rewrite H4 in H2.
    inversion H2; clear H2.
    subst.
    dependent induction H5.
    rtype_equalizer.
    subst.
    rewrite Forall_forall in H2.
    apply (H2 x0 H3).
  Qed.

  Global Instance tproper_NNRCFor :
    Proper (eq ==> tnnrc_rewrites_to ==> tnnrc_rewrites_to ==> tnnrc_rewrites_to) NNRCFor.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    inversion H2; clear H2; subst.
    specialize (H0 τcenv τenv (Coll τ₁) H8); elim H0; clear H0 H8; intros.
    specialize (H1 τcenv ((y, τ₁) :: τenv) τ₂ H9); elim H1; clear H1 H9; intros.
    econstructor; eauto.
    econstructor; eauto.
    intros; simpl.
    unfold nnrc_eval,nnrc_type in *; simpl.
    rewrite (H0 cenv env H3 H4).
    case_eq (nnrc_core_eval brand_relation_brands cenv env (nnrc_to_nnrc_base y0));
      intros; try reflexivity.
    destruct d; try reflexivity.
    assert (forall x, In x l -> (data_type x τ₁))
      by
        (apply (dcoll_wt l τ₁ τcenv τenv cenv env (nnrc_to_nnrc_base y0)); assumption).
    clear H5 H.
    induction l; try reflexivity.
    simpl in *.
    assert (forall x : data, In x l -> data_type x τ₁)
      by (intros; apply (H6 x); right; assumption).
    specialize (IHl H); clear H.
    rewrite (H2 cenv ((y, a) :: env) H3).
    destruct (nnrc_core_eval brand_relation_brands cenv ((y, a) :: env) (nnrc_to_nnrc_base y1)); try reflexivity.
    - destruct ((lift_map (fun d1 : data => nnrc_core_eval brand_relation_brands cenv ((y, d1) :: env) (nnrc_to_nnrc_base x1)) l));
      destruct ((lift_map (fun d1 : data => nnrc_core_eval brand_relation_brands cenv ((y, d1) :: env) (nnrc_to_nnrc_base y1)) l));
      simpl in *; try congruence.
    - unfold bindings_type.
      apply Forall2_cons; try assumption.
      simpl; split; try reflexivity.
      apply (H6 a); left; reflexivity.
  Qed.

  (* NNRCIf *)
  Global Instance tproper_NNRCIf :
    Proper (tnnrc_rewrites_to ==> tnnrc_rewrites_to
                              ==> tnnrc_rewrites_to
                              ==> tnnrc_rewrites_to) NNRCIf.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    inversion H2; clear H2; subst.
    specialize (H τcenv τenv Bool H7); elim H; clear H H7; intros.
    specialize (H0 τcenv τenv τout H9); elim H0; clear H0 H9; intros.
    specialize (H1 τcenv τenv τout H10); elim H1; clear H1 H10; intros.
    econstructor; eauto.
    econstructor; eauto.
    intros; simpl.
    unfold nnrc_eval,nnrc_type in *; simpl.
    rewrite (H2 cenv env H5 H6). rewrite (H3 cenv env H5 H6). rewrite (H4 cenv env H5 H6).
    reflexivity.
  Qed.

  (* NNRCEither *)
  Global Instance tproper_NNRCEither :
    Proper (tnnrc_rewrites_to ==> eq ==> tnnrc_rewrites_to
                              ==> eq ==> tnnrc_rewrites_to
                              ==> tnnrc_rewrites_to) NNRCEither.
  Proof.
    unfold Proper, respectful, tnnrc_rewrites_to; intros.
    unfold nnrc_eval,nnrc_type in *; simpl.
    subst.
    simpl in H4.
    inversion H4; clear H4; subst.
    destruct (H _ _ _ H10).
    destruct (H1 _ _ _ H11).
    destruct (H3 _ _ _ H12).
    clear H H1 H3.
    simpl.
    split; [qeauto | ]; intros.
    rewrite H2; trivial.
    destruct (@typed_nnrc_core_yields_typed_data _ _ _ _ _ _ _ H H1 H0) as [?[??]].
    rewrite H3.
    apply data_type_Either_inv in H8.
    destruct H8 as [[?[??]]|[?[??]]]; subst.
    - apply (H5 _ _ H). constructor; simpl; intuition; eauto.
    - eapply (H7 _ _ H). constructor; simpl; intuition; eauto.
  Qed.

  (* NNRCGroupBy *)
  Lemma group_by_macro_eq g sl n1 n2 :
    NNRCGroupBy g sl n1 ⇒ᶜ NNRCGroupBy g sl n2
    <-> nnrc_group_by g sl n1 ⇒ᶜ nnrc_group_by g sl n2.
  Proof.
    Opaque nnrc_group_by.
    unfold tnnrc_rewrites_to; intros.
    unfold nnrc_type in *.
    unfold nnrc_eval in *.
    split.
    - simpl. auto.
    - simpl. auto.
    Transparent nnrc_group_by.
  Qed.

  Global Instance tproper_NNRCGroupBy :
    Proper (eq ==> eq ==> tnnrc_rewrites_to ==> tnnrc_rewrites_to) NNRCGroupBy.
  Proof.
    unfold Proper, respectful; intros.
    subst.
    rewrite group_by_macro_eq.
    unfold nnrc_group_by.
    rewrite H1.
    reflexivity.
  Qed.

End TNNRCEq.

Notation "e1 ⇒ᶜ e2" := (tnnrc_rewrites_to e1 e2) (at level 80) : nnrc_scope.


Require Import VerdiRaft.Raft.

Require Import VerdiRaft.LastAppliedLeCommitIndexInterface.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.CommonTheorems.
Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Section LastAppliedLeCommitIndex.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Lemma lastApplied_le_commitIndex_appendEntries :
    raft_net_invariant_append_entries lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleAppendEntries_same_lastApplied.
    repeat find_rewrite.
    find_apply_lem_hyp handleAppendEntries_log_detailed.
    intuition; repeat find_rewrite; eauto;
    eapply Nat.le_trans; eauto; eauto using Nat.le_max_l.
  Qed.

  Lemma lastApplied_le_commitIndex_appendEntriesReply :
    raft_net_invariant_append_entries_reply lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleAppendEntriesReply_same_lastApplied.
    repeat find_rewrite.
    find_copy_apply_lem_hyp handleAppendEntriesReply_same_commitIndex.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_requestVote :
    raft_net_invariant_request_vote lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleRequestVote_same_lastApplied.
    repeat find_rewrite.
    find_copy_apply_lem_hyp handleRequestVote_same_commitIndex.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_requestVoteReply :
    raft_net_invariant_request_vote_reply lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    rewrite handleRequestVoteReply_same_lastApplied.
    rewrite handleRequestVoteReply_same_commitIndex. eauto.
  Qed.

  Lemma doLeader_same_lastApplied:
    forall st (os : list raft_output) (d' : raft_data)
      (ms : list (name * msg)) (h0 : name),
      doLeader st h0 = (os, d', ms) ->
      lastApplied d' = lastApplied st.
  Proof using.
    intros.
    unfold doLeader, advanceCommitIndex in *.
    repeat break_match; simpl in *; find_inversion; auto.
  Qed.

  Lemma fold_left_max :
    forall l y z,
      (forall x, In x l ->
            y <= x) ->
      y <= z ->
      y <= fold_left max l z.
  Proof using.
    induction l; simpl in *; auto.
    intros.
    specialize (IHl y (max z a)).
    forward IHl; eauto. concludes.
    forward IHl; [eapply Nat.le_trans; eauto; eauto using Nat.le_max_l|].
    concludes. auto.
  Qed.

  Lemma advanceCommitIndex_commitIndex :
    forall st h,
      commitIndex st <= commitIndex (advanceCommitIndex st h).
  Proof using.
    intros. unfold advanceCommitIndex. simpl in *.
    apply fold_left_max; auto.
    intros.
    do_in_map. subst.
    find_apply_lem_hyp filter_In.
    repeat (intuition; do_bool).
  Qed.

  Lemma doLeader_same_commitIndex :
    forall st (os : list raft_output) (d' : raft_data)
      (ms : list (name * msg)) (h0 : name),
      doLeader st h0 = (os, d', ms) ->
      commitIndex st <= commitIndex d'.
  Proof using.
    intros.
    unfold doLeader in *.
    repeat break_match; tuple_inversion; auto; eauto using advanceCommitIndex_commitIndex.
    eapply Nat.le_trans; [eapply advanceCommitIndex_commitIndex with (h := h0)|]; eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_doLeader :
    raft_net_invariant_do_leader lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp doLeader_same_lastApplied.
    find_copy_apply_lem_hyp doLeader_same_commitIndex.
    repeat find_rewrite. eapply Nat.le_trans; [|eauto]; eauto.
  Qed.

  Lemma doGenericServer_lastApplied:
    forall (h : name)
      (st : raft_data) (out : list raft_output) (st' : raft_data)
      (ms : list (name * msg)),
      doGenericServer h st = (out, st', ms) ->
      lastApplied st' <= max (lastApplied st) (commitIndex st).
  Proof using.
    intros. unfold doGenericServer in *. break_let. find_inversion.
    simpl in *.
    break_if; simpl in *; do_bool; auto.
    - use_applyEntries_spec. subst. simpl in *.
      eauto using Nat.le_max_r.
    - use_applyEntries_spec. subst. simpl in *.
      eauto using Nat.le_max_l.
  Qed.

  Lemma lastApplied_le_commitIndex_doGenericServer :
    raft_net_invariant_do_generic_server lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp doGenericServer_commitIndex.
    find_copy_apply_lem_hyp doGenericServer_lastApplied.
    repeat find_rewrite.
    erewrite Nat.max_r in *; eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_clientRequest :
    raft_net_invariant_client_request lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleClientRequest_commitIndex.
    find_copy_apply_lem_hyp handleClientRequest_lastApplied.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_timeout :
    raft_net_invariant_timeout lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp handleTimeout_commitIndex.
    find_copy_apply_lem_hyp handleTimeout_lastApplied.
    repeat find_rewrite. eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_reboot :
    raft_net_invariant_reboot lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
  Qed.

  Lemma lastApplied_le_commitIndex_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    subst.
    simpl in *. repeat find_reverse_higher_order_rewrite. auto.
  Qed.

  Lemma lastApplied_le_commitIndex_init :
    raft_net_invariant_init lastApplied_le_commitIndex.
  Proof using.
    red. unfold lastApplied_le_commitIndex. intros.
    simpl in *. auto.
  Qed.

  Theorem lastApplied_le_commitIndex_invariant :
    forall net,
      raft_intermediate_reachable net ->
      lastApplied_le_commitIndex net.
  Proof using.
    intros. apply raft_net_invariant; auto.
    - apply lastApplied_le_commitIndex_init.
    - apply lastApplied_le_commitIndex_clientRequest.
    - apply lastApplied_le_commitIndex_timeout.
    - apply lastApplied_le_commitIndex_appendEntries.
    - apply lastApplied_le_commitIndex_appendEntriesReply.
    - apply lastApplied_le_commitIndex_requestVote.
    - apply lastApplied_le_commitIndex_requestVoteReply.
    - apply lastApplied_le_commitIndex_doLeader.
    - apply lastApplied_le_commitIndex_doGenericServer.
    - apply lastApplied_le_commitIndex_state_same_packet_subset.
    - apply lastApplied_le_commitIndex_reboot.
  Qed.

  Instance lalcii : lastApplied_le_commitIndex_interface.
  split. auto using lastApplied_le_commitIndex_invariant.
  Qed.

End LastAppliedLeCommitIndex.


Require Import PeanoNat Lia List ListSupport.
Require Import Common FMap.
Require Import Syntax Semantics SemFacts StepM Invariant.
Require Import Serial SerialFacts.
Require Import Reduction Commutativity QuasiSeq Topology.
Require Import RqRsTopo RqRsFacts.
Require Import RqRsInvMsg RqRsInvLock RqRsInvAtomic RqRsInvSep.

(* Required to prove serializability *)
Require Import RqRsRed RqUpRed RsUpRed RqDownRed RsDownRed.
(* Required to prove nonmergeability *)
Require Import RqRsInvLockEx.

Set Implicit Arguments.

Open Scope list.
Open Scope fmap.

Section Pushable.
  Context `{dv: DecValue} `{oifc: OStateIfc}.
  Variables (dtr: DTree)
            (sys: System).

  Hypotheses (Hiorqs: GoodORqsInit (initsOf sys))
             (oinvs: IdxT -> ObjInv)
             (Hoinvs: InvReachable sys step_m (liftObjInvs oinvs))
             (Hrrs: RqRsSys dtr sys oinvs).

  Variables (phst: History)
            (oidx ridx: IdxT)
            (rins routs: list (Id Msg)).
  Hypothesis (Hcont: ExtContinuousL sys phst (RlblInt oidx ridx rins routs)).

  Local Definition nlbl := (RlblInt oidx ridx rins routs).

  Section RqUp.
    Hypothesis (Hru: RqUpMsgs dtr oidx rins).

    Lemma rqUp_lpush_unit:
      forall hst,
        AtomicEx hst ->
        Discontinuous phst hst ->
        Reducible sys (hst ++ phst) (phst ++ hst).
    Proof.
      intros.
      destruct H as [inits [ins [outs [eouts ?]]]].
      destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H2; inv H2.
      destruct H1 as [pinits pins phst pouts peouts].
      red in H0; dest.
      pose proof (atomic_unique H0 H2); dest; subst.
      pose proof (atomic_unique H5 H); dest; subst.
      eapply rqUp_lpush_unit_reducible; eauto.
      intro Hx; subst; elim H3; apply SubList_nil.
    Qed.

    Lemma rqUp_LPushableHst: LPushableHst sys phst nlbl.
    Proof.
      intros; red; intros.
      inv H1; clear H8.
      generalize dependent st3.
      induction hsts; simpl; intros; [constructor|].
      inv H0; inv H2.
      rewrite <-app_assoc in H6.
      eapply steps_split in H6; [|reflexivity].
      destruct H6 as [sti [? ?]].
      constructor; eauto.
      intros; eapply rqUp_lpush_unit; eauto.
    Qed.

    Lemma rqUp_WellInterleavedHst: WellInterleavedHst sys phst nlbl.
    Proof.
      apply LPushableHst_WellInterleavedHst; auto.
      eauto using rqUp_LPushableHst.
    Qed.

  End RqUp.

  Section RsUp.
    Hypothesis (Hru: RsUpMsgs dtr oidx rins).

    Definition RsUpP: State -> Prop :=
      fun st => Forall (InMPI st.(st_msgs)) rins.

    Lemma rsUp_PInitializing:
      PInitializing sys RsUpP phst.
    Proof.
      intros; red; intros.
      destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H1; inv H1.
      inv H0.
      red; eapply SubList_forall; [|eassumption].
      eapply atomic_messages_eouts_in; eauto.
    Qed.

    Lemma rsUp_PPreserving:
      forall hst,
        Discontinuous phst hst ->
        PPreserving sys RsUpP hst.
    Proof.
      intros.
      destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H1; inv H1.
      inv H0.
      destruct H as [inits1 [ins1 [outs1 [eouts1 [inits2 [ins2 [outs2 [eouts2 ?]]]]]]]].
      dest.
      eapply atomic_unique in H; [|eassumption]; dest; subst.

      red; intros.
      eapply atomic_messages_ins_ins.
      - eapply H0.
      - eassumption.
      - assumption.
      - eapply DisjList_comm, DisjList_SubList; eauto.
    Qed.

    Lemma rsUp_rpush_unit:
      forall hst,
        AtomicEx hst ->
        Discontinuous phst hst ->
        ReducibleP sys RsUpP (nlbl :: hst) (hst ++ [nlbl]).
    Proof.
      intros.
      destruct H as [inits [ins [outs [eouts ?]]]].
      destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H2; inv H2.
      destruct H1 as [pinits pins phst pouts peouts].
      red in H0; dest.
      pose proof (atomic_unique H0 H2); dest; subst.
      pose proof (atomic_unique H5 H); dest; subst.
      eapply rsUp_rpush_unit_reducible; eauto.
      - intro Hx; subst; elim H3; apply SubList_nil.
      - eapply DisjList_SubList; eauto.
    Qed.

    Lemma rsUp_RPushableHst:
      RPushableHst sys RsUpP phst nlbl.
    Proof.
      intros; red; intros.
      inv H1.
      eapply steps_split in H6; [|reflexivity].
      destruct H6 as [st4 [? ?]]; clear H1.
      generalize dependent st4.
      induction hsts as [|hst hsts] using list_ind_rev;
        simpl; intros; [constructor|].

      apply Forall_app_inv in H0; dest.
      inv H1; clear H7.
      apply Forall_app_inv in H2; dest.
      inv H2; clear H9.

      rewrite concat_app in H3; simpl in H3.
      rewrite app_nil_r in H3.
      eapply steps_split in H3; [|reflexivity].
      destruct H3 as [sti [? ?]].

      apply Forall_app; eauto.
      constructor; auto.
      split.
      - apply rsUp_PPreserving; auto.
      - intros; eapply rsUp_rpush_unit; eauto.
    Qed.

    Lemma rsUp_WellInterleavedHst:
      WellInterleavedHst sys phst nlbl.
    Proof.
      apply RPushableHst_WellInterleavedHst with (P:= RsUpP); auto.
      - eauto using rsUp_PInitializing.
      - eauto using rsUp_RPushableHst.
    Qed.

  End RsUp.

  Section RqDown.
    Variable pobj: Object.
    Hypothesis (Hrd: RqDownMsgs dtr sys oidx rins)
               (Hpobj: In pobj sys.(sys_objs))
               (Hcp: parentIdxOf dtr oidx = Some (obj_idx pobj)).

    Definition RqDownLPush (hst: History) :=
      exists loidx,
        lastOIdxOf hst = Some loidx /\
        In loidx (subtreeIndsOf dtr oidx).

    Definition RqDownRPush (hst: History) :=
      exists loidx,
        lastOIdxOf hst = Some loidx /\
        ~ In loidx (subtreeIndsOf dtr oidx).

    Lemma rqDown_PInitializing:
      PInitializing sys (RqDownP rins) phst.
    Proof.
      intros; red; intros.
      destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H1; inv H1.
      inv H0.
      red; eapply SubList_forall; [|eassumption].
      eapply atomic_messages_eouts_in; eauto.
    Qed.

    Lemma rqDown_discontinuous_PPreserving:
      forall hst,
        Discontinuous phst hst ->
        PPreserving sys RsUpP hst.
    Proof.
      intros.
      destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H1; inv H1.

      inv H0.
      destruct H as [inits1 [ins1 [outs1 [eouts1 [inits2 [ins2 [outs2 [eouts2 ?]]]]]]]].
      dest.
      eapply atomic_unique in H; [|eassumption]; dest; subst.

      red; intros.
      eapply atomic_messages_ins_ins.
      - eapply H0.
      - eassumption.
      - assumption.
      - eapply DisjList_comm, DisjList_SubList; eauto.
    Qed.

    Lemma rqDown_PPreserving:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (PPreserving sys (RqDownP rins)) hsts.
    Proof.
      intros.
      eapply Forall_impl; [|eapply H2].
      simpl; intros hst ?.
      eapply rqDown_discontinuous_PPreserving; assumption.
    Qed.

    Lemma rqDown_lpush_or_rpush:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (fun hst => RqDownLPush hst \/ RqDownRPush hst) hsts.
    Proof.
      intros; clear -H0.
      rewrite Forall_forall in H0.
      apply Forall_forall.
      intros hst ?.
      specialize (H0 _ H).
      destruct H0 as [inits [ints [outs [eouts ?]]]].
      apply atomic_lastOIdxOf in H0.
      destruct H0 as [loidx ?].
      destruct (in_dec idx_dec loidx (subtreeIndsOf dtr oidx)).
      - left; red; eauto.
      - right; red; eauto.
    Qed.

    Lemma rqDown_lpush_unit:
      forall hst,
        AtomicEx hst ->
        Discontinuous phst hst ->
        RqDownLPush hst ->
        Reducible sys (hst ++ phst) (phst ++ hst).
    Proof.
      intros.
      destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H3; inv H3.
      inv H2.
      destruct H0 as [inits1 [ins1 [outs1 [eouts1 ?]]]].
      destruct H0 as [inits2 [ins2 [outs2 [eouts2 ?]]]]; dest.
      pose proof (atomic_unique H6 H0); dest; subst; clear H0.
      destruct H1 as [loidx [? ?]].
      eapply rqDown_lpush_unit_reducible; eauto.
      apply rqDown_PInitializing.
    Qed.

    Lemma rqDown_lpush_reducible:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (fun hst => RqDownLPush hst ->
                             Reducible sys (hst ++ phst) (phst ++ hst)) hsts.
    Proof.
      intros.
      inv_steps.
      eapply steps_split in H6; [|reflexivity].
      destruct H6 as [sti [? ?]].
      clear H8.
      generalize dependent st3.
      induction hsts as [|hst hsts]; simpl; intros; [constructor|].
      inv H0; inv H2.
      eapply steps_split in H3; [|reflexivity].
      destruct H3 as [hsti [? ?]].
      specialize (IHhsts H7 H8 _ H0).
      constructor; [|assumption].
      intros; apply rqDown_lpush_unit; auto.
    Qed.

    Lemma rqDown_rpush_unit:
      forall hst,
        RqDownRPush hst ->
        AtomicEx hst ->
        Discontinuous phst hst ->
        ReducibleP sys (RqDownP rins) (nlbl :: hst) (hst ++ [nlbl]).
    Proof.
      intros.
      destruct H0 as [inits [ins [outs [eouts ?]]]].
      destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H3; inv H3.
      destruct H2 as [pinits pins phst pouts peouts].
      red in H1; dest.
      pose proof (atomic_unique H1 H3); dest; subst; clear H3.
      pose proof (atomic_unique H6 H0); dest; subst; clear H6.
      destruct H as [loidx [? ?]].
      eapply rqDown_rpush_unit_reducible; eauto.
      eapply DisjList_SubList; eauto.
    Qed.

    Lemma rqDown_rpush_reducible:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (fun hst => RqDownRPush hst ->
                             ReducibleP sys (RqDownP rins) (nlbl :: hst) (hst ++ [nlbl])) hsts.
    Proof.
      intros.
      clear H1.
      induction hsts as [|hst hsts]; simpl; intros; [constructor|].
      inv H0; inv H2.
      constructor; eauto.
      intros; eapply rqDown_rpush_unit; eauto.
    Qed.

    Lemma rqDown_LRPushable:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          LRPushable sys (RqDownP rins) RqDownLPush RqDownRPush hsts.
    Proof.
      intros; red; intros; subst.
      apply Forall_app_inv in H0; dest.
      inv H3; destruct H8 as [inits1 [ins1 [outs1 [eouts1 ?]]]].
      apply Forall_app_inv in H9; dest.
      inv H7; destruct H10 as [inits2 [ins2 [outs2 [eouts2 ?]]]].
      destruct H4 as [lloidx [? ?]].
      destruct H5 as [rloidx [? ?]].

      assert (DisjList rins inits1 /\ DisjList rins inits2).
      { destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
        apply eq_sym in H12; inv H12.
        apply Forall_app_inv in H2; dest.
        inv H12; apply Forall_app_inv in H18; dest.
        inv H15.
        red in H17, H19; dest.
        pose proof (atomic_unique H19 H3); dest; subst; clear H19.
        pose proof (atomic_unique H16 H7); dest; subst; clear H16.
        inv H10.
        pose proof (atomic_unique H17 H19); dest; subst; clear H17.
        pose proof (atomic_unique H15 H19); dest; subst; clear H15.
        split; eapply DisjList_SubList; eassumption.
      }
      destruct H10.
      eapply rqDown_LRPushable_unit_reducible; try eassumption.
    Qed.

    Lemma rqDown_WellInterleavedHst:
      WellInterleavedHst sys phst nlbl.
    Proof.
      apply PushableHst_WellInterleavedHst with (P:= RqDownP rins); auto.
      - eauto using rqDown_PInitializing.
      - exists RqDownLPush, RqDownRPush.
        intros; repeat split.
        + eauto using rqDown_PPreserving.
        + eauto using rqDown_lpush_or_rpush.
        + eauto using rqDown_lpush_reducible.
        + eauto using rqDown_rpush_reducible.
        + eauto using rqDown_LRPushable.
    Qed.

  End RqDown.

  Section RsDown.
    Variable pobj: Object.
    Hypothesis (Hrd: RsDownMsgs dtr sys oidx rins)
               (Hpobj: In pobj sys.(sys_objs))
               (Hcp: parentIdxOf dtr oidx = Some (obj_idx pobj)).

    Definition RsDownLPush (hst: History) :=
      exists loidx,
        lastOIdxOf hst = Some loidx /\
        In loidx (subtreeIndsOf dtr oidx).

    Definition RsDownRPush (hst: History) :=
      exists loidx,
        lastOIdxOf hst = Some loidx /\
        ~ In loidx (subtreeIndsOf dtr oidx).

    Lemma rsDown_PInitializing:
      PInitializing sys (RsDownP rins) phst.
    Proof.
      intros; red; intros.
      destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H1; inv H1.
      inv H0.
      red; eapply SubList_forall; [|eassumption].
      eapply atomic_messages_eouts_in; eauto.
    Qed.

    Lemma rsDown_discontinuous_PPreserving:
      forall hst,
        Discontinuous phst hst ->
        PPreserving sys RsUpP hst.
    Proof.
      intros.
      destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H1; inv H1.

      inv H0.
      destruct H as [inits1 [ins1 [outs1 [eouts1 [inits2 [ins2 [outs2 [eouts2 ?]]]]]]]].
      dest.
      eapply atomic_unique in H; [|eassumption]; dest; subst.

      red; intros.
      eapply atomic_messages_ins_ins.
      - eapply H0.
      - eassumption.
      - assumption.
      - eapply DisjList_comm, DisjList_SubList; eauto.
    Qed.

    Lemma rsDown_PPreserving:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (PPreserving sys (RsDownP rins)) hsts.
    Proof.
      intros.
      eapply Forall_impl; [|eapply H2].
      simpl; intros hst ?.
      eapply rsDown_discontinuous_PPreserving; assumption.
    Qed.

    Lemma rsDown_lpush_or_rpush:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (fun hst => RsDownLPush hst \/ RsDownRPush hst) hsts.
    Proof.
      intros; clear -H0.
      rewrite Forall_forall in H0.
      apply Forall_forall.
      intros hst ?.
      specialize (H0 _ H).
      destruct H0 as [inits [ints [outs [eouts ?]]]].
      apply atomic_lastOIdxOf in H0.
      destruct H0 as [loidx ?].
      destruct (in_dec idx_dec loidx (subtreeIndsOf dtr oidx)).
      - left; red; eauto.
      - right; red; eauto.
    Qed.

    Lemma rsDown_lpush_unit:
      forall hst,
        AtomicEx hst ->
        Discontinuous phst hst ->
        RsDownLPush hst ->
        Reducible sys (hst ++ phst) (phst ++ hst).
    Proof.
      intros.
      destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H3; inv H3.
      inv H2.
      destruct H0 as [inits1 [ins1 [outs1 [eouts1 ?]]]].
      destruct H0 as [inits2 [ins2 [outs2 [eouts2 ?]]]]; dest.
      pose proof (atomic_unique H6 H0); dest; subst; clear H0.
      destruct H1 as [loidx [? ?]].
      eapply rsDown_lpush_unit_reducible; eauto.
      apply rsDown_PInitializing.
    Qed.

    Lemma rsDown_lpush_reducible:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (fun hst => RsDownLPush hst ->
                             Reducible sys (hst ++ phst) (phst ++ hst)) hsts.
    Proof.
      intros.
      inv_steps.
      eapply steps_split in H6; [|reflexivity].
      destruct H6 as [sti [? ?]].
      clear H8.
      generalize dependent st3.
      induction hsts as [|hst hsts]; simpl; intros; [constructor|].
      inv H0; inv H2.
      eapply steps_split in H3; [|reflexivity].
      destruct H3 as [hsti [? ?]].
      specialize (IHhsts H7 H8 _ H0).
      constructor; [|assumption].
      intros; apply rsDown_lpush_unit; auto.
    Qed.

    Lemma rsDown_rpush_unit:
      forall hst,
        RsDownRPush hst ->
        AtomicEx hst ->
        Discontinuous phst hst ->
        ReducibleP sys (RsDownP rins) (nlbl :: hst) (hst ++ [nlbl]).
    Proof.
      intros.
      destruct H0 as [inits [ins [outs [eouts ?]]]].
      destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
      apply eq_sym in H3; inv H3.
      destruct H2 as [pinits pins phst pouts peouts].
      red in H1; dest.
      pose proof (atomic_unique H1 H3); dest; subst; clear H3.
      pose proof (atomic_unique H6 H0); dest; subst; clear H6.
      destruct H as [loidx [? ?]].
      eapply rsDown_rpush_unit_reducible; eauto.
      eapply DisjList_SubList; eauto.
    Qed.

    Lemma rsDown_rpush_reducible:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          Forall (fun hst => RsDownRPush hst ->
                             ReducibleP sys (RsDownP rins) (nlbl :: hst) (hst ++ [nlbl])) hsts.
    Proof.
      intros.
      clear H1.
      induction hsts as [|hst hsts]; simpl; intros; [constructor|].
      inv H0; inv H2.
      constructor; eauto.
      intros; eapply rsDown_rpush_unit; eauto.
    Qed.

    Lemma rsDown_LRPushable:
      forall st1,
        Reachable (steps step_m) sys st1 ->
        forall hsts st2,
          Forall AtomicEx hsts ->
          steps step_m sys st1 (nlbl :: List.concat hsts ++ phst) st2 ->
          Forall (fun hst => Discontinuous phst hst) hsts ->
          LRPushable sys (RsDownP rins) RsDownLPush RsDownRPush hsts.
    Proof.
      intros; red; intros; subst.
      apply Forall_app_inv in H0; dest.
      inv H3; destruct H8 as [inits1 [ins1 [outs1 [eouts1 ?]]]].
      apply Forall_app_inv in H9; dest.
      inv H7; destruct H10 as [inits2 [ins2 [outs2 [eouts2 ?]]]].
      destruct H4 as [lloidx [? ?]].
      destruct H5 as [rloidx [? ?]].

      assert (DisjList rins inits1 /\ DisjList rins inits2).
      { destruct Hcont as [peouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
        apply eq_sym in H12; inv H12.
        apply Forall_app_inv in H2; dest.
        inv H12; apply Forall_app_inv in H18; dest.
        inv H15.
        red in H17, H19; dest.
        pose proof (atomic_unique H19 H3); dest; subst; clear H19.
        pose proof (atomic_unique H16 H7); dest; subst; clear H16.
        inv H10.
        pose proof (atomic_unique H17 H19); dest; subst; clear H17.
        pose proof (atomic_unique H15 H19); dest; subst; clear H15.
        split; eapply DisjList_SubList; eassumption.
      }
      destruct H10.
      eapply rsDown_LRPushable_unit_reducible; try eassumption.
    Qed.

    Lemma rsDown_WellInterleavedHst:
      WellInterleavedHst sys phst nlbl.
    Proof.
      apply PushableHst_WellInterleavedHst with (P:= RqDownP rins); auto.
      - eauto using rsDown_PInitializing.
      - exists RqDownLPush, RqDownRPush.
        intros; repeat split.
        + eauto using rsDown_PPreserving.
        + eauto using rsDown_lpush_or_rpush.
        + eauto using rsDown_lpush_reducible.
        + eauto using rsDown_rpush_reducible.
        + eauto using rsDown_LRPushable.
    Qed.

  End RsDown.

  Lemma rqDown_ExtContinuousL_parent_in_system:
    RqDownMsgs dtr sys oidx rins ->
    forall st1,
      Reachable (steps step_m) sys st1 ->
      forall st2,
        steps step_m sys st1 phst st2 ->
        exists pobj,
          In pobj (sys_objs sys) /\
          parentIdxOf dtr oidx = Some (obj_idx pobj).
  Proof.
    destruct Hrrs as [? [? ?]]; intros.
    destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
    apply eq_sym in H6; inv H6.
    destruct H5 as [pinits pins phst pouts peouts].
    destruct H2 as [cobj [rqDown ?]]; dest; subst.
    pose proof (edgeDownTo_Some (proj1 (proj2 H)) _ H10).
    destruct H2 as [rqUp [rsUp [pidx ?]]]; dest.
    eapply atomic_down_out_in_history in H6; eauto.
    - eapply steps_object_in_system in H6; eauto.
      destruct H6 as [pobj [? ?]]; subst.
      exists pobj; auto.
    - apply SubList_singleton_In in H8.
      apply in_map; assumption.
  Qed.

  Lemma rsDown_ExtContinuousL_parent_in_system:
    RsDownMsgs dtr sys oidx rins ->
    forall st1,
      Reachable (steps step_m) sys st1 ->
      forall st2,
        steps step_m sys st1 phst st2 ->
        exists pobj,
          In pobj (sys_objs sys) /\
          parentIdxOf dtr oidx = Some (obj_idx pobj).
  Proof.
    destruct Hrrs as [? [? ?]]; intros.
    destruct Hcont as [eouts [oidx' [ridx' [rins' [routs' ?]]]]]; dest.
    apply eq_sym in H6; inv H6.
    destruct H5 as [pinits pins phst pouts peouts].
    destruct H2 as [cobj [rsDown ?]]; dest; subst.
    pose proof (edgeDownTo_Some (proj1 (proj2 H)) _ H10).
    destruct H2 as [rqUp [rsUp [pidx ?]]]; dest.
    eapply atomic_down_out_in_history in H6; eauto.
    - eapply steps_object_in_system in H6; eauto.
      destruct H6 as [pobj [? ?]]; subst.
      exists pobj; auto.
    - apply SubList_singleton_In in H8.
      apply in_map; assumption.
  Qed.

End Pushable.

Theorem rqrs_WellInterleaved:
  forall `{dv: DecValue} `{oifc: OStateIfc} (sys: System)
         (Hiorqs: GoodORqsInit (initsOf sys)) (dtr: DTree)
         (oinvs: IdxT -> ObjInv)
         (Hoinvs: InvReachable sys step_m (liftObjInvs oinvs)),
    RqRsSys dtr sys oinvs ->
    WellInterleaved sys.
Proof.
  intros; red; intros.
  red; intros.

  assert (exists oidx ridx rins routs,
             l2 = RlblInt oidx ridx rins routs /\
             (RqUpMsgs dtr oidx rins \/
              RqDownMsgs dtr sys oidx rins \/
              RsUpMsgs dtr oidx rins \/
              RsDownMsgs dtr sys oidx rins)) as Hnlbl.
  { destruct H as [? [? ?]].
    red in H0.
    destruct H0 as [eouts [oidx [ridx [rins [routs ?]]]]]; dest; subst.
    inv H2.
    eapply messages_in_cases in H14; eauto.
    eauto 6.
  }
  destruct Hnlbl as [oidx [ridx [rins [routs ?]]]]; dest; subst.

  destruct H6 as [|[|[|]]].
  - eapply rqUp_WellInterleavedHst; eauto.
  - assert (exists sti, steps step_m sys st1 hst1 sti).
    { inv_steps.
      eapply steps_split in H9; [|reflexivity].
      destruct H9 as [sti [? ?]]; eauto.
    }
    destruct H6 as [sti ?].
    destruct (rqDown_ExtContinuousL_parent_in_system Hiorqs H H0 H5 H1 H6)
      as [pobj [? ?]].
    eapply rqDown_WellInterleavedHst; eauto.
  - eapply rsUp_WellInterleavedHst; eauto.
  - assert (exists sti, steps step_m sys st1 hst1 sti).
    { inv_steps.
      eapply steps_split in H9; [|reflexivity].
      destruct H9 as [sti [? ?]]; eauto.
    }
    destruct H6 as [sti ?].
    destruct (rsDown_ExtContinuousL_parent_in_system Hiorqs H H0 H5 H1 H6)
      as [pobj [? ?]].
    eapply rsDown_WellInterleavedHst; eauto.
Qed.

Section NonConfluent.
  Context `{dv: DecValue} `{oifc: OStateIfc}.
  Variables (dtr: DTree)
            (sys: System)
            (oinvs: IdxT -> ObjInv).
  Hypotheses (Hiorqs: GoodORqsInit (initsOf sys))
             (Hoinvs: InvReachable sys step_m (liftObjInvs oinvs))
             (Hrrs: RqRsSys dtr sys oinvs).

  Lemma rqrs_step_ins_or:
    forall st1,
      Reachable (steps step_m) sys st1 ->
      forall oidx ridx rins routs st2,
        step_m sys st1 (RlblInt oidx ridx rins routs) st2 ->
        SubList (idsOf rins) (sys_merqs sys) \/
        SubList (idsOf rins) (sys_minds sys).
  Proof.
    intros.
    pose proof H0.
    eapply messages_in_cases in H1;
      try apply Hiorqs; try apply Hrrs; [|assumption].
    destruct H1 as [|[|[|]]]; disc_messages_in.
    - left; apply SubList_nil.
    - inv_step.
      destruct H14; simpl in *.
      apply SubList_singleton_In in H0.
      apply in_app_or in H0.
      destruct H0.
      + right; apply SubList_cons; [assumption|apply SubList_nil].
      + left; apply SubList_cons; [assumption|apply SubList_nil].
    - inv_step.
      destruct H14; simpl in *.
      apply SubList_singleton_In in H0.
      apply in_app_or in H0.
      destruct H0.
      + right; apply SubList_cons; [assumption|apply SubList_nil].
      + left; apply SubList_cons; [assumption|apply SubList_nil].
    - inv_step.
      destruct H13.
      right.
      red; intros midx ?.
      rewrite Forall_forall in H2; specialize (H2 _ H4).
      destruct H2 as [cidx [? ?]].
      apply H0 in H4.
      apply in_app_or in H4; destruct H4; [assumption|].
      exfalso.
      apply Hrrs in H4.
      destruct H4 as [eoidx ?].
      eapply rqrsDTree_rqUp_rsUp_not_eq in H4; [|apply Hrrs|eassumption].
      auto.
    - inv_step.
      destruct H14; simpl in *.
      apply SubList_singleton_In in H0.
      apply in_app_or in H0.
      destruct H0.
      + right; apply SubList_cons; [assumption|apply SubList_nil].
      + left; apply SubList_cons; [assumption|apply SubList_nil].
  Qed.

  Lemma extAtomic_IntMsgsEmpty_next_ins:
    forall st1,
      Reachable (steps step_m) sys st1 ->
      IntMsgsEmpty sys st1.(st_msgs) ->
      forall trss st2,
        steps step_m sys st1 (List.concat trss) st2 ->
        Forall AtomicEx trss ->
        Forall (Transactional sys) trss ->
        forall oidx ridx rins routs st3,
          ~ SubList (idsOf rins) (sys_merqs sys) ->
          step_m sys st2 (RlblInt oidx ridx rins routs) st3 ->
          exists einits trs eouts,
            In trs trss /\
            ExtAtomic sys einits trs eouts /\
            SubList rins eouts.
  Proof.
    intros.
    pose proof H5.
    eapply messages_in_cases in H6;
      try apply Hiorqs; try apply Hrrs;
        [|eapply reachable_steps; eassumption].
    assert (Forall (InMPI st2.(st_msgs)) rins /\
            SubList (idsOf rins) (sys_minds sys)).
    { pose proof H5.
      apply rqrs_step_ins_or in H7; [|eapply reachable_steps; eassumption].
      inv_step.
      split.
      { apply FirstMPI_Forall_InMP; assumption. }
      { destruct H7; [exfalso; auto|auto]. }
    }
    clear H5; dest. (* clear [step_m] *)

    destruct H6 as [|[|[|]]]; disc_messages_in.
    - elim H4; apply SubList_nil.
    - apply SubList_singleton_In in H7.
      inv H5; clear H13.
      eapply extAtomic_multi_IntMsgsEmpty_non_inits_InMPI in H12;
        try eassumption.
      destruct H12 as [einits [trs [eouts ?]]]; dest.
      exists einits, trs, eouts.
      repeat ssplit; [assumption..|].
      apply SubList_cons; [assumption|apply SubList_nil].

    - apply SubList_singleton_In in H7.
      inv H5; clear H13.
      eapply extAtomic_multi_IntMsgsEmpty_non_inits_InMPI in H12;
        try eassumption.
      destruct H12 as [einits [trs [eouts ?]]]; dest.
      exists einits, trs, eouts.
      repeat ssplit; [assumption..|].
      apply SubList_cons; [assumption|apply SubList_nil].

    - (* Pick a single [RsUp] message to get the previous transaction. *)
      destruct rins as [|[rsUp1 rsm1] rins];
        [exfalso; elim H4; apply SubList_nil|].
      simpl in *.
      apply SubList_cons_inv in H7; dest.
      inv H5; inv H6; inv H8.
      destruct H10 as [cidx1 [? ?]]; simpl in *.

      eapply extAtomic_multi_IntMsgsEmpty_non_inits_InMPI in H12;
        try eassumption.
      destruct H12 as [einits1 [trs1 [eouts1 ?]]]; dest.
      exists einits1, trs1, eouts1.

      (* Now prove all the other [RsUp] messages are from
       * this transaction as well. *)
      repeat ssplit; try assumption.
      red. intros [rsUp2 rsm2] ?.
      inv H16; [inv H17; assumption|].

      rewrite Forall_forall in H13, H14, H15.
      specialize (H13 _ H17).
      specialize (H14 _ H17).
      apply in_map with (f:= idOf) in H17.
      specialize (H15 _ H17).
      destruct H15 as [cidx2 [? ?]].
      simpl in *.
      eapply extAtomic_multi_IntMsgsEmpty_non_inits_InMPI in H13;
        try eassumption; [|apply H9 in H17; assumption].
      destruct H13 as [einits2 [trs2 [eouts2 ?]]]; dest.

      (* Prove two different [RsUp] messages are from the same transaction,
       * by deriving a contradiction; if [trs1 <> trs2] then ..
       *)
      apply In_nth_error in H8; destruct H8 as [n1 ?].
      apply In_nth_error in H13; destruct H13 as [n2 ?].
      destruct (Nat.eq_dec n1 n2).
      + subst; rewrite H8 in H13; inv H13.
        pose proof (extAtomic_unique H10 H18); dest; subst.
        assumption.
      + exfalso.
        eapply extAtomic_multi_rsUps_not_diverged
          with (n3:= n1) (n4:= n2) (rsUp3:= (rsUp1, rsm1)) (rsUp4:= (rsUp2, rsm2))
               (cidx3:= cidx1) (cidx4:= cidx2); eauto.
        * red; auto.
        * red; auto.

    - apply SubList_singleton_In in H7.
      inv H5; clear H13.
      eapply extAtomic_multi_IntMsgsEmpty_non_inits_InMPI in H12;
        try eassumption.
      destruct H12 as [einits [trs [eouts ?]]]; dest.
      exists einits, trs, eouts.
      repeat ssplit; [assumption..|].
      apply SubList_cons; [assumption|apply SubList_nil].
  Qed.

  Theorem rqrs_NonConfluent:
    RqRsSys dtr sys oinvs -> NonConfluent sys.
  Proof.
    intros.
    red; intros.
    eapply steps_split in H2; [|reflexivity].
    destruct H2 as [stt [? ?]].

    inv H5.
    pose proof H8.
    apply atomic_beginning_label in H5.
    destruct H5 as [ttrs [oidx [ridx [routs ?]]]]; subst.
    eapply steps_split in H6; [|reflexivity].
    destruct H6 as [sti [? ?]].
    inv_steps.

    eapply extAtomic_IntMsgsEmpty_next_ins in H14; eauto.
    destruct H14 as [pinits [ptrs [peouts ?]]]; dest.

    apply in_split in H5.
    destruct H5 as [hsts2 [hsts1 ?]]; subst.

    exists ptrs; eexists.
    exists hsts1, hsts2, nil; simpl.
    repeat ssplit.
    - reflexivity.
    - red; eauto 10.
    - apply Forall_forall.
      intros hst ?.
      eapply extAtomic_Discontinuous
        with (trss:= hsts2 ++ ptrs :: hsts1); try eassumption.
      + apply in_or_app; right.
        left; reflexivity.
      + apply in_or_app; left; assumption.
  Qed.

End NonConfluent.

Corollary rqrs_Serializable:
  forall `{dv: DecValue} `{oifc: OStateIfc} (sys: System)
         (Hiorqs: GoodORqsInit (initsOf sys)) (dtr: DTree)
         (oinvs: IdxT -> ObjInv) (Hoinvs: InvReachable sys step_m (liftObjInvs oinvs)),
    RqRsSys dtr sys oinvs ->
    SerializableSys sys.
Proof.
  intros.
  apply well_interleaved_serializable.
  - eapply rqrs_NonConfluent; eauto.
  - eapply rqrs_WellInterleaved; eauto.
Qed.

Close Scope list.
Close Scope fmap.