Require Import Bool List.
Require Import ExtLib.Tactics.Consider.
Require Import MirrorShard.Expr.
Require Import MirrorShard.SepExpr.
Require Import MirrorShard.Env MirrorShard.Prover.
Require Import SymEval.
Require Import Word Memory IL SepIL SymIL ILEnv.
Require Import PropX PropXTac Nomega NArith.

Set Implicit Arguments.

Definition array (ws : list W) (p : W) : HProp := ptsto32m _ p O ws.

Fixpoint div4 (n : nat) : option nat :=
  match n with
    | O => Some O
    | S (S (S (S n'))) => match div4 n' with
                            | None => None
                            | Some n'' => Some (S n'')
                          end
    | _ => None
  end.

Fixpoint selN (ws : list W) (n : nat) : W :=
  match ws with
    | nil => wzero _
    | w :: ws' => match n with
                    | O => w
                    | S n' => selN ws' n'
                  end
  end.

Definition sel (ws : list W) (a : W) : W :=
  selN ws (wordToNat a).

Fixpoint updN (ws : list W) (n : nat) (v : W) : list W :=
  match ws with
    | nil => nil
    | w :: ws' => match n with
                    | O => v :: ws'
                    | S n' => w :: updN ws' n' v
                  end
  end.

Definition upd (ws : list W) (a v : W) : list W :=
  updN ws (wordToNat a) v.

Definition bedrock_type_listW : type :=
  {| Expr.Impl := list W
   ; Expr.Eqb := (fun _ _ => false)
   ; Expr.Eqb_correct := @ILEnv.all_false_compare _ |}.

Definition types_r : Env.Repr Expr.type :=
  Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
    let lst :=
      Some ILEnv.bedrock_type_W ::
      Some ILEnv.bedrock_type_setting_X_state ::
      None ::
(*      None :: *)
      None ::
      Some ILEnv.bedrock_type_nat ::
      Some bedrock_type_listW :: nil
    in Env.listOptToRepr lst EmptySet_type.

Local Notation "'pcT'" := (tvType 0).
Local Notation "'stT'" := (tvType 1).
Local Notation "'wordT'" := (tvType 0).
Local Notation "'natT'" := (tvType 4).
Local Notation "'listWT'" := (tvType 5).

Local Notation "'wplusF'" := 0.
Local Notation "'wmultF'" := 2.
Local Notation "'wltF'" := 4.
Local Notation "'natToWF'" := 5.
Local Notation "'lengthF'" := 6.
Local Notation "'selF'" := 7.
Local Notation "'updF'" := 8.

Section parametric.
  Variable types' : list type.
  Definition types := repr types_r types'.
  Variable Prover : ProverT types.

  Definition natToW_r : signature types.
    refine {| Domain := natT :: nil; Range := wordT |}.
    exact natToW.
  Defined.

  Definition wlength_r : signature types.
    refine {| Domain := listWT :: nil; Range := natT |}.
    exact (@length _).
  Defined.

  Definition sel_r : signature types.
    refine {| Domain := listWT :: wordT :: nil; Range := wordT |}.
    exact sel.
  Defined.

  Definition upd_r : signature types.
    refine {| Domain := listWT :: wordT :: wordT :: nil; Range := listWT |}.
    exact upd.
  Defined.

  Definition funcs_r : Env.Repr (signature types) :=
    Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
      let lst :=
        Some (ILEnv.wplus_r types) ::
        None ::
        Some (ILEnv.wmult_r types) ::
(*        None :: *)
        None ::
        Some (ILEnv.wlt_r types) ::
        Some (ILEnv.natToW_r types) ::
        Some wlength_r ::
        Some sel_r ::
        Some upd_r ::
        nil
      in Env.listOptToRepr lst (Default_signature _).

  Definition deref (e : expr types) : option (expr types * expr types) :=
    match e with
      | Func wplusF (base :: offset :: nil) =>
        match offset with
          | Func wmultF (Func natToWF (Const t k :: nil) :: offset :: nil) =>
            match t return tvarD types t -> _ with
              | natT => fun k => match k with
                                   | 4 => Some (base, offset)
                                   | _ => None
                                 end
              | _ => fun _ => None
            end k
          | Func natToWF (Const t k :: nil) =>
            match t return tvarD types t -> _ with
              | natT => fun k => match div4 k with
                                   | None => None
                                   | Some k' => Some (base, Func natToWF (Const (types := types) (t := natT) k'
                                     :: nil))
                                 end
              | _ => fun _ => None
            end k
          | _ => None
        end
      | _ => None
    end.

  Definition sym_read (summ : Prover.(Facts)) (args : list (expr types)) (p : expr types)
    : option (expr types) :=
    match args with
      | ws :: p' :: nil =>
        match deref p with
          | None => None
          | Some (base, offset) =>
            if Prover.(Prove) summ (Equal wordT p' base)
              && Prover.(Prove) summ (Func wltF (offset :: Func natToWF (Func lengthF (ws :: nil)
                :: nil) :: nil))
              then Some (Func selF (ws :: offset :: nil))
              else None
        end
      | _ => None
    end.

  Definition sym_write (summ : Prover.(Facts)) (args : list (expr types)) (p v : expr types)
    : option (list (expr types)) :=
    match args with
      | ws :: p' :: nil =>
        match deref p with
          | None => None
          | Some (base, offset) =>
            if Prover.(Prove) summ (Equal wordT p' base)
              && Prover.(Prove) summ (Func wltF (offset :: Func natToWF (Func lengthF (ws :: nil)
                :: nil) :: nil))
              then Some (Func updF (ws :: offset :: v :: nil) :: p' :: nil)
              else None
        end
      | _ => None
    end.
End parametric.

Definition MemEval types' : @MEVAL.PredEval.MemEvalPred (types types').
  apply MEVAL.PredEval.Build_MemEvalPred.
  apply sym_read.
  apply sym_write.
  exact (fun _ _ _ _ => None).
  exact (fun _ _ _ _ _ => None).
Defined.

Ltac destr' E := destruct E. (*case_eq E; intros;
  try match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *
      end.*)

Ltac destr simp E :=
  match E with
    | context[match _ with None => _ | _ => _ end] => fail 1
    | div4 _ => fail 1
    | _ => destr' E; discriminate || tauto
    | _ => destr' E; try (discriminate || tauto); [simp]
  end.

Ltac destr2 simp E :=
  match E with
    | context[match _ with None => _ | _ => _ end] => fail 1
    | div4 _ => fail 1
    | _ => destr' E; try (discriminate || tauto); [simp]
    | _ => destr' E; try (discriminate || tauto); [ | ]; simp
  end.

Ltac stripSuffix E :=
  match E with
    | ?E = _ => stripSuffix E
    | ?E _ => stripSuffix E
    | ?E _ _ => stripSuffix E
    | _ => E
  end.

Ltac doMatch simp P :=
  match P with
    | match ?E with 0 => _ | _ => _ end => destr2 simp E
    | match ?E with nil => _ | _ => _ end => destr simp E
    | match ?E with Const _ _ => _ | _ => _ end => destr2 simp E
    | match ?E with tvProp => _ | _ => _ end => destr simp E
    | match ?E with None => _ | _ => _ end => destr simp E
    | match ?E with left _ => _ | _ => _ end => destr2 simp E
  end.

Ltac deconstruct' simp := match goal with
                            | [ H : Some _ = Some _ |- _ ] => injection H; clear H; intros; subst; simp
                            | [ H : ?P |- _ ] =>
                              let P := stripSuffix P in
                                doMatch simp P
                                || match P with
                                     | match ?P with None => _ | _ => _ end =>
                                       let P := stripSuffix P in
                                         doMatch simp P
                                   end
                          end.

Ltac deconstruct := repeat deconstruct' ltac:(simpl in *).

Section correctness.
  Variable types' : list type.
  Definition types0 := types types'.

  Definition ssig : SEP.predicate types0.
    refine (SEP.PSig _ (listWT :: wordT :: nil) _).
    exact array.
  Defined.

  Definition ssig_r : Env.Repr (SEP.predicate types0) :=
    Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
      let lst :=
        None :: Some ssig :: nil
      in Env.listOptToRepr lst (SEP.Default_predicate _).

  Variable funcs' : functions types0.
  Definition funcs := Env.repr (funcs_r _) funcs'.

  Variable Prover : ProverT types0.
  Variable Prover_correct : ProverT_correct Prover funcs.

  Lemma div4_correct' : forall n0 n m, (n < n0)%nat
    -> div4 n = Some m
    -> n = 4 * m.
    induction n0; simpl; intuition.
    destruct n; simpl in *.
    injection H0; omega.
    repeat destr ltac:(simpl in *) n.
    specialize (IHn0 n).
    destruct (div4 n).
    injection H0.
    rewrite (IHn0 n1); auto; omega.
    discriminate.
  Qed.

  Lemma div4_correct : forall n m, div4 n = Some m
    -> n = 4 * m.
    intros; eapply div4_correct'; eauto.
  Qed.

  Lemma deref_correct : forall uvars vars e w base offset,
    exprD funcs uvars vars e wordT = Some w
    -> deref e = Some (base, offset)
    -> exists wb, exists wo,
      exprD funcs uvars vars base wordT = Some wb
      /\ exprD funcs uvars vars offset wordT = Some wo
      /\ w = wb ^+ $4 ^* wo.
    destruct e; simpl; intuition; try discriminate.
    repeat (deconstruct' ltac:(simpl in *); []).
    case_eq (exprD funcs uvars vars e wordT); intros;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *
      end; try discriminate.
    deconstruct; eauto.
    match goal with
      | [ _ : context[div4 ?N] |- _ ] => specialize (div4_correct N); destruct (div4 N)
    end; try discriminate.
    deconstruct.
    specialize (H2 _ (refl_equal _)); subst.
    repeat (esplit || eassumption).
    replace (n + (n + (n + (n + 0)))) with (n * 4) by omega.
    rewrite natToW_times4.
    W_eq.
  Qed.

  Fixpoint ptsto32m' sos (a : W) (offset : nat) (vs : list W) : hpropB sos :=
    match vs with
      | nil => Emp
      | v :: vs' => (a ^+ $(offset)) =*> v * ptsto32m' sos a (4 + offset) vs'
    end%Sep.

  Theorem ptsto32m'_in : forall a cs stn vs offset m,
    interp cs (ptsto32m _ a offset vs stn m)
    -> interp cs (ptsto32m' _ a offset vs stn m).
    induction vs.

    auto.

    unfold ptsto32m, ptsto32m'.
    fold ptsto32m; fold ptsto32m'.
    destruct vs; destruct offset; intros.

    replace (a ^+ $0) with a by W_eq.
    simpl.
    propxFo.
    exists m.
    exists smem_emp; intuition.
    apply split_comm; apply split_emp.
    reflexivity.

    unfold ptsto32m'.
    apply simplify_bwd.
    exists m.
    exists smem_emp; intuition.
    split.
    apply split_comm; apply split_emp. reflexivity.
    split.
    apply simplify_fwd; assumption.
    split.
    constructor.
    reflexivity.

    replace (a ^+ $0) with a by W_eq.
    apply simplify_fwd in H.
    destruct H.
    destruct H.
    destruct H.
    destruct H0.
    apply simplify_bwd in H0.
    apply simplify_bwd in H1.
    apply simplify_bwd.
    exists x.
    exists x0.
    split; auto.
    split.
    apply simplify_fwd; assumption.
    apply simplify_fwd; auto.

    apply simplify_fwd in H.
    destruct H.
    destruct H.
    destruct H.
    destruct H0.
    apply simplify_bwd in H0.
    apply simplify_bwd in H1.
    apply simplify_bwd.
    exists x.
    exists x0.
    split; auto.
    split.
    apply simplify_fwd; assumption.
    apply simplify_fwd; auto.
  Qed.

  Lemma smem_read_correct'' : forall cs base stn ws offset i m,
    interp cs (ptsto32m' _ base (offset * 4) ws stn m)
    -> (i < length ws)%nat
    -> smem_read_word stn (base ^+ $((offset + i) * 4)) m = Some (selN ws i).
    induction ws.

    simpl length.
    intros.
    elimtype False.
    nomega.

    simpl length.
    unfold ptsto32m'.
    fold ptsto32m'.
    intros.
    destruct i; simpl selN.
    replace (offset + 0) with offset by omega.
    apply simplify_fwd in H.
    destruct H.
    destruct H.
    destruct H.
    destruct H1.
    destruct H1.
    simpl in H.
    eapply MSMF.split_multi_read; eauto.

    apply simplify_fwd in H.
    destruct H.
    destruct H.
    destruct H.
    destruct H1.
    apply simplify_bwd in H2.
    replace (4 + offset * 4) with (S offset * 4) in H2 by omega.
    eapply (IHws _ i) in H2.
    eapply split_comm in H.
    eapply MSMF.split_multi_read in H; eauto. unfold smem_read_word in H2.
    replace (offset + S i) with (S offset + i) by omega. auto. omega.
  Qed.

  Lemma smem_get_disjoint : forall a w1 w2 dom m1 m2,
    disjoint' dom m1 m2
    -> smem_get' dom a m1 = Some w1
    -> smem_get' dom a m2 = Some w2
    -> False.
  Proof.
    induction dom; simpl; intuition.
    discriminate.
    destruct (M.addr_dec a0 a); subst; try congruence.
    eauto.
    destruct (M.addr_dec a0 a); subst; try congruence.
    eauto.
  Qed.

  Lemma smem_read_word_disjoint : forall a m m1 m2 w1 w2 addrs,
    split m m1 m2
    -> smem_read_word addrs a m1 = Some w1
    -> smem_read_word addrs a m2 = Some w2
    -> False.
  Proof.
    unfold smem_read_word; intros.
    unfold MultiMem.multi_read in *.
    generalize (split_disjoint _ _ _ H). clear H. intros. simpl in *.

    consider (smem_get a m1); intros; try congruence.
    assert (in_domain a m1). red. congruence.
    eapply H in H3. apply H3. red.
    consider (smem_get a m2); try congruence.
  Qed.

  Lemma array_bound' : forall cs base stn ws m i,
    (0 < i < length ws)%nat
    -> base ^+ $(i * 4) = base
    -> interp cs (ptsto32m' _ base 0 ws stn m)
    -> False.
    destruct ws; simpl length; intros.

    elimtype False; omega.

    simpl in H1.
    propxFo.
    destruct i; try omega.
    generalize (@smem_read_correct'' cs base stn ws 1 i x0).
    simpl plus.
    rewrite H0.
    rewrite wplus_comm in H4.
    rewrite wplus_unit in H4.
    intuition.
    assert (i < length ws)%nat by omega; intuition.
    eapply smem_read_word_disjoint; eauto.
  Qed.

  Lemma pow2_pos : forall n, (pow2 n > 0)%nat.
    induction n; simpl; omega.
  Qed.

  Lemma pow2_monotone : forall n m,
    (n < m)%nat
    -> (pow2 n < pow2 m)%nat.
    induction 1; simpl; intuition.
    specialize (pow2_pos n).
    omega.
  Qed.

  Lemma pow2_mult : forall m n,
    pow2 n * pow2 m = pow2 (n + m).
    induction n; simpl; intuition.
    repeat rewrite <- IHn.
    repeat rewrite <- plus_n_O.
    apply Mult.mult_plus_distr_r.
  Qed.

  Lemma array_bound : forall cs ws base stn m,
    interp cs (array ws base stn m)
    -> (length ws < pow2 32)%nat.
  Proof.
    intros.
    Require Import Arith.
    destruct (lt_dec (length ws) (pow2 32)); auto.
    elimtype False.
    apply ptsto32m'_in in H.
    apply (@array_bound' _ _ _ _ _ (pow2 30)) in H; auto.
    split.
    unfold pow2; omega.
    specialize (@pow2_monotone 30 32).
    omega.
    change (pow2 30 * 4) with (pow2 30 * pow2 2).
    rewrite pow2_mult.
    simpl plus.
    clear.
    rewrite wplus_alt.
    unfold wplusN, wordBinN.
    rewrite natToWord_pow2.
    rewrite roundTrip_0.
    rewrite plus_0_r.
    apply natToWord_wordToNat.
  Qed.

  Lemma smem_read_correct' : forall cs base stn ws i m,
    interp cs (array ws base stn m)
    -> i < $(length ws)
    -> smem_read_word stn (base ^+ $4 ^* i) m = Some (sel ws i).
  Proof.
    unfold sel; intros; rewrite <- (@smem_read_correct'' cs base stn ws 0 (wordToNat i) m).
    f_equal.
    simpl plus.
    rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    apply ptsto32m'_in; auto.

    red in H0.
    apply Nlt_out in H0.
    repeat rewrite wordToN_nat in *.
    repeat rewrite Nat2N.id in *.
    rewrite wordToNat_natToWord_idempotent in H0; auto.
    apply array_bound in H.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    assumption.
  Qed.

  Lemma sym_read_correct : forall args uvars vars cs summ pe p ve m stn,
    sym_read Prover summ args pe = Some ve ->
    Valid Prover_correct uvars vars summ ->
    exprD funcs uvars vars pe wordT = Some p ->
    match
      applyD (exprD funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
      with
      | None => False
      | Some p => PropX.interp cs (p stn m)
    end ->
    match exprD funcs uvars vars ve wordT with
      | Some v =>
        smem_read_word stn p m = Some v
      | _ => False
    end.
  Proof.
    simpl; intuition.
    do 3 (destruct args; simpl in *; intuition; try discriminate).
    generalize (deref_correct uvars vars pe); destr ltac:(simpl in *) (deref pe); intro Hderef.
    destruct p0.

    repeat  match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove Prover ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[exprD _ _ _ goal _] |- _ ] => fail 1
                 | _ => specialize (@Prove_correct _ _ _ Prover_correct _ _ summ H goal); intro
               end
           end; unfold ValidProp in *; simpl in *.

    match goal with
      | [ _ : (if ?E then _ else _) = Some _ |- _ ] => case_eq E; intro Heq; rewrite Heq in *
    end; try discriminate.
    unfold types0 in *; simpl in *.
    unfold Provable in *; simpl in *.
    deconstruct.
    repeat match goal with
             | [ H : _ |- _ ] => apply andb_prop in H; intuition
           end.
    rewrite H1 in *.
    specialize (Hderef _ _ _ (refl_equal _) (refl_equal _)); destruct Hderef as [ ? [ ] ]; intuition.
    subst.
    simpl in *.
    rewrite H4 in *.
    rewrite H7 in *.
    subst.
    eapply smem_read_correct'; eauto.
  Qed.

  Theorem ptsto32m'_out : forall a cs stn vs offset m,
    interp cs (ptsto32m' _ a offset vs stn m)
    -> interp cs (ptsto32m _ a offset vs stn m).
  Proof.
    induction vs.

    auto.

    unfold ptsto32m, ptsto32m'.
    fold ptsto32m; fold ptsto32m'.
    destruct vs; destruct offset; intros.

    replace (a ^+ $0) with a in * by W_eq.
    simpl.
    propxFo.
    { rewrite <- H1.
      f_equal.
      eapply split_emp. subst.
      apply split_comm; eauto. }
    { apply split_comm in H3.
      subst. eapply split_emp in H3. red in H3. subst.
      specialize (H7 a'). intuition. }

    { apply simplify_fwd in H.
      destruct H.
      destruct H.
      destruct H.
      destruct H0.
      apply simplify_bwd in H0.
      replace m with x; auto.
      symmetry; eapply split_emp.
      apply split_comm; eauto.
      simpl in H. simpl in H1. intuition; subst; auto. }

    { replace (a ^+ $0) with a in * by W_eq.
      apply simplify_fwd in H.
      apply simplify_bwd.
      destruct H.
      destruct H.
      destruct H.
      destruct H0.
      exists x; exists x0; split.
      auto.
      split; auto.
      apply simplify_fwd.
      apply simplify_bwd in H1.
      auto. }

    { apply simplify_fwd in H.
      apply simplify_bwd.
      destruct H.
      destruct H.
      destruct H.
      destruct H0.
      exists x; exists x0; split.
      auto.
      split; auto.
      apply simplify_fwd.
      apply simplify_bwd in H1.
      auto. }
    Qed.

  Lemma smem_write_correct'' : forall cs base stn v ws i m offset,
    (i < length ws)%nat
    -> interp cs (ptsto32m' _ base (offset * 4) ws stn m)
    -> exists m', smem_write_word stn (base ^+ $4 ^* $(offset + i)) v m = Some m'
      /\ PropX.interp cs ((ptsto32m' _ base (offset * 4) (updN ws i v)) stn m').
  Proof.
    induction ws; simpl length; intros.

    inversion H.

    unfold ptsto32m' in *.
    fold ptsto32m' in *.
    destruct i; simpl updN.
    { rewrite wmult_comm.
      rewrite <- natToW_times4.
      replace (offset + 0) with offset by omega.
      unfold ptsto32m'.
      fold ptsto32m'.
      apply simplify_fwd in H0.
      destruct H0.
      destruct H0.
      destruct H0.
      destruct H1.
      hnf in H1.
      unfold natToW.
      destruct H1.

      unfold smem_read_word in *.

      match goal with
        | _ : ?X = Some _ |- _ =>
          assert (X <> None) by congruence
      end.
      specialize (@MSMF.smem_set_get_valid_multi W 4 (fun a : W =>
                                                        let '(a0, b, c, d) := footprint_w a in (a0, (b, (c, (d, tt)))))
                                                 (fun v : MultiMem.vector B 4 =>
                                                    let '(a, (b, (c, (d, _)))) := v in implode stn (a, b, c, d))
                                                 (fun v0 : W =>
                                                    let '(a0, b, c, d) := explode stn v0 in (a0, (b, (c, (d, tt)))))
                                                 (base ^+ $ (offset * 4)) v x H4); clear H4; intro.
      match goal with
        | _ : not (?X = None) |- _ =>
          consider X; try congruence; intros
      end.
      clear H5.
      simpl in H0.
      generalize H4.
      eapply MSMF.split_multi_write in H4; try solve [ intuition eauto ].
      destruct H4. destruct H4. intro.
      exists (join s x0); split.
      { destruct H4; subst; auto. }
      { unfold starB, star, STK.istar.
        eapply Exists_I with (B := s). eapply Exists_I with (B := x0).
        eapply And_I.
        apply Inj_I. destruct H4; split; auto.
        eapply And_I. 2: propxFo.
        apply Inj_I.
        split.
        { unfold smem_read_word, MultiMem.multi_read.
          eapply MSMF.smem_read_write_eq_multi' with (k := (fun v0 : MultiMem.vector B 4 =>
      let '(a0, (b, (c, (d, _)))) := v0 in implode stn (a0, b, c, d))) in H6.
          clear - H6. etransitivity. eapply H6. f_equal.
          clear. consider (explode stn v); simpl. destruct p as [ [ ] ]. intros.
          rewrite <- H. eapply implode_explode.
          Theorem footprint_w_NoDup : forall p,
                                        MultiMem.NoDup_v M.addr 4
                                                         (let '(a0, b, c, d) := footprint_w p in
                                                          (a0, (b, (c, (d, tt))))).
          Proof.
            clear. Opaque natToWord. simpl; intros.
            cut (MultiMem.NoDup_v M.addr 4
                                     (p ^+ $(0), (p ^+ $ (1), (p ^+ $ (2), (p ^+ $ (3), tt))))).
            rewrite Word.wplus_comm. rewrite Word.wplus_unit. auto.
            repeat constructor; simpl; intuition; auto;
            match goal with
              | H0 : _ = _ |- _ =>
                do 2 (rewrite (Word.wplus_comm p) in H0); apply Word.wplus_cancel in H0; inversion H0
            end.
          Qed.
          eapply footprint_w_NoDup. }
        { intro. specialize (H3 a'). intuition.
          erewrite <- MSMF.smem_multi_write_footprint.
          eassumption. eapply H6.
          clear - H8 H7 H9 H11. simpl. intuition. } } }
    { simpl.
      eapply STK.interp_star in H0. do 3 destruct H0. destruct H1.
      replace (base ^+ $ (4) ^* $ (offset + S i)) with
              (base ^+ $ (4) ^* $ ((S offset) + i)) in H2 by (f_equal; f_equal; f_equal; omega).
      assert (i < length ws)%nat by omega.
      destruct (@IHws i x0 (S offset) H3 H2).
      destruct H4. replace (offset + S i)%nat with (S offset + i)%nat by omega.
      generalize H4; intro.
      eapply MSMF.split_multi_write in H4. 2: eapply split_comm; eassumption.
      destruct H4. intuition. eexists. split. eapply H8.
      eapply Exists_I with (B := x).
      eapply Exists_I with (B := x1).
      eapply And_I.
      2: eapply And_I; eauto.
      eapply Inj_I. eapply split_comm; auto. }
  Qed.

  Lemma smem_write_correct' : forall i ws cs base stn m v,
    i < natToW (length ws)
    -> interp cs (array ws base stn m)
    -> exists m', smem_write_word stn (base ^+ $4 ^* i) v m = Some m'
      /\ PropX.interp cs ((array (upd ws i v) base) stn m').
  Proof.
    intros.
    destruct (@smem_write_correct'' cs base stn v ws (wordToNat i) m 0).

    red in H.
    apply Nlt_out in H.
    repeat rewrite wordToN_nat in *.
    repeat rewrite Nat2N.id in *.
    rewrite wordToNat_natToWord_idempotent in H; auto.
    apply array_bound in H0.
    apply Nlt_in.
    rewrite Nat2N.id.
    rewrite Npow2_nat.
    assumption.

    apply ptsto32m'_in; auto.

    intuition.
    simpl plus in *.
    simpl mult in *.
    rewrite natToWord_wordToNat in H2.
    exists x; split; auto.
    apply ptsto32m'_out; auto.
  Qed.

  Lemma sym_write_correct : forall args uvars vars cs summ pe p ve v m stn args',
    sym_write Prover summ args pe ve = Some args' ->
    Valid Prover_correct uvars vars summ ->
    exprD funcs uvars vars pe wordT = Some p ->
    exprD funcs uvars vars ve wordT = Some v ->
    match
      applyD (@exprD _ funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
      with
      | None => False
      | Some p => PropX.interp cs (p stn m)
    end ->
    match
      applyD (@exprD _ funcs uvars vars) (SEP.SDomain ssig) args' _ (SEP.SDenotation ssig)
      with
      | None => False
      | Some pr =>
        match smem_write_word stn p v m with
          | None => False
          | Some sm' => PropX.interp cs (pr stn sm')
        end
    end.
  Proof.
    simpl; intuition.
    do 3 (destruct args; simpl in *; intuition; try discriminate).
    generalize (deref_correct uvars vars pe); destr ltac:(simpl in *) (deref pe); intro Hderef.
    destruct p0.

    repeat  match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove Prover ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[exprD _ _ _ goal _] |- _ ] => fail 1
                 | _ => specialize (@Prove_correct _ _ _ Prover_correct _ _ summ H goal); intro
               end
           end; unfold ValidProp in *; simpl in *.

    match goal with
      | [ _ : (if ?E then _ else _) = Some _ |- _ ] => case_eq E; intro Heq; rewrite Heq in *
    end; try discriminate.
    unfold types0 in *; simpl in *.
    unfold Provable in *; simpl in *.
    deconstruct.
    repeat match goal with
             | [ H : _ |- _ ] => apply andb_prop in H; intuition
           end.
    rewrite H1 in *.
    rewrite H2 in *.
    specialize (Hderef _ _ _ (refl_equal _) (refl_equal _)); destruct Hderef as [ ? [ ] ]; intuition.
    subst.
    simpl in *.
    rewrite H8 in *.
    rewrite H5 in *.
    subst.
    eapply smem_write_correct' in H3; eauto.
    destruct H3; intuition.
    rewrite H7. assumption.
  Qed.
End correctness.

Definition MemEvaluator types' : MEVAL.MemEvaluator (types types') :=
  Eval cbv beta iota zeta delta [ MEVAL.PredEval.MemEvalPred_to_MemEvaluator ] in
    @MEVAL.PredEval.MemEvalPred_to_MemEvaluator _ (MemEval types') 1.

Theorem MemEvaluator_correct types' funcs' preds'
  : @MEVAL.MemEvaluator_correct (Env.repr types_r types') (tvType 0) (tvType 1)
  (MemEvaluator (Env.repr types_r types')) (funcs funcs') (Env.repr (ssig_r _) preds')
  (IL.settings * IL.state) (tvType 0) (tvType 0)
  (@IL_mem_satisfies (types types')) (@IL_ReadWord (types types')) (@IL_WriteWord (types types'))
  (@IL_ReadByte (types types')) (@IL_WriteByte (types types')).
Proof.
  intros. eapply (@MemPredEval_To_MemEvaluator_correct (types types')); try reflexivity;
  intros; unfold MemEval in *; simpl in *; try discriminate.
  { generalize (@sym_read_correct types' funcs' P PE). simpl in *. intro.
    eapply H3 in H; eauto. }
  { generalize (@sym_write_correct types' funcs' P PE). simpl in *. intro.
    eapply H4 in H; eauto. }
Qed.

Definition pack : MEVAL.MemEvaluatorPackage types_r (tvType 0) (tvType 1) (tvType 0) (tvType 0)
  IL_mem_satisfies IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte :=

  @MEVAL.Build_MemEvaluatorPackage types_r (tvType 0) (tvType 1) (tvType 0) (tvType 0)
  IL_mem_satisfies IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte
  types_r
  funcs_r
  (fun ts => Env.listOptToRepr (None :: Some (ssig ts) :: nil)
    (SEP.Default_predicate (Env.repr types_r ts)))
  (fun ts => MemEvaluator _)
  (fun ts fs ps => MemEvaluator_correct _ _).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime P A B C D A1 B1 C1 D1 C1prime M D1prime N : Universe, ((wd_ O E /\ (wd_ P B /\ (wd_ A B /\ (wd_ O M /\ (wd_ M C1 /\ (wd_ P D /\ (wd_ O C1 /\ (wd_ C1 C1prime /\ (wd_ O C1prime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ P A /\ (wd_ A C /\ (wd_ P C /\ (wd_ C D /\ (wd_ C1prime A1 /\ (wd_ O A1 /\ (wd_ O D1 /\ (wd_ O D1prime /\ (wd_ O B1 /\ (wd_ M C1prime /\ (wd_ N O /\ (wd_ D1 N /\ (wd_ D1 D1prime /\ (wd_ N D1prime /\ (wd_ A1 Eprime /\ (col_ P A B /\ (col_ P C D /\ (col_ O E A1 /\ (col_ O E B1 /\ (col_ O E C1 /\ (col_ O E D1 /\ (col_ O M N /\ (col_ D A B /\ (col_ N D1 D1prime /\ (col_ M C1 C1prime /\ (col_ O C1prime D1prime /\ (col_ O A1 C1 /\ col_ O C1 D1)))))))))))))))))))))))))))))))))))))) -> col_ P A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX DepMaps Protocols.
From DiSeL Require Import Worlds NetworkSem Rely Actions Injection Process.
From DiSeL Require Import Always HoareTriples InferenceRules InductiveInv While.
From DiSeL Require Import TwoPhaseProtocol.

Module TwoPhaseCoordinator.
Section TwoPhaseCoordinator.

Variable l : Label.
Variables (cn : nid) (pts : seq nid) (others : seq nid).
Hypothesis Hnin : cn \notin pts.
Hypothesis Puniq : uniq pts.
Hypothesis PtsNonEmpty : pts != [::].

Definition tpc := TwoPhaseCommitProtocol others Hnin l.
Notation W := (mkWorld tpc).

Section CoordinatorImplementation.

(************** Atomic actions **************)

(* Three send-actions, e -- id of the current era *)

(* TODO: automate the proofs of obligations *)
Program Definition send_prep e data to :=
  act (@send_action_wrapper W tpc cn l (prEq tpc) (cn_send_prep_trans cn pts others) _ (e :: data) to).
Next Obligation. by rewrite InE; do![left|right]. Qed.

Program Definition send_commit e to :=
  act (@send_action_wrapper W tpc cn l (prEq tpc) (cn_send_commit_trans cn pts others) _ [:: e] to).
Next Obligation. by rewrite !InE; right; left. Qed.

Program Definition send_abort e to :=
  act (@send_action_wrapper W tpc cn l (prEq tpc) (cn_send_abort_trans cn pts others) _ [:: e] to).
Next Obligation. by rewrite !InE; right; right; left. Qed.

(* Three receive-actions *)

(* This action actually encompasses two receive-transitions *)
Program Definition tryrecv_prep_resp := act (@tryrecv_action_wrapper W cn
      (* filter *)
      (fun k _ t b => (k == l) && ((t == prep_yes) || (t == prep_no))) _).
(* TODO: automate these kinds of proofs *)
Next Obligation. by case/andP: H=>/eqP->_; rewrite /ddom domPt inE/=. Qed.

Program Definition tryrecv_commit_ack :=
  act (@tryrecv_action_wrapper W cn (fun k _ t b => (k == l) && (t == commit_ack)) _).
Next Obligation. by case/andP: H=>/eqP->_; rewrite /ddom domPt inE/=. Qed.

Program Definition tryrecv_abort_ack :=
  act (@tryrecv_action_wrapper W cn (fun k _ t b => (k == l) && (t == abort_ack)) _).
Next Obligation. by case/andP: H=>/eqP->_; rewrite /ddom domPt inE/=. Qed.

(************** Coordinator code **************)

(*** Reading internal state ***)
Arguments TPCProtocol.TPCCoh {cn pts others}.
Notation coh := (@TPCProtocol.TPCCoh cn pts others).
Notation getS s := (getStatelet s l).
Notation loc i := (getLocal cn (getStatelet i l)).

Export TPCProtocol.

(*************************************)
(* Reading current state - with spec *)
(*************************************)

Program Definition read_round :
  {(ecl : (nat * CState) * Log)}, DHT [cn, W]
  (fun i => loc i = st :-> ecl.1 \+ log :-> ecl.2,
   fun r m => loc m = st :-> ecl.1 \+ log :-> ecl.2 /\
              exists (pf : coh (getS m)), r = (getStC pf).1) :=
  Do (act (@skip_action_wrapper W cn l tpc (prEq tpc) _
                                (fun s pf => (getStC pf).1))).
Next Obligation.
apply: ghC=>i [[e c]lg]/= E _.
apply: act_rule=>j R; split=>[|r k m]; first by case: (rely_coh R).
case=>/=H1[Cj]Z; subst j=>->R'.
split; first by rewrite (rely_loc' l R') (rely_loc' _ R).
case: (rely_coh R')=>_; case=>_ _ _ _/(_ l)=>/= pf; rewrite prEq in pf.
exists pf; move: (rely_loc' l R').
move => E'.
apply sym_eq in E'.
suff X: getStC (Actions.safe_local (prEq tpc) H1) = getStC pf by rewrite X.
by apply: (getStCE pf _ E').
Qed.

(*******************************************)
(***   Sending out proposals in a loop   ***)
(*******************************************)

Definition send_prep_loop_spec (e : nat) d := forall to_send,
  {l : Log}, DHT [cn, W]
  (fun i =>
     loc i = st :-> (e, CInit) \+ log :-> l /\ perm_eq pts to_send \/
     if to_send == [::]
     then loc i = st :-> (e, CWaitPrepResponse d [::]) \+ log :-> l
     else exists (ps : seq nid),
         loc i = st :-> (e, CSentPrep d ps) \+ log :-> l /\
         perm_eq pts (ps ++ to_send),
   fun r m => r = tt /\ loc m = st :-> (e, CWaitPrepResponse d [::]) \+ log :-> l).

Program Definition send_prep_loop e d :
  {l : Log}, DHT [cn, W]
  (fun i => loc i = st :-> (e, CInit) \+ log :-> l,
   fun r m => r = tt /\
              loc m = st :-> (e, CWaitPrepResponse d [::]) \+ log :-> l) :=
  Do (ffix (fun (rec : send_prep_loop_spec e d) to_send =>
              Do (match to_send with
                  | to :: tos => send_prep e d to ;; rec tos
                  | [::] => ret _ _ tt
                  end)) pts).

(* Verifying the loop invariant *)
Next Obligation.
apply: ghC=>i1 lg.
(*********************************)
(* two cases of the precondition *)
(*********************************)
case=>[[E1 P1 C1]|].

(*--------------------------------------*)
(* Case 1: We are in the initial state  *)
(*--------------------------------------*)

- case: to_send P1=>[|to tos Hp].
  + by move/perm_size=>/=/size0nil=>Z; rewrite Z in (PtsNonEmpty).
- apply: step; apply:act_rule=>j1 R1/=; split=>[|r k m[Sf]St R2].
  split=>//=; first by case: (rely_coh R1).
  + split; first by split=>//; move/perm_mem: Hp->; rewrite inE eqxx.
    case: (proj2 (rely_coh R1))=>_ _ _ _/(_ l); rewrite (prEq tpc)=>C; exists C.
    left; exists e; split; last by exists d.
    by rewrite -(rely_loc' _ R1) in E1; rewrite (getStC_K _ E1).
  + rewrite /Actions.can_send /nodes inE eqxx andbC/=.
    by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
  + rewrite /Actions.filter_hooks umfilt0=>???.
    move => F.
    apply sym_eq in F.
    move: F.
    by move/find_some; rewrite dom0.
case: {-1}(Sf)=>_/=[]Hc[C][]; last first.
- move=>[n][d'][ps][E1'][]Z1 Z2 _; subst n d'.
  rewrite -(rely_loc' _ R1) in E1.
  by rewrite (getStC_K C E1) in E1'; discriminate E1'.
case=>b[E1'][d'][Z1 Z2]_ _; subst b d'.
move: St=>[Z][h][[]Z' G]; subst r h.
apply: (gh_ex (g := lg)).

(* Verifying precondition of the recursive call *)
have Pre:
  (if tos == [::]
   then loc m = st :-> (e, CWaitPrepResponse d [::]) \+ log :-> lg
   else exists ps : seq nid, loc m = st :-> (e, CSentPrep d ps) \+ log :-> lg /\ perm_eq pts (ps ++ tos)).
- case X: ([::] == tos);[move/eqP: X=>X; subst tos; rewrite eqxx|
                         rewrite eq_sym X].
  have Y: pts == [:: to] by rewrite (perm_small_eq _ Hp).
  rewrite /cstep_send/= Y in G.
  move: (proj2 Hc)=>Y'; rewrite Y' in G=>{Y'}.
  rewrite [cn_safe_coh _ ](pf_irr _ C) E1' in G. (* TADA! *)
  rewrite (rely_loc' l R2); subst k; rewrite -(rely_loc' _ R1) in E1.
  rewrite locE; last apply: (cohVl C).
  + by rewrite -(pf_irr (cn_in cn pts others) (cn_this_in _ _))
                  (getStL_Kc _ (cn_in cn pts others) E1).
  + by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
  by apply: (cohS (proj2 (rely_coh R1))).
- exists [:: to]; split; last by rewrite cat_cons/=.
  have Y: pts == [:: to] = false.
  + apply/negP=>/eqP Z; rewrite Z in Hp.
    move/perm_size: (Hp).
    move => F.
    apply sym_eq in F.
    move: F.
    by case=>/size0nil=>Z'; rewrite Z' eqxx in X.
    (* This part is similar to the previous step *)
  rewrite /cstep_send/= Y in G.
  move: (proj2 Hc)=>Y'; rewrite Y' in G=>{Y'}.
  rewrite [cn_safe_coh _ ](pf_irr _ C) E1' in G. (* TADA! *)
  rewrite (rely_loc' l R2); subst k; rewrite -(rely_loc' _ R1) in E1.
  rewrite locE; last apply: (cohVl C).
  + by rewrite -(pf_irr (cn_in cn pts others) (cn_this_in _ _))
                  (getStL_Kc _ (cn_in cn pts others) E1).
  + by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
  by apply: (cohS (proj2 (rely_coh R1))).

apply: call_rule'=>/=[Cm|r2 m2]; first by right.
by case=>//; right.

(*------------------------------------------*)
(* Case 2: We are in the intermediate state *)
(*------------------------------------------*)

(*** Subcase 2.1 : The last step of the loop ***)
case X: (to_send == [::]).
- move=>E1 C1; move/eqP: X=>Z; subst to_send.
  by apply: ret_rule=>m R; split=>//; rewrite (rely_loc' _ R).

(*** Subcase 2.2 : The proper intermediate step ***)
case=>ps[E1]Hp C1.
have Y: exists to tos, to_send = to :: tos.
- case: to_send X Hp; first by rewrite eqxx.
  by move=>to tos _ _; exists to, tos.
case: Y=>to[tos] Z; subst to_send=>{X}.
- apply: step; apply:act_rule=>j1 R1/=; split=>[|r k m[Sf]St R2].
  split=>//=; first by case: (rely_coh R1).
  + split; first by split=>//; move/perm_mem: Hp->;
                    rewrite mem_cat orbC inE eqxx.
    case: (proj2 (rely_coh R1))=>_ _ _ _/(_ l); rewrite prEq=>C; exists C.
    right; exists e, d, ps; split=>//.
      by rewrite -(rely_loc' _ R1) in E1; rewrite (getStC_K _ E1).
  + move/perm_uniq: Hp; rewrite Puniq.
    move => F.
    apply sym_eq in F.
    move: F.
    rewrite -cat_rcons cat_uniq -cats1 cat_uniq=>/andP[]/andP[_]/andP[].
    by rewrite /= orbC/=.
  + rewrite /Actions.can_send /nodes inE eqxx andbC.
    by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
  rewrite /Actions.filter_hooks umfilt0=>???.
  move => F.
  apply sym_eq in F.
  move: F.
  by move/find_some; rewrite dom0.
(* dismiss the bogus branch *)
case: {-1}(Sf)=>_/=[]Hc[C][].
- case=>b[E1'][d'][Z1 Z2]_; subst b d'.
  rewrite -(rely_loc' _ R1) in E1.
  by rewrite (getStC_K C E1) in E1'; discriminate E1'.
move=>[n][d'][ps'][E1'][]Z1 Z2 N _ _; subst n d'.
rewrite -(rely_loc' _ R1) in E1.
move: (E1'); rewrite (getStC_K C E1); case=>Z; subst ps'.
move: St=>[Z][h][[]Z' G]; subst r h.
apply: (gh_ex (g := lg)).

(* the same precondition, but different state *)
suff Pre:
  (if tos == [::]
   then loc m = st :-> (e, CWaitPrepResponse d [::]) \+ log :-> lg
   else exists ps : seq nid,
   loc m = st :-> (e, CSentPrep d ps) \+ log :-> lg /\ perm_eq pts (ps ++ tos)).
- apply: call_rule'=>/=[Cm|r2 m2]; first by right.
  by case=>//; right.
- case X: ([::] == tos);
    [move/eqP: X=>X; subst tos; rewrite eqxx| rewrite eq_sym X].
    rewrite /cstep_send/= (proj2 Hc)/= in G.
    rewrite [cn_safe_coh _ ](pf_irr _ C) E1' in G.
  have Y: perm_eq (to :: ps) pts
    by move: Hp; rewrite (perm_sym pts) perm_catC cat1s.
  rewrite Y/= in G.
  rewrite (rely_loc' l R2); subst k; rewrite locE; last apply: (cohVl C).
  + by rewrite -(pf_irr (cn_in cn pts others) (cn_this_in _ _))
               (getStL_Kc _ (cn_in cn pts others) E1).
  + by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
  by apply: (cohS (proj2 (rely_coh R1))).

rewrite /cstep_send/= (proj2 Hc)/= in G.
rewrite [cn_safe_coh _ ](pf_irr _ C) E1' in G.
have Y : perm_eq (to :: ps) pts = false.
- apply/negP=>Hp'; move: (perm_trans Hp' Hp).
  rewrite -[to::ps]cat1s -[to::tos]cat1s.
  move/permEl: (perm_catC ps [::to])=>Hs.
  move/(perm_trans Hs); rewrite -[_++[::_]]cats0 catA perm_cat2l.
  move/perm_size.
  move => F.
  apply sym_eq in F.
  move: F.
  by move/size0nil=>Z; subst tos.
rewrite Y/= in G.
rewrite (rely_loc' l R2); subst k; rewrite locE; last apply: (cohVl C).
  + rewrite -(pf_irr (cn_in cn pts others) (cn_this_in _ _))
               (getStL_Kc _ (cn_in cn pts others) E1); exists (to::ps).
    split=>//; move: Hp.
    by rewrite -cat_rcons -cat1s -!catA !(perm_sym pts) -perm_catCA catA cats1.
  + by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
  by apply: (cohS (proj2 (rely_coh R1))).
Qed.

(* Verifying the top-level call of ffix *)
Next Obligation.
apply:ghC=>i lg E1 _; apply: (gh_ex (g:=lg)).
by apply: call_rule=>C1; first by left.
Qed.

(*******************************************)
(*** Receiving responses to the proposal ***)
(*******************************************)

(* Ending condition *)
Definition rc_prep_cond (acc : seq (nid * bool)) := ~~ perm_eq (map fst acc) pts.

(* Invariant relates the argument and the shape of the state *)
Definition rc_prep_inv (e : nat) (dl : data * Log) : cont (seq (nid * bool)) :=
  fun acc i => loc i = st :-> (e, CWaitPrepResponse dl.1 acc) \+ log :-> dl.2.

Program Definition receive_prep_loop (e : nat):
  {(dl : data * Log)}, DHT [cn, W]
  (fun i => loc i = st :-> (e, CWaitPrepResponse dl.1 [::]) \+ log :-> dl.2,
   fun res m =>
       loc m = st :-> (e, CWaitPrepResponse dl.1 res) \+ log :-> dl.2 /\
       (perm_eq (map fst res) pts))
  :=
  Do _ (@while cn W _ _ rc_prep_cond (rc_prep_inv e) _
        (fun acc => Do _ (
           r <-- tryrecv_prep_resp;
           match r with
           | Some (from, tg, body) =>
               if [&& from \in pts, head 0 body == e & from \notin (map fst acc)]
               then ret _ _ ((from, tg == prep_yes) :: acc)
               else ret _ _ acc
           | None => ret _ _ acc
           end
        )) [::]).

(* TODO: Get rid of this bogus obligation! *)
Next Obligation. by apply: with_spec x. Defined.
Next Obligation. by move:H; rewrite /rc_prep_inv (rely_loc' _ H0). Qed.

Next Obligation.
move=>i[[d lg]]/=[H1 I1]; apply: step.
apply: act_rule=>j R1/=; split; first by case: (rely_coh R1).
case=>[[[from tg] body] k m|k m]; last first.
- case=>Sf []Cj[]H; last by case: H=>[?][?][?][?][?][?][].
  have E: k = j by case: H.
  move: H; subst k=>_ R2; apply: ret_rule=>m' R3 {d lg I1}[d lg][H2].
  by rewrite /rc_prep_inv; rewrite -(rely_loc' _ R1)-(rely_loc' _ R2)-(rely_loc' _ R3).
case=>Sf []Cj[]=>[|[l'][mid][tms][from'][rt][pf][][E]Hin E1 Hw/=]; first by case.
case/andP=>/eqP Z G->{k}[]Z1 Z2 Z3 R2; subst l' from' tg body.
move: rt pf (coh_s (w:=W) l (s:=j) Cj) Hin R2 E1 Hw G E; rewrite prEq/=.
move=>rt pf Cj' Hin R E1 Hw G E.
have D: rt = cn_receive_prep_yes_trans _ _ _ \/ rt = cn_receive_prep_no_trans _ _ _.
- case: Hin G=>/=; first by intuition.
  case; first by intuition.
  by do! [case; first by move=>->].
(* Some forward facts: *)
have P1: valid (dstate (getS j))
  by apply: (@cohVl _ TPCCoh); case: (Cj')=>P1 P2 P3 P4; split=>//=; done.
have P2: valid j by apply: (cohS (proj2 (rely_coh R1))).
have P3: l \in dom j by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
(* Two cases: received yes or no from a participant *)
case: D=>{Hin G Hw}Z; subst rt; rewrite/= in E1 R; case:ifP=>G1;
apply: ret_rule=>m' R'=>{d lg I1}[[d lg][I1]]; rewrite /rc_prep_inv ?E1 ?eqxx/=;
rewrite -(rely_loc' _ R1)(rely_loc' _ R')(rely_loc' _ R)=>Ej; rewrite locE//;
rewrite /rc_step eqxx/cstep_recv/= (getStC_K Cj' Ej) (getStL_Kc _ _ Ej) ?eqxx/=;
do? [by move: G1; case: (from \in pts)=>//=;
        case: (head 0 tms == e)=>//=/negbFE->/=];
do ? by case/andP:G1=>->/andP[]/eqP->G1; rewrite negbF ?eqxx//=;
     by move/negbTE: G1=>->.
Qed.

Next Obligation.
apply: ghC=>i[d lg]E1 C1.
have Pre: rc_prep_inv e (d, lg) [::] i by rewrite /rc_prep_inv/= E1.
apply: call_rule'=>[|acc m]; first by exists (d, lg).
case/(_ (d, lg) Pre)=>/=H1 H2 Cm; split=>//;  by move/negbNE: H1.
Qed.

Definition read_res (st : CStateT) :=
  let: (_, s) := st in
  match s with
  | CWaitPrepResponse _ res => res
  | _ => [::]
  end.

(* Reading the accumulated responses from the state *)
Program Definition read_resp_result :
  {(e : nat) (d : data) (lg : Log) res}, DHT [cn, W]
  (fun i => loc i = st :-> (e, CWaitPrepResponse d res) \+ log :-> lg,
   fun r m => loc m = st :-> (e, CWaitPrepResponse d res) \+ log :-> lg /\
              r = all (fun i => i) (map snd res)) :=
  Do (act (@skip_action_wrapper W cn l tpc (prEq tpc) _
          (fun s pf => all (fun i => i) (map snd (read_res (getStC pf)))))).
Next Obligation.
move=>/=i[e][d][lg][res] E/=.
apply: act_rule=>j R; split=>/=[|r k m]; first by case: (rely_coh R).
case=>/=H1[Cj]Z; subst j=>->R'.
split; first by rewrite (rely_loc' l R') (rely_loc' _ R).
by rewrite -(rely_loc' _ R) in H; rewrite (getStC_K _ H)/=.
Qed.

(*************************)
(* Coordinator's prelude *)
(*************************)

Program Definition coordinator_prelude (d : data) :
  {(lg : Log)}, DHT [cn, W]
  (fun i => exists (e : nat), loc i = st :-> (e, CInit) \+ log :-> lg,
   fun r m => let: (res, b) := r in
       exists (e : nat),
       [/\ loc m = st :-> (e, CWaitPrepResponse d res) \+ log :-> lg,
           perm_eq (map fst res) pts &
           b = all id (map snd res)]) :=
  Do (e <-- read_round;
      send_prep_loop e d;;
      res <-- receive_prep_loop e;
      b <-- read_resp_result;
      ret _ _ (res, b)).
Next Obligation.
move=>s0/=[lg][e]E0; apply: step.
apply: (gh_ex (g := (e, CInit, lg))).
apply: call_rule=>//=e' s1 [E1][pf]->C1.
rewrite !(getStC_K _ E1)=>{e'}.
apply: step; apply: (gh_ex (g:=lg)).
apply: call_rule=>//_ s2[_]/=E2 C2.
apply: step; apply: (gh_ex (g:=(d, lg))).
apply: call_rule=>//res s3/= [E3 H3] C3.
apply: step; apply: (gh_ex (g:=e)); apply: (gh_ex (g:=d));
  apply: (gh_ex (g:=lg)); apply: (gh_ex (g:=res)).
apply: call_rule=>// b s4 [E4]->{b}C4/=.
apply: ret_rule=>i5 R5 lg'[e'] E0'; exists e.
rewrite E0 in E0'; case: (hcancelV _ E0'); first by rewrite validPtUn.
case=>Z1 _; subst e'; move/(hcancelPtV _).
by rewrite validPt (rely_loc' _ R5)=>/(_ is_true_true)=><-.
Qed.

(*******************************************)
(***    Sending commits/aborts           ***)
(*******************************************)

(* Commit *)

Definition send_commit_loop_spec (e : nat) d := forall to_send,
  {lg : Log}, DHT [cn, W]
  (fun i =>
     (exists res,
         [/\ loc i = st :-> (e, CWaitPrepResponse d res) \+ log :-> lg,
          to_send = pts, perm_eq (map fst res) pts &
          all id (map snd res)]) \/
     if to_send == [::]
     then loc i = st :-> (e, CWaitAckCommit d [::]) \+ log :-> lg
     else exists (ps : seq nid),
         loc i = st :-> (e, CSentCommit d ps) \+ log :-> lg /\
         perm_eq pts (ps ++ to_send),
   fun (r : unit) m => loc m = st :-> (e, CWaitAckCommit d [::]) \+ log :-> lg).

Program Definition send_commit_loop e d : send_commit_loop_spec e d :=
  fun to_send  =>
    Do (fix rec to_send :=
          (match to_send with
           | to :: tos => send_commit e to ;; rec tos
           | [::] => ret _ _ tt
           end)) to_send.

Next Obligation.
apply: ghC=>s1 lg E1 C1; elim: to_send s1 E1 C1=>//=.
- move=>s1; case; first by case=>?[]_ Z; rewrite -Z in (PtsNonEmpty).
  by move=>E1 _; apply: ret_rule=>i2 R; rewrite (rely_loc' _ R).
move=>to tos Hi s1 H C1.
apply: step; apply: act_rule=>s2 R2/=.
have Pre: Actions.send_act_safe W (p:=tpc) cn l
          (cn_send_commit_trans cn pts others) [:: e] to s2.
- split; [by case: (rely_coh R2) | | |]; last first.
  + rewrite /Actions.filter_hooks umfilt0=>???.
    move => F.
    apply sym_eq in F.
    move: F.
    by move/find_some; rewrite dom0.
  + rewrite /Actions.can_send /nodes inE eqxx andbC/=.
    by rewrite -(cohD (proj2 (rely_coh R2)))/ddom domPt inE/=.
  case: (proj2 (rely_coh R2))=>_ _ _ _/(_ l); rewrite prEq=>C; split.
  + split=>//; case: H; first by case=>?[_]<-; rewrite inE eqxx.
    by case=>ps[_]/perm_mem->; rewrite mem_cat orbC inE eqxx.
  exists C; case:H=>[[res][P1]P2 P3|[ps][P1 P2]];[left|right];
  rewrite -(rely_loc' _ R2) in P1; rewrite (getStC_K _ P1);
  first by exists e, d, res=>//.
  exists e, d, ps; split=>//.
  move/perm_uniq: P2; rewrite Puniq.
  move => F.
  apply sym_eq in F.
  move: F.
  rewrite -cat_rcons cat_uniq -cats1 cat_uniq=>/andP[]/andP[_]/andP[].
  by rewrite /= orbC.

(* Using the postcondition *)
split=>// body i3 i4[Sf]/=St R3.
apply: Hi; last by case: (rely_coh R3).
right; rewrite (rely_loc' _ R3).
case: (Sf)=>C2/=[][]_ Tp [C2']/=; case; move=>[e'][d'].
- move=>[res][E'][]Z P1 P2/andP[P3] _; subst e'.
  case: H=>[[res'][E1]Te _ _|[ps]]; last first.
  + by rewrite -(rely_loc' _ R2)=>[][E1]; rewrite (getStC_K _ E1) in E'.
  rewrite -(rely_loc' _ R2) in E1; rewrite (getStC_K _ E1) in E'.
  case: E'=>Z Z'; subst res' d'.
  case: St=>Z1[h][];case=>->{h}; subst body=>G.
  rewrite (getStC_K _ E1) (getStL_Kc _ _ E1)
          /cstep_send -{1}Te inE eqxx/= P1 P2 in G.
  have X: (pts == [:: to]) = (tos == [::]).
  + rewrite -Te; apply/Bool.eq_iff_eq_true.
    by split; [move=>/eqP[]->|move/eqP->;rewrite eqxx].
    rewrite X in G; subst i3.
    rewrite locE//; [|by apply: (cohS C2)|by apply: (cohVl C2')].
  by case: ifP=>X'; rewrite X'//; exists [::to]; split=>//; rewrite -Te.
case=>ps[E'][]Z N/andP[P1]_; subst e'.
case: H=>[[res'][E1]Te _ _|[ps']].
- by rewrite -(rely_loc' _ R2) in E1; rewrite (getStC_K _ E1) in E'.
rewrite -(rely_loc' _ R2)=>[][E1] P2; rewrite (getStC_K _ E1) in E'.
case: E'=>Z1 Z2; subst d' ps'; case: St=>Z1[h][];case=>->{h}; subst body=>G.
rewrite (getStC_K _ E1) (getStL_Kc _ _ E1)
        /cstep_send Tp in G.
have X: perm_eq (to :: ps) pts = (tos == [::]).
- apply/Bool.eq_iff_eq_true; split.
  + move=>Hp'; move: (perm_trans Hp' P2).
    rewrite -[to::ps]cat1s -[to::tos]cat1s.
    move/permEl: (perm_catC ps [::to])=>Hs.
    move/(perm_trans Hs); rewrite -[_++[::_]]cats0 catA perm_cat2l.
    move/perm_size.
    move => F.
    apply sym_eq in F.
    move: F.
    by move/size0nil=>Z; subst tos.
  move/eqP=>Z; subst tos; rewrite perm_sym; apply: (perm_trans P2).
  by apply/permEl; move: (perm_catC ps [:: to]).
rewrite X in G=>{X}; subst i3.
rewrite locE//; [|by apply: (cohS C2)|by apply: (cohVl C2')].
case:ifP=>->//; exists (to :: ps);split=>//.
apply: (perm_trans P2).
by rewrite -[to::ps]cat1s -[to::tos]cat1s -!catA perm_catCA.
Qed.

Program Definition send_commits e d :
  {lg : Log}, DHT [cn, W]
  (fun i => exists res,
         [/\ loc i = st :-> (e, CWaitPrepResponse d res) \+ log :-> lg,
          perm_eq (map fst res) pts &
          all id (map snd res)],
   fun (r : unit) m => loc m = st :-> (e, CWaitAckCommit d [::]) \+ log :-> lg)
  := Do (send_commit_loop e d pts).
Next Obligation.
apply: ghC=>i lg[res][H1]H2 H3 C; apply: (gh_ex (g:=lg)).
apply: call_rule=>//; first by move=>_; left; exists res.
Qed.

(* Abort *)

Definition send_abort_loop_spec (e : nat) d := forall to_send,
  {lg : Log}, DHT [cn, W]
  (fun i =>
     (exists res,
         [/\ loc i = st :-> (e, CWaitPrepResponse d res) \+ log :-> lg,
          to_send = pts, perm_eq (map fst res) pts &
          has (fun r => negb r) (map snd res)]) \/
     if to_send == [::]
     then loc i = st :-> (e, CWaitAckAbort d [::]) \+ log :-> lg
     else exists (ps : seq nid),
         loc i = st :-> (e, CSentAbort d ps) \+ log :-> lg /\
         perm_eq pts (ps ++ to_send),
   fun (r : unit) m => loc m = st :-> (e, CWaitAckAbort d [::]) \+ log :-> lg).

Program Definition send_abort_loop e d : send_abort_loop_spec e d :=
  fun to_send  =>
    Do (fix rec to_send :=
          (match to_send with
           | to :: tos => send_abort e to ;; rec tos
           | [::] => ret _ _ tt
           end)) to_send.

Next Obligation.
apply: ghC=>s1 lg E1 C1; elim: to_send s1 E1 C1=>//=.
- move=>s1; case; first by case=>?[]_ Z; rewrite -Z in (PtsNonEmpty).
  by move=>E1 _; apply: ret_rule=>i2 R; rewrite (rely_loc' _ R).
move=>to tos Hi s1 H C1.
apply: step; apply: act_rule=>s2 R2/=.
have Pre: Actions.send_act_safe W (p:=tpc) cn l
          (cn_send_abort_trans cn pts others) [:: e] to s2.
- split; [by case: (rely_coh R2) | | |]; last first.
  + rewrite /Actions.filter_hooks umfilt0=>???.
    move => F.
    apply sym_eq in F.
    move: F.
    by move/find_some; rewrite dom0.
  + rewrite /Actions.can_send /nodes inE eqxx andbC/=.
    by rewrite -(cohD (proj2 (rely_coh R2)))/ddom domPt inE/=.
  case: (proj2 (rely_coh R2))=>_ _ _ _/(_ l); rewrite prEq=>C; split.
  + split=>//; case: H; first by case=>?[_]<-; rewrite inE eqxx.
    by case=>ps[_]/perm_mem->; rewrite mem_cat orbC inE eqxx.
  exists C; case:H=>[[res][P1]P2 P3|[ps][P1 P2]];[left|right];
  rewrite -(rely_loc' _ R2) in P1; rewrite (getStC_K _ P1);
  first by exists e, d, res=>//.
  exists e, d, ps; split=>//.
  move/perm_uniq: P2; rewrite Puniq.
  move => F.
  apply sym_eq in F.
  move: F.
  rewrite -cat_rcons cat_uniq -cats1 cat_uniq=>/andP[]/andP[_]/andP[].
  by rewrite /= orbC.

(* Using the postcondition *)
split=>// body i3 i4[Sf]/=St R3.
apply: Hi; last by case: (rely_coh R3).
right; rewrite (rely_loc' _ R3).
case: (Sf)=>C2/=[][]_ Tp [C2']/=; case; move=>[e'][d'].
- move=>[res][E'][]Z P1 P2/andP[P3] _; subst e'.
  case: H=>[[res'][E1]Te _ _|[ps]]; last first.
  + by rewrite -(rely_loc' _ R2)=>[][E1]; rewrite (getStC_K _ E1) in E'.
  rewrite -(rely_loc' _ R2) in E1; rewrite (getStC_K _ E1) in E'.
  case: E'=>Z Z'; subst res' d'.
  case: St=>Z1[h][];case=>->{h}; subst body=>G.
  have P2' : all id [seq i.2 | i <- res] = false
    by rewrite has_predC in P2; apply/negbTE.
  rewrite (getStC_K _ E1) (getStL_Kc _ _ E1)
          /cstep_send -{1}Te inE eqxx/= P1 P2' in G.
  have X: (pts == [:: to]) = (tos == [::]).
  + rewrite -Te; apply/Bool.eq_iff_eq_true.
    by split; [move=>/eqP[]->|move/eqP->;rewrite eqxx].
    rewrite X in G; subst i3.
    rewrite locE//; [|by apply: (cohS C2)|by apply: (cohVl C2')].
  by case: ifP=>X'; rewrite X'//; exists [::to]; split=>//; rewrite -Te.
case=>ps[E'][]Z N/andP[P1]_; subst e'.
case: H=>[[res'][E1]Te _ _|[ps']].
- by rewrite -(rely_loc' _ R2) in E1; rewrite (getStC_K _ E1) in E'.
rewrite -(rely_loc' _ R2)=>[][E1] P2; rewrite (getStC_K _ E1) in E'.
case: E'=>Z1 Z2; subst d' ps'; case: St=>Z1[h][];case=>->{h}; subst body=>G.
rewrite (getStC_K _ E1) (getStL_Kc _ _ E1)
        /cstep_send Tp in G.
have X: perm_eq (to :: ps) pts = (tos == [::]).
- apply/Bool.eq_iff_eq_true; split.
  + move=>Hp'; move: (perm_trans Hp' P2).
    rewrite -[to::ps]cat1s -[to::tos]cat1s.
    move/permEl: (perm_catC ps [::to])=>Hs.
    move/(perm_trans Hs); rewrite -[_++[::_]]cats0 catA perm_cat2l.
    move/perm_size.
    move => F.
    apply sym_eq in F.
    move: F.
    by move/size0nil=>Z; subst tos.
  move/eqP=>Z; subst tos; rewrite perm_sym; apply: (perm_trans P2).
  by apply/permEl; move: (perm_catC ps [:: to]).
rewrite X in G=>{X}; subst i3.
rewrite locE//; [|by apply: (cohS C2)|by apply: (cohVl C2')].
case:ifP=>->//; exists (to :: ps);split=>//.
apply: (perm_trans P2).
by rewrite -[to::ps]cat1s -[to::tos]cat1s -!catA perm_catCA.
Qed.

Program Definition send_aborts e d :
  {lg : Log}, DHT [cn, W]
  (fun i => exists res,
         [/\ loc i = st :-> (e, CWaitPrepResponse d res) \+ log :-> lg,
          perm_eq (map fst res) pts &
          has (fun r => negb r) (map snd res)],
   fun (r : unit) m => loc m = st :-> (e, CWaitAckAbort d [::]) \+ log :-> lg)
  := Do (send_abort_loop e d pts).
Next Obligation.
apply: ghC=>i lg[res][H1]H2 H3 C; apply: (gh_ex (g:=lg)).
apply: call_rule=>//; first by move=>_; left; exists res.
Qed.

(*******************************************)
(*** Receiving acks on commit/abort    ***)
(*******************************************)

(* Acks on Commit *)

(* Ending condition *)
Definition rc_commit_cond (acc : seq nid) := ~~ perm_eq acc pts.

(* Invariant relates the argument and the shape of the state *)
Definition rc_commit_inv (e : nat) (dl : data * Log) : cont (seq nid) :=
  fun acc i =>
    if perm_eq acc pts
    then loc i = st :-> (e.+1, CInit) \+ log :-> rcons dl.2 (true, dl.1)
    else loc i = st :-> (e, CWaitAckCommit dl.1 acc) \+ log :-> dl.2.

Program Definition receive_commit_loop (e : nat):
  {(dl : data * Log)}, DHT [cn, W]
  (fun i => loc i = st :-> (e, CWaitAckCommit dl.1 [::]) \+ log :-> dl.2,
   fun (res : seq nat) m =>
       loc m = st :-> (e.+1, CInit) \+ log :-> rcons dl.2 (true, dl.1))
  :=
  Do _ (@while cn W _ _ rc_commit_cond (rc_commit_inv e) _
        (fun acc => Do _ (
           r <-- tryrecv_commit_ack;
           match r with
           | Some (from, tg, body) =>
               if [&& from \in pts, head 0 body == e & from \notin acc]
               then ret _ _ (from :: acc)
               else ret _ _ acc
           | None => ret _ _ acc
           end
        )) [::]).

Next Obligation. by apply: with_spec x. Defined.
Next Obligation. by move:H; rewrite /rc_commit_inv (rely_loc' _ H0). Qed.

Next Obligation.
move=>i[[d lg]]/=[H1 I1]; apply: step.
apply: act_rule=>j R1/=; split; first by case: (rely_coh R1).
case=>[[[from tg] body] k m|k m]; last first.
- case=>Sf []Cj[]H; last by case: H=>[?][?][?][?][?][?][].
  have E: k = j by case: H.
  move: H; subst k=>_ R2; apply: ret_rule=>m' R3 {d lg I1}[d lg][H2].
  by rewrite /rc_commit_inv;
     rewrite -(rely_loc' _ R1)-(rely_loc' _ R2)-(rely_loc' _ R3).
case=>Sf []Cj[]=>[|[l'][mid][tms][from'][rt][pf][][E]Hin E1 Hw/=]; first by case.
case/andP=>/eqP Z G->{k}[]Z1 Z2 Z3 R2; subst l' from' tg body.
move: rt pf (coh_s (w:=W) l (s:=j) Cj) Hin R2 E1 Hw G E; rewrite prEq/=.
move=>rt pf Cj' Hin R E1 Hw G E.
have D: rt = cn_receive_commit_ack_trans _ _ _.
- by move: Hin G; do! [case ;first by move=>->].
(* Some forward facts: *)
have P1: valid (dstate (getS j))
  by apply: (@cohVl _ TPCCoh); case: (Cj')=>P1 P2 P3 P4; split=>//=; done.
have P2: valid j by apply: (cohS (proj2 (rely_coh R1))).
have P3: l \in dom j by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
(* The final blow *)
by subst rt; rewrite/= in E1 R; case:ifP=>G1;
apply: ret_rule=>m' R'; rewrite /rc_commit_cond=>{d lg I1}[[d lg][I1]];
rewrite /rc_commit_inv ?E1 ?eqxx/=;
rewrite -(rely_loc' _ R1)(rely_loc' _ R')(rely_loc' _ R)=>Ej; rewrite locE//;
rewrite /rc_step eqxx/cstep_recv/=;
move/negbTE: I1=>I1; rewrite I1 in Ej *;
rewrite (getStC_K Cj' Ej) (getStL_Kc _ _ Ej) ?eqxx/=;
move: G1; case: (from \in pts)=>//=;case: (head 0 tms == e)=>//=;
case: (from \in acc)=>//=_; case:ifP=>X; rewrite X//=.
Qed.

Next Obligation.
apply: ghC=>i[d lg]E1 C1.
have Pre: rc_commit_inv e (d, lg) [::] i.
- rewrite /rc_commit_inv/= E1/=.
  have X: perm_eq [::] pts = false.
  - apply/negP.
    move/perm_size.
    move => F.
    apply sym_eq in F.
    move: F.
    move/size0nil=>Z.
    by move: (PtsNonEmpty); rewrite Z.
  by rewrite X.
apply: call_rule'=>[|acc m]; first by exists (d, lg).
case/(_ (d, lg) Pre)=>/=H1 H2 Cm.
by move/negbNE: H1=>H1; rewrite /rc_commit_inv H1 in H2.
Qed.

(* Acks on Abort *)

(* Ending condition *)
Definition rc_abort_cond (acc : seq nid) := ~~ perm_eq acc pts.

(* Invariant relates the argument and the shape of the state *)
Definition rc_abort_inv (e : nat) (dl : data * Log) : cont (seq nid) :=
  fun acc i =>
    if perm_eq acc pts
    then loc i = st :-> (e.+1, CInit) \+ log :-> rcons dl.2 (false, dl.1)
    else loc i = st :-> (e, CWaitAckAbort dl.1 acc) \+ log :-> dl.2.

Program Definition receive_abort_loop (e : nat):
  {(dl : data * Log)}, DHT [cn, W]
  (fun i => loc i = st :-> (e, CWaitAckAbort dl.1 [::]) \+ log :-> dl.2,
   fun (res : seq nat) m =>
       loc m = st :-> (e.+1, CInit) \+ log :-> rcons dl.2 (false, dl.1))
  :=
  Do _ (@while cn W _ _ rc_abort_cond (rc_abort_inv e) _
        (fun acc => Do _ (
           r <-- tryrecv_abort_ack;
           match r with
           | Some (from, tg, body) =>
               if [&& from \in pts, head 0 body == e & from \notin acc]
               then ret _ _ (from :: acc)
               else ret _ _ acc
           | None => ret _ _ acc
           end
        )) [::]).

Next Obligation. by apply: with_spec x. Defined.
Next Obligation. by move:H; rewrite /rc_abort_inv (rely_loc' _ H0). Qed.

Next Obligation.
move=>i[[d lg]]/=[H1 I1]; apply: step.
apply: act_rule=>j R1/=; split; first by case: (rely_coh R1).
case=>[[[from tg] body] k m|k m]; last first.
- case=>Sf []Cj[]H; last by case: H=>[?][?][?][?][?][?][].
  have E: k = j by case: H.
  move: H; subst k=>_ R2; apply: ret_rule=>m' R3 {d lg I1}[d lg][H2].
  by rewrite /rc_abort_inv;
     rewrite -(rely_loc' _ R1)-(rely_loc' _ R2)-(rely_loc' _ R3).
case=>Sf []Cj[]=>[|[l'][mid][tms][from'][rt][pf][][E]Hin E1 Hw/=]; first by case.
case/andP=>/eqP Z G->{k}[]Z1 Z2 Z3 R2; subst l' from' tg body.
move: rt pf (coh_s (w:=W) l (s:=j) Cj) Hin R2 E1 Hw G E; rewrite prEq/=.
move=>rt pf Cj' Hin R E1 Hw G E.
have D: rt = cn_receive_abort_ack_trans _ _ _.
- by move: Hin G; do! [case ;first by move=>->].
(* Some forward facts: *)
have P1: valid (dstate (getS j))
  by apply: (@cohVl _ TPCCoh); case: (Cj')=>P1 P2 P3 P4; split=>//=; done.
have P2: valid j by apply: (cohS (proj2 (rely_coh R1))).
have P3: l \in dom j by rewrite -(cohD (proj2 (rely_coh R1)))/ddom domPt inE/=.
(* The final blow *)
by subst rt; rewrite/= in E1 R; case:ifP=>G1;
apply: ret_rule=>m' R'; rewrite /rc_abort_cond=>{d lg I1}[[d lg][I1]];
rewrite /rc_abort_inv ?E1 ?eqxx/=;
rewrite -(rely_loc' _ R1)(rely_loc' _ R')(rely_loc' _ R)=>Ej; rewrite locE//;
rewrite /rc_step eqxx/cstep_recv/=;
move/negbTE: I1=>I1; rewrite I1 in Ej *;
rewrite (getStC_K Cj' Ej) (getStL_Kc _ _ Ej) ?eqxx/=;
move: G1; case: (from \in pts)=>//=;case: (head 0 tms == e)=>//=;
case: (from \in acc)=>//=_; case:ifP=>X; rewrite X//=.
Qed.

Next Obligation.
apply: ghC=>i[d lg]E1 C1.
have Pre: rc_abort_inv e (d, lg) [::] i.
- rewrite /rc_abort_inv/= E1/=.
  have X: perm_eq [::] pts = false.
  - apply/negP.
    move/perm_size.
    move => F.
    apply sym_eq in F.
    move: F.
    move/size0nil=>Z.
    by move: (PtsNonEmpty); rewrite Z.
  by rewrite X.
apply: call_rule'=>[|acc m]; first by exists (d, lg).
case/(_ (d, lg) Pre)=>/=H1 H2 Cm.
by move/negbNE: H1=>H1; rewrite /rc_abort_inv H1 in H2.
Qed.

(*****************************************************)
(*      Full coordinator Implementation              *)
(*****************************************************)

Program Definition coordinator_round (d : data) :
  {(e : nat)(lg : Log)}, DHT [cn, W]
  (fun i => loc i = st :-> (e, CInit) \+ log :-> lg,
   fun res m => loc m = st :-> (e.+1, CInit) \+ log :-> rcons lg (res, d))
  :=
  Do (e <-- read_round;
      send_prep_loop e d;;
      res <-- receive_prep_loop e;
      b <-- read_resp_result;
      (if b
       then send_commits e d;;
            receive_commit_loop e
       else send_aborts e d;;
            receive_abort_loop e);;
      ret _ _ b).
Next Obligation.
move=>s0/=[e][lg]E0; apply: step.
apply: (gh_ex (g := (e, CInit, lg))).
apply: call_rule=>//e' s1 [E1][pf]->C1.
rewrite !(getStC_K _ E1)=>{e'}.
apply: step; apply: (gh_ex (g:=lg)).
apply: call_rule=>//_ s2[_]/=E2 C2.
apply: step; apply: (gh_ex (g:=(d, lg))).
apply: call_rule=>//res s3/= [E3 H3] C3.
apply: step; apply: (gh_ex (g:=e)); apply: (gh_ex (g:=d));
  apply: (gh_ex (g:=lg)); apply: (gh_ex (g:=res)).
apply: call_rule=>// b s4 [E4]->{b}C4/=.
case:ifP=>A.
- do![apply: step]; apply: (gh_ex (g:=lg)).
  apply: call_rule=>_; first by exists res.
  move=>s5 E5 C5; apply: (gh_ex (g:=(d, lg))).
  apply: call_rule=>//_ s6 E6 C6.
  apply: ret_rule=>i6 R6 e' lg' E0'.
  rewrite E0 in E0'; case: (hcancelV _ E0'); first by rewrite validPtUn.
  + case=>Z1 _; subst e'; move/(hcancelPtV _).
  by rewrite validPt (rely_loc' _ R6)=>/(_ is_true_true)=><-.
do![apply: step]; apply: (gh_ex (g:=lg)).
apply: call_rule=>_; first by exists res; rewrite has_predC A.
move=>s5 E5 C5; apply: (gh_ex (g:=(d, lg))).
apply: call_rule=>//_ s6 E6 C6.
apply: ret_rule=>i6 R6 e' lg' E0'.
rewrite E0 in E0'; case: (hcancelV _ E0'); first by rewrite validPtUn.
- case=>Z1 _; subst e'; move/(hcancelPtV _).
by rewrite validPt (rely_loc' _ R6)=>/(_ is_true_true)=><-.
Qed.

(**************************************************)
(*
Overall Implementation effort:

2 full person-days

TODO: Do something about severe proof duplication!

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

(*****************************************************)
(*    Announcing a list of data transactions         *)
(*****************************************************)

Definition coord_loop_spec := forall dts,
  {(el : nat * Log)}, DHT [cn, W]
  (fun i =>  loc i = st :-> (el.1, CInit) \+ log :-> el.2,
   fun (_ : unit) m => exists (chs : seq bool),
     loc m = st :-> (el.1 + (size dts), CInit) \+ log :-> (el.2 ++ (seq.zip chs dts))).

Program Definition coord_loop : coord_loop_spec :=
  fun dts  =>
    Do (fix rec dts :=
          (match dts with
           | d :: dts => coordinator_round d ;; rec dts
           | [::] => ret _ _ tt
           end)) dts.
Next Obligation.
apply:ghC=>i; elim: dts i=>//=[|d ds/= Hi]i1 [e lg] E1 C1.
- by apply: ret_rule=>i2 R1; exists [::]; rewrite cats0 addn0 (rely_loc' _ R1).
apply: step; apply: (gh_ex (g:=e)); apply: (gh_ex (g:=lg)).
apply: call_rule=>//b i2/=E2 C2/=.
move:(Hi i2 (e.+1, rcons lg (b, d)) E2 C2)=>/=; apply: vrf_mono=>_ i3 [chs]->.
rewrite -[e.+1]addn1 -[(size ds).+1]addn1 addnAC addnA; exists (b :: chs)=>/=.
by rewrite -cats1 -!catA/=.
Qed.

Program Definition coordinator_loop_zero (ds : seq data) :
  DHT [cn, W]
  (fun i =>  loc i = st :-> (0, CInit) \+ log :-> ([::] : seq (bool * data)),
   fun (_ : unit) m => exists (chs : seq bool),
       loc m = st :-> (size ds, CInit) \+ log :-> (seq.zip chs ds))
  := Do (coord_loop ds).
Next Obligation.
by move=>i/=E; apply: (gh_ex (g:=(0, [::]))); apply: call_rule.
Qed.

(*****************************************************)
(*          Checking the invariant rule              *)
(*****************************************************)

(* Section CheckingDummyInv. *)

(* Require Import TwoPhaseInductiveInv. *)
(* Definition tpc' := tpc_with_inv l cn pts others Hnin PtsNonEmpty. *)

(* Definition W' := mkWorld tpc'. *)
(* Notation ii := (tpc_ii l cn pts others Hnin PtsNonEmpty). *)

(* (* Check with_inv ii. *) *)

(* Program Definition coordinator_inv (d : data) : *)
(*   {(e : nat)(lg : Log)}, DHT [cn, W']  *)
(*   (fun i => loc i = st :-> (e, CInit) \+ log :-> lg, *)
(*    fun r m => 1 == 1 /\ *)
(*        loc m = st :-> (e.+1, CInit) \+ log :-> rcons lg (r, d)) *)
(*   := Do (with_inv ii (coordinator_round d)). *)
(* Next Obligation. *)
(* move=>i1/=[e][lg]E1; apply with_inv_rule'. *)
(* apply: (gh_ex (g:=e)); apply: (gh_ex (g:=lg)). *)
(* apply: call_rule=>//r m H/=C' I e' lg' E'. *)
(* have X: e' = e /\ lg' = lg. *)
(* rewrite E1 in E'; case: (hcancelV _ E'); first by rewrite hvalidPtUn. *)
(* - case=>Z1 _; subst e'; move/(hcancelPtV _)=>/=. *)
(*   by rewrite hvalidPt/=/(_ is_true_true)=><-. *)
(* case: X=>Z1 Z2; subst e' lg'; split; last by []. *)
(* move: I; rewrite/TwoPhaseInductiveInv.Inv. *)
(* done. *)
(* Qed. *)

(* End CheckingDummyInv. *)

End CoordinatorImplementation.
End TwoPhaseCoordinator.

Module Exports.
Section Exports.

Definition coordinator_loop_zero := coordinator_loop_zero.
Definition coordinator_loop := coord_loop.
Definition coordinator_round := coordinator_round.

End Exports.
End Exports.

End TwoPhaseCoordinator.

Export TwoPhaseCoordinator.Exports.