From iris.algebra Require Export updates local_updates frac dfrac agree.
From iris.algebra Require Import proofmode_classes big_op.
From iris.prelude Require Import options.

(** The view camera with fractional authoritative elements *)
(** The view camera, which is reminiscent of the views framework, is used to
  provide a logical/"small-footprint" "view" of some "large-footprint" piece of
  data, which can be shared in the separation logic sense, i.e., different parts
  of the data can be separately owned by different functions or threads. This is
  achieved using the two elements of the view camera:

- The authoritative element [●V a], which describes the data under consideration.
- The fragment [◯V b], which provides a logical view of the data [a].

To enable sharing of the fragments, the type of fragments is equipped with a
camera structure so ownership of fragments can be split. Concretely, fragments
enjoy the rule [◯V (b1 ⋅ b2) = ◯V b1 ⋅ ◯V b2].

To enable sharing of the authoritative element [●V{dq} a], it is equipped with a
discardable fraction [dq]. Updates are only possible with the full authoritative
element [●V a] (syntax for [●V{#1} a]]), while fractional authoritative elements
have agreement, i.e., [✓ (●V{dq1} a1 ⋅ ●V{dq2} a2) → a1 ≡ a2]. *)

(** * The view relation *)
(** To relate the authoritative element [a] to its possible fragments [b], the
view camera is parametrized by a (step-indexed) relation [view_rel n a b]. This
relation should be a.) closed under smaller step-indexes [n], b.) non-expansive
w.r.t. the argument [a], c.) closed under smaller [b] (which implies
non-expansiveness w.r.t. [b]), and d.) ensure validity of the argument [b].

Note 1: Instead of requiring both a step-indexed and a non-step-indexed version
of the relation (like cameras do for validity), we use [∀ n, view_rel n] as the
non-step-indexed version. This is anyway necessary when using [≼{n}] as the
relation (like the authoritative camera does) as its non-step-indexed version
is not equivalent to [∀ n, x ≼{n} y].

Note 2: The view relation is defined as a canonical structure so that given a
relation [nat → A → B → Prop], the instance with the laws can be inferred. We do
not use type classes for this purpose because cameras themselves are represented
using canonical structures. It has proven fragile for a canonical structure
instance to take a type class as a parameter (in this case, [viewR] would need
to take a class with the view relation laws). *)
Structure view_rel (A : ofe) (B : ucmra) := ViewRel {
  view_rel_holds :> nat → A → B → Prop;
  view_rel_mono n1 n2 a1 a2 b1 b2 :
    view_rel_holds n1 a1 b1 →
    a1 ≡{n2}≡ a2 →
    b2 ≼{n2} b1 →
    n2 ≤ n1 →
    view_rel_holds n2 a2 b2;
  view_rel_validN n a b :
    view_rel_holds n a b → ✓{n} b;
  view_rel_unit n :
    ∃ a, view_rel_holds n a ε
}.
Global Arguments ViewRel {_ _} _ _.
Global Arguments view_rel_holds {_ _} _ _ _ _.
Global Instance: Params (@view_rel_holds) 4 := {}.

Global Instance view_rel_ne {A B} (rel : view_rel A B) n :
  Proper (dist n ==> dist n ==> iff) (rel n).
Proof.
  intros a1 a2 Ha b1 b2 Hb.
  split=> ?; (eapply view_rel_mono; [done|done|by rewrite Hb|done]).
Qed.
Global Instance view_rel_proper {A B} (rel : view_rel A B) n :
  Proper ((≡) ==> (≡) ==> iff) (rel n).
Proof. intros a1 a2 Ha b1 b2 Hb. apply view_rel_ne; by apply equiv_dist. Qed.

Class ViewRelDiscrete {A B} (rel : view_rel A B) :=
  view_rel_discrete n a b : rel 0 a b → rel n a b.

(** * Definition of the view camera *)
(** To make use of the lemmas provided in this file, elements of [view] should
always be constructed using [●V] and [◯V], and never using the constructor
[View]. *)
Record view {A B} (rel : nat → A → B → Prop) :=
  View { view_auth_proj : option (dfrac * agree A) ; view_frag_proj : B }.
Add Printing Constructor view.
Global Arguments View {_ _ _} _ _.
Global Arguments view_auth_proj {_ _ _} _.
Global Arguments view_frag_proj {_ _ _} _.
Global Instance: Params (@View) 3 := {}.
Global Instance: Params (@view_auth_proj) 3 := {}.
Global Instance: Params (@view_frag_proj) 3 := {}.

Definition view_auth {A B} {rel : view_rel A B} (dq : dfrac) (a : A) : view rel :=
  View (Some (dq, to_agree a)) ε.
Definition view_frag {A B} {rel : view_rel A B} (b : B) : view rel := View None b.
Typeclasses Opaque view_auth view_frag.

Global Instance: Params (@view_auth) 3 := {}.
Global Instance: Params (@view_frag) 3 := {}.

Notation "●V dq a" := (view_auth dq a)
  (at level 20, dq custom dfrac at level 1, format "●V dq  a").
Notation "◯V a" := (view_frag a) (at level 20).

(** * The OFE structure *)
(** We omit the usual [equivI] lemma because it is hard to state a suitably
general version in terms of [●V] and [◯V], and because such a lemma has never
been needed in practice. *)
Section ofe.
  Context {A B : ofe} (rel : nat → A → B → Prop).
  Implicit Types a : A.
  Implicit Types ag : option (dfrac * agree A).
  Implicit Types b : B.
  Implicit Types x y : view rel.

  Local Instance view_equiv : Equiv (view rel) := λ x y,
    view_auth_proj x ≡ view_auth_proj y ∧ view_frag_proj x ≡ view_frag_proj y.
  Local Instance view_dist : Dist (view rel) := λ n x y,
    view_auth_proj x ≡{n}≡ view_auth_proj y ∧
    view_frag_proj x ≡{n}≡ view_frag_proj y.

  Global Instance View_ne : NonExpansive2 (@View A B rel).
  Proof. by split. Qed.
  Global Instance View_proper : Proper ((≡) ==> (≡) ==> (≡)) (@View A B rel).
  Proof. by split. Qed.
  Global Instance view_auth_proj_ne: NonExpansive (@view_auth_proj A B rel).
  Proof. by destruct 1. Qed.
  Global Instance view_auth_proj_proper :
    Proper ((≡) ==> (≡)) (@view_auth_proj A B rel).
  Proof. by destruct 1. Qed.
  Global Instance view_frag_proj_ne : NonExpansive (@view_frag_proj A B rel).
  Proof. by destruct 1. Qed.
  Global Instance view_frag_proj_proper :
    Proper ((≡) ==> (≡)) (@view_frag_proj A B rel).
  Proof. by destruct 1. Qed.

  Definition view_ofe_mixin : OfeMixin (view rel).
  Proof. by apply (iso_ofe_mixin (λ x, (view_auth_proj x, view_frag_proj x))). Qed.
  Canonical Structure viewO := Ofe (view rel) view_ofe_mixin.

  Global Instance View_discrete ag b :
    Discrete ag → Discrete b → Discrete (View ag b).
  Proof. by intros ?? [??] [??]; split; apply: discrete. Qed.
  Global Instance view_ofe_discrete :
    OfeDiscrete A → OfeDiscrete B → OfeDiscrete viewO.
  Proof. intros ?? [??]; apply _. Qed.
End ofe.

(** * The camera structure *)
Section cmra.
  Context {A B} (rel : view_rel A B).
  Implicit Types a : A.
  Implicit Types ag : option (dfrac * agree A).
  Implicit Types b : B.
  Implicit Types x y : view rel.
  Implicit Types q : frac.
  Implicit Types dq : dfrac.

  Global Instance view_auth_ne dq : NonExpansive (@view_auth A B rel dq).
  Proof. solve_proper. Qed.
  Global Instance view_auth_proper dq : Proper ((≡) ==> (≡)) (@view_auth A B rel dq).
  Proof. solve_proper. Qed.
  Global Instance view_frag_ne : NonExpansive (@view_frag A B rel).
  Proof. done. Qed.
  Global Instance view_frag_proper : Proper ((≡) ==> (≡)) (@view_frag A B rel).
  Proof. done. Qed.

  Global Instance view_auth_dist_inj n :
    Inj2 (=) (dist n) (dist n) (@view_auth A B rel).
  Proof.
    intros dq1 a1 dq2 a2 [Hag ?]; inversion Hag as [?? [??]|]; simplify_eq/=.
    split; [done|]. by apply (inj to_agree).
  Qed.
  Global Instance view_auth_inj : Inj2 (=) (≡) (≡) (@view_auth A B rel).
  Proof.
    intros dq1 a1 dq2 a2 [Hag ?]; inversion Hag as [?? [??]|]; simplify_eq/=.
    split; [done|]. by apply (inj to_agree).
  Qed.
  Global Instance view_frag_dist_inj n : Inj (dist n) (dist n) (@view_frag A B rel).
  Proof. by intros ?? [??]. Qed.
  Global Instance view_frag_inj : Inj (≡) (≡) (@view_frag A B rel).
  Proof. by intros ?? [??]. Qed.

  Local Instance view_valid_instance : Valid (view rel) := λ x,
    match view_auth_proj x with
    | Some (dq, ag) =>
       ✓ dq ∧ (∀ n, ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x))
    | None => ∀ n, ∃ a, rel n a (view_frag_proj x)
    end.
  Local Instance view_validN_instance : ValidN (view rel) := λ n x,
    match view_auth_proj x with
    | Some (dq, ag) =>
       ✓{n} dq ∧ ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x)
    | None => ∃ a, rel n a (view_frag_proj x)
    end.
  Local Instance view_pcore_instance : PCore (view rel) := λ x,
    Some (View (core (view_auth_proj x)) (core (view_frag_proj x))).
  Local Instance view_op_instance : Op (view rel) := λ x y,
    View (view_auth_proj x ⋅ view_auth_proj y) (view_frag_proj x ⋅ view_frag_proj y).

  Local Definition view_valid_eq :
    valid = λ x,
      match view_auth_proj x with
      | Some (dq, ag) =>
         ✓ dq ∧ (∀ n, ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x))
      | None => ∀ n, ∃ a, rel n a (view_frag_proj x)
      end := eq_refl _.
  Local Definition view_validN_eq :
    validN = λ n x,
      match view_auth_proj x with
      | Some (dq, ag) => ✓{n} dq ∧ ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x)
      | None => ∃ a, rel n a (view_frag_proj x)
      end := eq_refl _.
  Local Definition view_pcore_eq :
      pcore = λ x, Some (View (core (view_auth_proj x)) (core (view_frag_proj x))) :=
    eq_refl _.
  Local Definition view_core_eq :
      core = λ x, View (core (view_auth_proj x)) (core (view_frag_proj x)) :=
    eq_refl _.
  Local Definition view_op_eq :
      op = λ x y, View (view_auth_proj x ⋅ view_auth_proj y)
                       (view_frag_proj x ⋅ view_frag_proj y) :=
    eq_refl _.

  Lemma view_cmra_mixin : CmraMixin (view rel).
  Proof.
    apply (iso_cmra_mixin_restrict
      (λ x : option (dfrac * agree A) * B, View x.1 x.2)
      (λ x, (view_auth_proj x, view_frag_proj x))); try done.
    - intros [x b]. by rewrite /= pair_pcore !cmra_pcore_core.
    - intros n [[[dq ag]|] b]; rewrite /= view_validN_eq /=.
      + intros (?&a&->&?). repeat split; simpl; [done|]. by eapply view_rel_validN.
      + intros [a ?]. repeat split; simpl. by eapply view_rel_validN.
    - rewrite view_validN_eq.
      intros n [x1 b1] [x2 b2] [Hx ?]; simpl in *;
        destruct Hx as [[q1 ag1] [q2 ag2] [??]|]; intros ?; by ofe_subst.
    - rewrite view_valid_eq view_validN_eq.
      intros [[[dq aa]|] b]; rewrite /= ?cmra_valid_validN; naive_solver.
    - rewrite view_validN_eq=> n [[[dq ag]|] b] /=.
      + intros [? (a&?&?)]; split; [done|].
        exists a; split; [by eauto using dist_le|].
        apply view_rel_mono with (S n) a b; auto with lia.
      + intros [a ?]. exists a. apply view_rel_mono with (S n) a b; auto with lia.
    - rewrite view_validN_eq=> n [[[q1 ag1]|] b1] [[[q2 ag2]|] b2] /=.
      + intros [?%cmra_validN_op_l (a & Haga & ?)]. split; [done|].
        assert (ag1 ≡{n}≡ ag2) as Ha12 by (apply agree_op_invN; by rewrite Haga).
        exists a. split; [by rewrite -Haga -Ha12 agree_idemp|].
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
      + intros [? (a & Haga & ?)]. split; [done|]. exists a; split; [done|].
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
      + intros [? (a & Haga & ?)]. exists a.
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
      + intros [a ?]. exists a.
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
  Qed.
  Canonical Structure viewR := Cmra (view rel) view_cmra_mixin.

  Global Instance view_auth_discrete dq a :
    Discrete a → Discrete (ε : B) → Discrete (●V{dq} a : view rel).
  Proof. intros. apply View_discrete; apply _. Qed.
  Global Instance view_frag_discrete b :
    Discrete b → Discrete (◯V b : view rel).
  Proof. intros. apply View_discrete; apply _. Qed.
  Global Instance view_cmra_discrete :
    OfeDiscrete A → CmraDiscrete B → ViewRelDiscrete rel →
    CmraDiscrete viewR.
  Proof.
    split; [apply _|]=> -[[[dq ag]|] b]; rewrite view_valid_eq view_validN_eq /=.
    - rewrite -cmra_discrete_valid_iff.
      setoid_rewrite <-(discrete_iff _ ag). naive_solver.
    - naive_solver.
  Qed.

  Local Instance view_empty_instance : Unit (view rel) := View ε ε.
  Lemma view_ucmra_mixin : UcmraMixin (view rel).
  Proof.
    split; simpl.
    - rewrite view_valid_eq /=. apply view_rel_unit.
    - by intros x; constructor; rewrite /= left_id.
    - do 2 constructor; [done| apply (core_id_core _)].
  Qed.
  Canonical Structure viewUR := Ucmra (view rel) view_ucmra_mixin.

  (** Operation *)
  Lemma view_auth_dfrac_op dq1 dq2 a : ●V{dq1 ⋅ dq2} a ≡ ●V{dq1} a ⋅ ●V{dq2} a.
  Proof.
    intros; split; simpl; last by rewrite left_id.
    by rewrite -Some_op -pair_op agree_idemp.
  Qed.
  Global Instance view_auth_dfrac_is_op dq dq1 dq2 a :
    IsOp dq dq1 dq2 → IsOp' (●V{dq} a) (●V{dq1} a) (●V{dq2} a).
  Proof. rewrite /IsOp' /IsOp => ->. by rewrite -view_auth_dfrac_op. Qed.

  Lemma view_frag_op b1 b2 : ◯V (b1 ⋅ b2) = ◯V b1 ⋅ ◯V b2.
  Proof. done. Qed.
  Lemma view_frag_mono b1 b2 : b1 ≼ b2 → ◯V b1 ≼ ◯V b2.
  Proof. intros [c ->]. rewrite view_frag_op. apply cmra_included_l. Qed.
  Lemma view_frag_core b : core (◯V b) = ◯V (core b).
  Proof. done. Qed.
  Lemma view_both_core_discarded a b :
    core (●V□ a ⋅ ◯V b) ≡ ●V□ a ⋅ ◯V (core b).
  Proof. rewrite view_core_eq view_op_eq /= !left_id //. Qed.
  Lemma view_both_core_frac q a b :
    core (●V{#q} a ⋅ ◯V b) ≡ ◯V (core b).
  Proof. rewrite view_core_eq view_op_eq /= !left_id //. Qed.

  Global Instance view_auth_core_id a : CoreId (●V□ a).
  Proof. do 2 constructor; simpl; auto. apply: core_id_core. Qed.
  Global Instance view_frag_core_id b : CoreId b → CoreId (◯V b).
  Proof. do 2 constructor; simpl; auto. apply: core_id_core. Qed.
  Global Instance view_both_core_id a b : CoreId b → CoreId (●V□ a ⋅ ◯V b).
  Proof. do 2 constructor; simpl; auto. rewrite !left_id. apply: core_id_core. Qed.
  Global Instance view_frag_is_op b b1 b2 :
    IsOp b b1 b2 → IsOp' (◯V b) (◯V b1) (◯V b2).
  Proof. done. Qed.
  Global Instance view_frag_sep_homomorphism :
    MonoidHomomorphism op op (≡) (@view_frag A B rel).
  Proof. by split; [split; try apply _|]. Qed.

  Lemma big_opL_view_frag {C} (g : nat → C → B) (l : list C) :
    (◯V [^op list] k↦x ∈ l, g k x) ≡ [^op list] k↦x ∈ l, ◯V (g k x).
  Proof. apply (big_opL_commute _). Qed.
  Lemma big_opM_view_frag `{Countable K} {C} (g : K → C → B) (m : gmap K C) :
    (◯V [^op map] k↦x ∈ m, g k x) ≡ [^op map] k↦x ∈ m, ◯V (g k x).
  Proof. apply (big_opM_commute _). Qed.
  Lemma big_opS_view_frag `{Countable C} (g : C → B) (X : gset C) :
    (◯V [^op set] x ∈ X, g x) ≡ [^op set] x ∈ X, ◯V (g x).
  Proof. apply (big_opS_commute _). Qed.
  Lemma big_opMS_view_frag `{Countable C} (g : C → B) (X : gmultiset C) :
    (◯V [^op mset] x ∈ X, g x) ≡ [^op mset] x ∈ X, ◯V (g x).
  Proof. apply (big_opMS_commute _). Qed.

  (** Validity *)
  Lemma view_auth_dfrac_op_invN n dq1 a1 dq2 a2 :
    ✓{n} (●V{dq1} a1 ⋅ ●V{dq2} a2) → a1 ≡{n}≡ a2.
  Proof.
    rewrite /op /view_op_instance /= left_id -Some_op -pair_op view_validN_eq /=.
    intros (?&?& Eq &?). apply (inj to_agree), agree_op_invN. by rewrite Eq.
  Qed.
  Lemma view_auth_dfrac_op_inv dq1 a1 dq2 a2 : ✓ (●V{dq1} a1 ⋅ ●V{dq2} a2) → a1 ≡ a2.
  Proof.
    intros ?. apply equiv_dist. intros n.
    by eapply view_auth_dfrac_op_invN, cmra_valid_validN.
  Qed.
  Lemma view_auth_dfrac_op_inv_L `{!LeibnizEquiv A} dq1 a1 dq2 a2 :
    ✓ (●V{dq1} a1 ⋅ ●V{dq2} a2) → a1 = a2.
  Proof. by intros ?%view_auth_dfrac_op_inv%leibniz_equiv. Qed.

  Lemma view_auth_dfrac_validN n dq a : ✓{n} (●V{dq} a) ↔ ✓{n}dq ∧ rel n a ε.
  Proof.
    rewrite view_validN_eq /=. apply and_iff_compat_l. split; [|by eauto].
    by intros [? [->%(inj to_agree) ?]].
  Qed.
  Lemma view_auth_validN n a : ✓{n} (●V a) ↔ rel n a ε.
  Proof. rewrite view_auth_dfrac_validN. split; [naive_solver|done]. Qed.

  Lemma view_auth_dfrac_op_validN n dq1 dq2 a1 a2 :
    ✓{n} (●V{dq1} a1 ⋅ ●V{dq2} a2) ↔ ✓(dq1 ⋅ dq2) ∧ a1 ≡{n}≡ a2 ∧ rel n a1 ε.
  Proof.
    split.
    - intros Hval. assert (a1 ≡{n}≡ a2) as Ha by eauto using view_auth_dfrac_op_invN.
      revert Hval. rewrite Ha -view_auth_dfrac_op view_auth_dfrac_validN. naive_solver.
    - intros (?&->&?). by rewrite -view_auth_dfrac_op view_auth_dfrac_validN.
  Qed.
  Lemma view_auth_op_validN n a1 a2 : ✓{n} (●V a1 ⋅ ●V a2) ↔ False.
  Proof. rewrite view_auth_dfrac_op_validN. naive_solver. Qed.

  Lemma view_frag_validN n b : ✓{n} (◯V b) ↔ ∃ a, rel n a b.
  Proof. done. Qed.

  Lemma view_both_dfrac_validN n dq a b :
    ✓{n} (●V{dq} a ⋅ ◯V b) ↔ ✓dq ∧ rel n a b.
  Proof.
    rewrite view_validN_eq /=. apply and_iff_compat_l.
    setoid_rewrite (left_id _ _ b). split; [|by eauto].
    by intros [?[->%(inj to_agree)]].
  Qed.
  Lemma view_both_validN n a b : ✓{n} (●V a ⋅ ◯V b) ↔ rel n a b.
  Proof. rewrite view_both_dfrac_validN. split; [naive_solver|done]. Qed.

  Lemma view_auth_dfrac_valid dq a : ✓ (●V{dq} a) ↔ ✓dq ∧ ∀ n, rel n a ε.
  Proof.
    rewrite view_valid_eq /=. apply and_iff_compat_l. split; [|by eauto].
    intros H n. by destruct (H n) as [? [->%(inj to_agree) ?]].
  Qed.
  Lemma view_auth_valid a : ✓ (●V a) ↔ ∀ n, rel n a ε.
  Proof. rewrite view_auth_dfrac_valid. split; [naive_solver|done]. Qed.

  Lemma view_auth_dfrac_op_valid dq1 dq2 a1 a2 :
    ✓ (●V{dq1} a1 ⋅ ●V{dq2} a2) ↔ ✓(dq1 ⋅ dq2) ∧ a1 ≡ a2 ∧ ∀ n, rel n a1 ε.
  Proof.
    rewrite 1!cmra_valid_validN equiv_dist. setoid_rewrite view_auth_dfrac_op_validN.
    split; last naive_solver. intros Hv.
    split; last naive_solver. apply (Hv 0).
  Qed.
  Lemma view_auth_op_valid a1 a2 : ✓ (●V a1 ⋅ ●V a2) ↔ False.
  Proof. rewrite view_auth_dfrac_op_valid. naive_solver. Qed.

  Lemma view_frag_valid b : ✓ (◯V b) ↔ ∀ n, ∃ a, rel n a b.
  Proof. done. Qed.

  Lemma view_both_dfrac_valid dq a b : ✓ (●V{dq} a ⋅ ◯V b) ↔ ✓dq ∧ ∀ n, rel n a b.
  Proof.
    rewrite view_valid_eq /=. apply and_iff_compat_l.
    setoid_rewrite (left_id _ _ b). split; [|by eauto].
    intros H n. by destruct (H n) as [?[->%(inj to_agree)]].
  Qed.
  Lemma view_both_valid a b : ✓ (●V a ⋅ ◯V b) ↔ ∀ n, rel n a b.
  Proof. rewrite view_both_dfrac_valid. split; [naive_solver|done]. Qed.

  (** Inclusion *)
  Lemma view_auth_dfrac_includedN n dq1 dq2 a1 a2 b :
    ●V{dq1} a1 ≼{n} ●V{dq2} a2 ⋅ ◯V b ↔ (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2.
  Proof.
    split.
    - intros [[[[dqf agf]|] bf]
        [[?%(discrete_iff _ _) ?]%(inj Some) _]]; simplify_eq/=.
      + split; [left; apply: cmra_included_l|]. apply to_agree_includedN. by exists agf.
      + split; [right; done|]. by apply (inj to_agree).
    - intros [[[? ->]| ->] ->].
      + rewrite view_auth_dfrac_op -assoc. apply cmra_includedN_l.
      + apply cmra_includedN_l.
  Qed.
  Lemma view_auth_dfrac_included dq1 dq2 a1 a2 b :
    ●V{dq1} a1 ≼ ●V{dq2} a2 ⋅ ◯V b ↔ (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2.
  Proof.
    intros. split.
    - split.
      + by eapply (view_auth_dfrac_includedN 0), cmra_included_includedN.
      + apply equiv_dist=> n.
        by eapply view_auth_dfrac_includedN, cmra_included_includedN.
    - intros [[[dq ->]| ->] ->].
      + rewrite view_auth_dfrac_op -assoc. apply cmra_included_l.
      + apply cmra_included_l.
  Qed.
  Lemma view_auth_includedN n a1 a2 b :
    ●V a1 ≼{n} ●V a2 ⋅ ◯V b ↔ a1 ≡{n}≡ a2.
  Proof. rewrite view_auth_dfrac_includedN. naive_solver. Qed.
  Lemma view_auth_included a1 a2 b :
    ●V a1 ≼ ●V a2 ⋅ ◯V b ↔ a1 ≡ a2.
  Proof. rewrite view_auth_dfrac_included. naive_solver. Qed.

  Lemma view_frag_includedN n p a b1 b2 :
    ◯V b1 ≼{n} ●V{p} a ⋅ ◯V b2 ↔ b1 ≼{n} b2.
  Proof.
    split.
    - intros [xf [_ Hb]]; simpl in *.
      revert Hb; rewrite left_id. by exists (view_frag_proj xf).
    - intros [bf ->]. rewrite comm view_frag_op -assoc. apply cmra_includedN_l.
  Qed.
  Lemma view_frag_included p a b1 b2 :
    ◯V b1 ≼ ●V{p} a ⋅ ◯V b2 ↔ b1 ≼ b2.
  Proof.
    split.
    - intros [xf [_ Hb]]; simpl in *.
      revert Hb; rewrite left_id. by exists (view_frag_proj xf).
    - intros [bf ->]. rewrite comm view_frag_op -assoc. apply cmra_included_l.
  Qed.

  (** The weaker [view_both_included] lemmas below are a consequence of the
  [view_auth_included] and [view_frag_included] lemmas above. *)
  Lemma view_both_dfrac_includedN n dq1 dq2 a1 a2 b1 b2 :
    ●V{dq1} a1 ⋅ ◯V b1 ≼{n} ●V{dq2} a2 ⋅ ◯V b2 ↔
      (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
  Proof.
    split.
    - intros. rewrite assoc. split.
      + rewrite -view_auth_dfrac_includedN. by etrans; [apply cmra_includedN_l|].
      + rewrite -view_frag_includedN. by etrans; [apply cmra_includedN_r|].
    - intros (?&->&?bf&->). rewrite (comm _ b1) view_frag_op assoc.
      by apply cmra_monoN_r, view_auth_dfrac_includedN.
  Qed.
  Lemma view_both_dfrac_included dq1 dq2 a1 a2 b1 b2 :
    ●V{dq1} a1 ⋅ ◯V b1 ≼ ●V{dq2} a2 ⋅ ◯V b2 ↔
      (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2 ∧ b1 ≼ b2.
  Proof.
    split.
    - intros. rewrite assoc. split.
      + rewrite -view_auth_dfrac_included. by etrans; [apply cmra_included_l|].
      + rewrite -view_frag_included. by etrans; [apply cmra_included_r|].
    - intros (?&->&?bf&->). rewrite (comm _ b1) view_frag_op assoc.
      by apply cmra_mono_r, view_auth_dfrac_included.
  Qed.
  Lemma view_both_includedN n a1 a2 b1 b2 :
    ●V a1 ⋅ ◯V b1 ≼{n} ●V a2 ⋅ ◯V b2 ↔ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
  Proof. rewrite view_both_dfrac_includedN. naive_solver. Qed.
  Lemma view_both_included a1 a2 b1 b2 :
    ●V a1 ⋅ ◯V b1 ≼ ●V a2 ⋅ ◯V b2 ↔ a1 ≡ a2 ∧ b1 ≼ b2.
  Proof. rewrite view_both_dfrac_included. naive_solver. Qed.

  (** Updates *)
  Lemma view_update a b a' b' :
    (∀ n bf, rel n a (b ⋅ bf) → rel n a' (b' ⋅ bf)) →
    ●V a ⋅ ◯V b ~~> ●V a' ⋅ ◯V b'.
  Proof.
    intros Hup; apply cmra_total_update=> n [[[dq ag]|] bf] [/=].
    { by intros []%(exclusiveN_l _ _). }
    intros _ (a0 & <-%(inj to_agree) & Hrel). split; simpl; [done|].
    exists a'; split; [done|]. revert Hrel. rewrite !left_id. apply Hup.
  Qed.

  Lemma view_update_alloc a a' b' :
    (∀ n bf, rel n a bf → rel n a' (b' ⋅ bf)) →
    ●V a ~~> ●V a' ⋅ ◯V b'.
  Proof.
    intros Hup. rewrite -(right_id _ _ (●V a)).
    apply view_update=> n bf. rewrite left_id. apply Hup.
  Qed.
  Lemma view_update_dealloc a b a' :
    (∀ n bf, rel n a (b ⋅ bf) → rel n a' bf) →
    ●V a ⋅ ◯V b ~~> ●V a'.
  Proof.
    intros Hup. rewrite -(right_id _ _ (●V a')).
    apply view_update=> n bf. rewrite left_id. apply Hup.
  Qed.

  Lemma view_update_auth a a' b' :
    (∀ n bf, rel n a bf → rel n a' bf) →
    ●V a ~~> ●V a'.
  Proof.
    intros Hup. rewrite -(right_id _ _ (●V a)) -(right_id _ _ (●V a')).
    apply view_update=> n bf. rewrite !left_id. apply Hup.
  Qed.
  Lemma view_update_auth_persist dq a : ●V{dq} a ~~> ●V□ a.
  Proof.
    apply cmra_total_update.
    move=> n [[[dq' ag]|] bf] [Hv ?]; last done. split; last done.
    by apply (dfrac_discard_update dq _ (Some dq')).
  Qed.

  Lemma view_update_frag b b' :
    (∀ a n bf, rel n a (b ⋅ bf) → rel n a (b' ⋅ bf)) →
    ◯V b ~~> ◯V b'.
  Proof.
    rewrite !cmra_total_update view_validN_eq=> ? n [[[dq ag]|] bf]; naive_solver.
  Qed.

  Lemma view_update_dfrac_alloc dq a b :
    (∀ n bf, rel n a bf → rel n a (b ⋅ bf)) →
    ●V{dq} a ~~> ●V{dq} a ⋅ ◯V b.
  Proof.
    intros Hup. apply cmra_total_update=> n [[[p ag]|] bf] [/=].
    - intros ? (a0 & Hag & Hrel). split; simpl; [done|].
      exists a0; split; [done|]. revert Hrel.
      assert (to_agree a ≼{n} to_agree a0) as <-%to_agree_includedN.
      { by exists ag. }
      rewrite !left_id. apply Hup.
    - intros ? (a0 & <-%(inj to_agree) & Hrel). split; simpl; [done|].
      exists a; split; [done|]. revert Hrel. rewrite !left_id. apply Hup.
  Qed.

  Lemma view_local_update a b0 b1 a' b0' b1' :
    (b0, b1) ~l~> (b0', b1') →
    (∀ n, view_rel_holds rel n a b0 → view_rel_holds rel n a' b0') →
    (●V a ⋅ ◯V b0, ●V a ⋅ ◯V b1) ~l~> (●V a' ⋅ ◯V b0', ●V a' ⋅ ◯V b1').
  Proof.
    rewrite !local_update_unital.
    move=> Hup Hrel n [[[qd ag]|] bf] /view_both_validN Hrel' [/=].
    - rewrite right_id -Some_op -pair_op => /Some_dist_inj [/= H1q _].
      by destruct (id_free_r (DfracOwn 1) qd).
    - rewrite !left_id=> _ Hb0.
      destruct (Hup n bf) as [? Hb0']; [by eauto using view_rel_validN..|].
      split; [apply view_both_validN; by auto|]. by rewrite -assoc Hb0'.
  Qed.

End cmra.

(** * Utilities to construct functors *)
(** Due to the dependent type [rel] in [view] we cannot actually define
instances of the functor structures [rFunctor] and [urFunctor]. Functors can
only be defined for instances of [view], like [auth]. To make it more convenient
to define functors for instances of [view], we define the map operation
[view_map] and a bunch of lemmas about it. *)
Definition view_map {A A' B B'}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f : A → A') (g : B → B') (x : view rel) : view rel' :=
  View (prod_map id (agree_map f) <$> view_auth_proj x) (g (view_frag_proj x)).
Lemma view_map_id {A B} {rel : nat → A → B → Prop} (x : view rel) :
  view_map id id x = x.
Proof. destruct x as [[[]|] ]; by rewrite // /view_map /= agree_map_id. Qed.
Lemma view_map_compose {A A' A'' B B' B''}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    {rel'' : nat → A'' → B'' → Prop}
    (f1 : A → A') (f2 : A' → A'') (g1 : B → B') (g2 : B' → B'') (x : view rel) :
  view_map (f2 ∘ f1) (g2 ∘ g1) x
  =@{view rel''} view_map f2 g2 (view_map (rel':=rel') f1 g1 x).
Proof. destruct x as [[[]|] ];  by rewrite // /view_map /= agree_map_compose. Qed.
Lemma view_map_ext  {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f1 f2 : A → A') (g1 g2 : B → B')
    `{!NonExpansive f1, !NonExpansive g1} (x : view rel) :
  (∀ a, f1 a ≡ f2 a) → (∀ b, g1 b ≡ g2 b) →
  view_map f1 g1 x ≡@{view rel'} view_map f2 g2 x.
Proof.
  intros. constructor; simpl; [|by auto].
  apply option_fmap_equiv_ext=> a; by rewrite /prod_map /= agree_map_ext.
Qed.
Global Instance view_map_ne {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f : A → A') (g : B → B') `{Hf : !NonExpansive f, Hg : !NonExpansive g} :
  NonExpansive (view_map (rel':=rel') (rel:=rel) f g).
Proof.
  intros n [o1 bf1] [o2 bf2] [??]; split; simpl in *; [|by apply Hg].
  apply option_fmap_ne; [|done]=> pag1 pag2 ?.
  apply prod_map_ne; [done| |done]. by apply agree_map_ne.
Qed.

Definition viewO_map {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f : A -n> A') (g : B -n> B') : viewO rel -n> viewO rel' :=
  OfeMor (view_map f g).
Lemma viewO_map_ne {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop} :
  NonExpansive2 (viewO_map (rel:=rel) (rel':=rel')).
Proof.
  intros n f f' Hf g g' Hg [[[p ag]|] bf]; split=> //=.
  do 2 f_equiv. by apply agreeO_map_ne.
Qed.

Lemma view_map_cmra_morphism {A A' B B'}
    {rel : view_rel A B} {rel' : view_rel A' B'}
    (f : A → A') (g : B → B') `{!NonExpansive f, !CmraMorphism g} :
  (∀ n a b, rel n a b → rel' n (f a) (g b)) →
  CmraMorphism (view_map (rel:=rel) (rel':=rel') f g).
Proof.
  intros Hrel. split.
  - apply _.
  - rewrite !view_validN_eq=> n [[[p ag]|] bf] /=;
      [|naive_solver eauto using cmra_morphism_validN].
    intros [? [a' [Hag ?]]]. split; [done|]. exists (f a'). split; [|by auto].
    by rewrite -agree_map_to_agree -Hag.
  - intros [o bf]. apply Some_proper; rewrite /view_map /=.
    f_equiv; by rewrite cmra_morphism_core.
  - intros [[[dq1 ag1]|] bf1] [[[dq2 ag2]|] bf2];
      try apply View_proper=> //=; by rewrite cmra_morphism_op.
Qed.


From stdpp Require Import gmap.

From Perennial.Helpers Require Import Integers.
From Perennial.algebra Require Import big_sepM.
From Perennial.program_proof Require Import addr.addr_proof.

Lemma default_fmap `{Countable K} `{EqDecision K} {A B:Type} (m : option (gmap K A)) (f : A -> B) :
  (default ∅ (fmap (fun bm => f <$> bm) m)) =
  f <$> (default ∅ m).
Proof.
  destruct m; simpl; eauto.
  rewrite fmap_empty; eauto.
Qed.

Lemma filter_union_ignored {K A} `{EqDecision K} `{Countable K} (m m' : gmap K A) (P : K->Prop)
                         `{! ∀ k, Decision (P k)} :
  ( ∀ k a, m' !! k = Some a -> ¬ P k ) ->
  filter (λ v, P (fst v)) m = filter (λ v, P (fst v)) (m' ∪ m).
Proof.
  intros.
  apply map_eq; intros i.
  destruct (decide (P i)).
  2: { rewrite !map_filter_lookup_key_notin; eauto. }
  rewrite map_filter_lookup_key_in; eauto.
  rewrite map_filter_lookup_key_in; eauto.
  rewrite lookup_union_r; eauto.
  destruct (m' !! i) eqn:He; eauto.
  exfalso. eapply H1; eauto.
Qed.

Lemma filter_union_gmap_addr_by_block_ignored {A} (m m' : gmap addr A) (P : u64->Prop)
                         `{! ∀ k, Decision (P k)} :
  ( ∀ k a, m' !! k = Some a -> ¬ P (fst k) ) ->
  filter (λ v, P (fst v)) (gmap_addr_by_block m) = filter (λ v, P (fst v)) (gmap_addr_by_block (m' ∪ m)).
Proof.
  intros.
  apply map_eq; intros i.
  destruct (decide (P i)).
  2: { rewrite ?map_filter_lookup_key_notin; eauto. }
  rewrite map_filter_lookup_key_in; eauto.
  rewrite map_filter_lookup_key_in; eauto.
  rewrite /gmap_addr_by_block.
  destruct (gmap_curry m !! i) eqn:He.
  2: {
    symmetry.
    erewrite lookup_gmap_curry_None in He.
    erewrite lookup_gmap_curry_None. intros j. specialize (He j).
    specialize (H0 (i, j)). simpl in *.
    rewrite lookup_union_r; eauto.
    destruct (m' !! (i, j)) eqn:Hee; eauto. exfalso. eapply H0; eauto.
  }

  destruct (gmap_curry (m' ∪ m) !! i) eqn:He2.
  2: {
    exfalso.
    erewrite lookup_gmap_curry_None in He2.
    apply gmap_curry_non_empty in He as He'. apply map_choose in He'. destruct He' as [j [x He']].
    specialize (He2 j). rewrite lookup_union_r in He2.
    2: { destruct (m' !! (i, j)) eqn:Hee; eauto. exfalso. eapply H0; eauto. }
    rewrite -lookup_gmap_curry in He2. rewrite He /= in He2. congruence.
  }

  f_equal.
  apply map_eq.
  intros j.

  replace (g !! j) with (m !! (i, j)).
  2: { rewrite -lookup_gmap_curry. rewrite He. done. }

  replace (g0 !! j) with ((m' ∪ m) !! (i, j)).
  2: { rewrite -lookup_gmap_curry. rewrite He2. done. }

  rewrite lookup_union_r; eauto.
  destruct (m' !! (i, j)) eqn:Hee; eauto. exfalso. eapply H0; eauto.
Qed.


Require Import CSPEC.
Require Import MailServerAPI.
Require Import MailServerLockAbsAPI.

Module MailServerLockAbsImpl' <:
  HLayerImplAbsT MailServerOp
    MailServerLockAbsState MailServerLockAbsAPI
    MailServerState MailServerAPI.

  Import MailServerLockAbsState.

  Definition absR (s1 : MailServerLockAbsState.State) (s2 : MailServerState.State) :=
    MailServerLockAbsState.maildir s1 = s2.

  Hint Extern 1 (MailServerAPI.step _ _ _ _ _ _) => econstructor.

  Theorem absR_ok :
    op_abs absR MailServerLockAbsAPI.step MailServerAPI.step.
  Proof.
    unfold op_abs; intros.
    unfold absR in *.
    inversion H0; clear H0; subst; repeat sigT_eq.
    all: eauto.
  Qed.

  Definition initP_map (s1: MailServerLockAbsState.State) : {s2:MailServerState.State | initP s1 -> absR s1 s2 /\ MailServerState.initP s2}.
    exists (maildir s1).
    unfold initP, absR, MailServerState.initP; eauto.
  Defined.

End MailServerLockAbsImpl'.

Module MailServerLockAbsImpl :=
  HLayerImplAbs MailServerOp
    MailServerLockAbsState MailServerLockAbsAPI
    MailServerState MailServerAPI
    MailServerLockAbsImpl'.

Module MailServerLockAbsImplH' :=
  LayerImplAbsHT
    MailServerOp
    MailServerLockAbsState MailServerLockAbsAPI
    MailServerState MailServerAPI
    MailServerLockAbsImpl'
    UserIdx.

Module MailServerLockAbsImplH :=
  LayerImplAbs MailServerHOp
    MailServerLockAbsHState MailServerLockAbsHAPI
    MailServerHState        MailServerHAPI
    MailServerLockAbsImplH'.


Require Import RGref.DSL.Core.
Require Export RGref.DSL.LinearEnv.

(** * A Monad for RGref programs *)

(* TODO: Should probably be a type-class *)
Inductive splits : Set -> Set -> Set -> Prop :=
  | natsp : splits nat nat nat
  | boolsp : splits bool bool bool
  | unitsp : splits unit unit unit
  | pairsp : forall A A' A'' B B' B'',
               splits A A' A'' ->
               splits B B' B'' ->
               splits (A*B) (A'*B') (A''*B'')
  | listsp : forall A A' A'', splits A A' A'' -> splits (list A) (list A') (list A'')
  | funsp : forall (A B:Set),
               splits (forall x:A, B) (forall x:A, B) (forall x:A, B)
.
Inductive rgref (Γ:tyenv) (T:Set) (Γ':tyenv) : Type :=
  | mkRGR :  envlist Γ -> T -> envlist Γ' -> (heap -> heap) -> rgref Γ T Γ'.

(* TODO: Really bind should be doing some kind of framing on environments, a subenv type thing. *)
Program Definition rgref_bind {Γ Γ' Γ'':tyenv}{t t':Set} (a:rgref Γ t Γ') (b:t->rgref Γ' t' Γ'') : rgref Γ t' Γ'' :=
  match a with
  | mkRGR _ va _ ha =>
    match b va with
    | mkRGR _ vb _ hb =>
      mkRGR _ _ _ _ vb _ (fun h => hb (ha h))
    end
  end.

(* TODO: To actually define this properly, bind needs to do framing and ret should use the empty env. *)
Axiom rgret : forall {Γ:tyenv}{A:Set}(a:A), rgref Γ A Γ .
(*  := mkRGR Γ A Γ e a e (fun h=>h).*)

Axiom dropvar : forall {Γ} (v:var) (t:Set) (tm:tymember v t Γ), rgref Γ unit (tyrem tm).

(** * Higher-Order Safety *)
(** The following typeclass network prohibits latent dereference expressions in the heap, alleviating the need for
    extra caution in proof principles, and removing the need for the type-sensitive semantics in the PLDI'13 paper.
    It is the subject of a submission to POPL'14. *)
(* Some background stuff... *)
  Instance n2n : ImmediateReachability (nat -> nat) := { imm_reachable_from_in := fun _ _ _ _ _ _ => False }.
  Print Containment.
  Instance n2nc : Containment (nat -> nat) := {contains := fun _ => False}.

  Instance n2n' : ImmediateReachability (forall x : nat, (fun _ : nat => nat) x) := { imm_reachable_from_in := fun _ _ _ _ _ _ => False }.

Class Library {T:Type}(o:T) : Prop := {}.
Class Safe {T:Type}(t:T) : Prop := {}.
Class SafeType (T:Type) : Prop := {}.
Instance safe_lib {T:Type}{o:T}`{Library T o} : Safe o.
Instance val_of_safe_type {T:Type}`{SafeType T}(t:T) : Safe t.
Instance imp_of_safe_type {T:Set}`{SafeType T}{Γ}(t : rgref Γ T Γ) : Safe t.
Instance puretype_safe {T:Set}`{pure_type T} : SafeType T.

Class ESafe (n:nat){T:Type}(t:T) : Prop := { force_proof : False }.
Instance safe_esafe {T:Type}(t:T){n:nat}`{Safe _ t} : ESafe n t. Admitted.
Instance esafe_ind {A:Type}{B:A->Type}{n:nat}(f:forall x:A, B x)`{forall a:A, Safe a -> ESafe n (f a)} : ESafe (S n) f.
Admitted.
Instance deref_esafe {A B:Set}{P R G}`{rel_fold A}(r:ref{A|P}[R,G]){a b} : ESafe 0 (@deref A B _ P R G a b r).
Admitted.
Instance esafe_app {A:Type}{B:A->Type}(f:forall x:A, B x)(a:A){n:nat}`{ESafe (S n) _ f}`{ESafe 0 _ a} : ESafe n (f a).
Admitted.

Ltac solve_applications :=
  match goal with
  | [ |- @ESafe _ _ (?g _ _ _) ] => eapply @esafe_app with (f := g _ _)
  | [ |- @ESafe _ _ (?g _ _) ] => eapply @esafe_app with (f := g _)
  | [ |- @ESafe _ _ (?g _) ] => eapply @esafe_app with (f := g)
  end; eauto with typeclass_instances.

(** The core problem with folding here is that we want the user (and automated provers!) to see the same dereference on either side of
    G's state.  But G applies to elements of A, not [R,G]>>A.  We could introduce an internal "cheat_deref" that skipped
    folding, but then the two sides aren't equal, and many automated tactics that treat !e as essentially an uninterpreted
    symbol fail because the pre and post values use different uninterpreted symbols.  Another alternative is to
    ALSO add an axiom relating the behaviors of deref and cheat_deref, but this will run into serious issues with
    polymorphism over A and [R,G]>>A.  John Major equality might handle this okay, but I haven't had much success using
    JMeq for anything yet.

    A slightly different approach would be to have a folding version of heap-specific dereference, and do the guarantee
    validity check in a context with the assumption that ∀ e, !e = h[e]>> (where h[x]>> is the folding specific-heap read).
    This still runs into some JMeq issues (e.g. ∀ x h, JMeq h[x] h[x]>>), but they might be easier to deal with.

    A less serious (easier to solve) version of this occurs with reflexivity checks on G for reads.  Still need two symbols,
    one for devs that checks reflexivity on reads, the other for metatheory proofs like satisfying G, with either an axiom
    or per-context assumption that their results are equal (eq equal, since the types are equal, unless we're also solving
    the general folding issue at the same time).

    In practice the folding shouldn't matter too much (for pure types, folding is identity), but we need to support it
    in general.  Eventually both store and write will need to take rel_fold A instances so they can use them in proofs
    and obligation statements.
*)
(** TODO: Fix store to work properly with the linear environment. *)
(*Axiom store : forall {Γ:dyn_env}{A:Set}{P R G}(x:var)(e:A)
                 {varty:exists ptr, lookup x Γ = Some (existT (fun x:Set=>x) (ref{A|P}[R,G]) ptr)}
                 {guar:forall h l, lookup x Γ = Some (existT (fun x:Set=>x) (ref{A|P}[R,G]) l) ->
                   G (!l) e h (heap_write l e h)}
                 {pres:(forall h (l:ref{A|P}[R,G]), P (!l) h -> P e (heap_write l e h))}
                 , rgref Γ unit Γ.*)
Program Axiom write' : forall {Γ:tyenv}{A:Set}`{rel_fold A}{P R G}`{hreflexive G}(x:ref{A|P}[R,G])(e:A)`{ESafe 0 A e}
                      (meta_x_deref:A) (meta_e_fold:A)
                      (** These meta args are notationally expanded x and e using the identity relation folding *)
                 (*{guar:forall h, G (!x) e h (heap_write x e h)} *)
                 {guar:forall h, (forall A (fa:rel_fold A), fa = meta_fold) -> G (meta_x_deref) e h (heap_write x e h)}
                 (** temporarily not using meta_e_fold... the cases where I needed the "nop" behavior are once where the types are actually equal *)
                 {pres:(forall h, P meta_x_deref h -> P meta_e_fold (heap_write x meta_e_fold h))}
                 , rgref Γ unit Γ.
Notation "[ x ]:= e" := (@write' _ _ _ _ _ _ _ x e _ ({{{!x}}}) ({{{e}}}) _ _) (at level 70).
(** TODO: heap writes that update the predicate.  Because of the monadic style, we'll actually
   need a new axiom and syntax support for this, to rebind the variable at the strengthened type *)

(** Interactions between pure terms and monadic terms *)
(** valueOf should be treated as roughly a more serious version of unsafePerformIO;
    it's a coreturn like the latter, but should actually never be written in user programs! *)
Program Axiom valueOf : forall {Γ Γ'}{A:Set}, envlist Γ -> heap -> rgref Γ A Γ' -> A.
(** pureApp is essentially based on valueOf... Technically this is weaker than what's in the paper,
    since dependently-typed pure functions are allowed if the instantiation of the range type is
    closed, but right now I don't need the expressiveness and can't figure out how to properly treat the
    dependency in binding B.

    I supposed technically this makes rgref an indexed functor (in the Haskell sense), and with a
    small tweak, an applicative functor if we need it. *)
Program Axiom pureApp : forall {Γ Γ'}{A:Set}`{splits A A A}{B:Set}, (A->B) -> rgref Γ A Γ' -> rgref Γ B Γ'.

(** This is just strong enough to get the race-free counter example to go through... Need to strengthen this at some point. *)
Axiom weak_pureApp_morphism :
  forall Γ Γ' τ env h (e:rgref Γ τ Γ') (sp:splits τ τ τ) (f:τ->τ) (P:τ->τ->Prop),
    (forall v:τ, P v (f v)) ->
    P (valueOf Γ Γ' τ env h e) (valueOf Γ Γ' τ env h (pureApp Γ Γ' τ sp τ f e)).

(* Impure read expression (using a direct ref value) *)
Program Axiom read_imp : forall {Γ}{A B:Set}`{rel_fold A}{P R G}`{hreflexive G}`{rgfold R G = B}(x:ref{A|P}[R,G]), rgref Γ B Γ.

(* Writing with an impure source expression (and direct ref value) *)
Program Axiom write_imp_exp : forall {Γ Γ'}{A:Set}`{rel_fold A}{P R G}`{hreflexive G}(x:ref{A|P}[R,G])(e:rgref Γ A Γ')
                              `{ESafe 0 _ e}
                              (meta_x_deref:rgref Γ A Γ') (meta_e_fold:rgref Γ A Γ')
                              {guar:forall h env, G (valueOf _ _ _ env h meta_x_deref) (valueOf _ _ _ env h e) h (heap_write x (valueOf _ _ _ env h e) h)}
                              {pres:(forall h env, P (valueOf _ _ _ env h meta_x_deref) h -> P (valueOf _ _ _ env h meta_e_fold) (heap_write x (valueOf _ _ _ env h meta_e_fold) h))}
                              , rgref Γ unit Γ'.
Notation "[[ x ]]:= e" := (@write_imp_exp _ _ _ _ _ _ _ _ x e ({{{read_imp x}}}) ({{{e}}}) _ _) (at level 70).

Definition locally_const {A:Set} (R:hrel A) := forall a a' h h', R a a' h h' -> a=a'.

Axiom alloc : forall {Γ}{T:Set}{RT:ImmediateReachability T}{CT:Containment T}{FT:rel_fold T} P R G (e:T),
                ESafe 0 e ->
                stable P R ->        (* predicate is stable *)
                (forall h, P e h) -> (* predicate is true *)
                precise_pred P ->    (* P precise *)
                precise_rel R ->     (* R precise *)
                precise_rel G ->     (* G precise *)
                rgref Γ (ref{T|P}[R,G]) Γ.
Notation "'Alloc' e" := (alloc _ _ _ e _ _ _ _ _ _) (at level 70).
(** Sometimes it is useful to refine P to give equality with the allocated value, which
    propagates assumptions and equalities across "statements." *)
Axiom alloc' : forall {Γ}{T:Set}{RT:ImmediateReachability T}{CT:Containment T}{FT:rel_fold T} P R G (e:T) (meta_e:T),
                ESafe 0 e ->
                stable P R ->        (* predicate is stable *)
                (forall h, P e h) -> (* predicate is true *)
                precise_pred P ->    (* P precise *)
                precise_rel R ->     (* R precise *)
                precise_rel G ->     (* G precise *)
                 rgref Γ (ref{T|P ⊓ (fun t=>fun h=> (locally_const R -> t=meta_e))}[R,G]) Γ.
Notation "Alloc! e" := (alloc' _ _ _ e ({{{e}}}) _ _ _ _ _ _) (at level 70).

Notation "x <- M ; N" := (rgref_bind M (fun x => N)) (at level 49, right associativity).

Axiom varalloc' : forall {Γ}{T:Set}{RT:ImmediateReachability T}{CT:Containment T}{FT:rel_fold T} P R G (v:var) (e:T) (meta_e:T),
                ESafe 0 e ->
                stable P R ->        (* predicate is stable *)
                (forall h, P e h) -> (* predicate is true *)
                precise_pred P ->    (* P precise *)
                precise_rel R ->     (* R precise *)
                precise_rel G ->     (* G precise *)
                 rgref Γ unit (v:ref{T|P ⊓ (fun t=>fun h=> (locally_const R -> t=meta_e))}[R,G],Γ).
Notation "VarAlloc! v e" := (varalloc' _ _ _ v e ({{{e}}}) _ _ _ _ _ _) (at level 70).

(** ** Fixpoints *)
(** Possibly non-terminating fixpoint combinators. *)
(* TODO: This is only a first cut, and doesn't allow polymorphic recursion. *)
Axiom RGFix : forall { Γ Γ' }(t t':Set), ((t -> rgref Γ t' Γ') -> (t -> rgref Γ t' Γ')) -> t -> rgref Γ t' Γ'.
Axiom RGFix2 : forall { Γ Γ' }(t t2 t':Set), ((t -> t2 -> rgref Γ t' Γ') -> (t -> t2 -> rgref Γ t' Γ')) -> t -> rgref Γ t' Γ'.
Axiom RGFix3 : forall { Γ Γ' }(t t2 t3 t':Set), ((t -> t2 -> t3 -> rgref Γ t' Γ') -> (t -> t2 -> t3 -> rgref Γ t' Γ')) -> t -> rgref Γ t' Γ'.
Axiom RGFix4 : forall { Γ Γ' }(t t2 t3 t4 t':Set), ((t -> t2 -> t3 -> t4 -> rgref Γ t' Γ') -> (t -> t2 -> t3 -> t4 -> rgref Γ t' Γ')) -> t -> rgref Γ t' Γ'.


(*********************************************************************)
(*             Stability in Weak Memory Models                       *)
(*                                                                   *)
(*   Jade Alglave INRIA Paris-Rocquencourt, France                   *)
(*                University of Oxford, UK                           *)
(*                                                                   *)
(*  Copyright 2010 Institut National de Recherche en Informatique et *)
(*  en Automatique. All rights reserved. This file is distributed    *)
(*  under the terms of the Lesser GNU General Public License.        *)
(*********************************************************************)

Require Import Ensembles.
Require Import Bool.
From CoqCat Require Import util.
From CoqCat Require Import wmm.
From CoqCat Require Import basic.
From CoqCat Require Import hierarchy.
From CoqCat Require Import valid.
From CoqCat Require Import covering.
Require Import Classical_Prop.
From CoqCat Require Import drf.
From CoqCat Require Import racy.
Import OEEvt.
Set Implicit Arguments.

Module CritSC (A1 A2: Archi) (dp:Dp).

Module Wk := (*Hierarchy.*)Weaker A1 A2 dp.
Import Wk.
Hypothesis wk : weaker.

Module VA2 := Valid A2n dp.
Import VA2. Import VA2.ScAx.
Module Covering := Covering A1 A2n dp.
Import Covering.

Set Implicit Arguments.

Definition rel_inter A (r1 r2 : Rln A) :=
  fun x => fun y => r1 x y /\ r2 x y.

Definition cycle_sym A (sigma : Rln A) :=
  forall x y, udr sigma x -> udr sigma y ->
  sigma x y -> sigma y x.
Definition cycle_trans_tot A (sigma : Rln A) :=
  forall x y, udr sigma x -> udr sigma y ->
    tc (sigma) x y.
Definition non_empty A (sigma : Rln A) :=
  (exists x, exists y, sigma x y).
Definition cycle A (sigma : Rln A) :=
  cycle_sym sigma /\
  cycle_trans_tot sigma /\ non_empty sigma.
Ltac destruct_cycle H :=
  destruct H as [Hsym [Htot Hnemp]].
Lemma cycle_implies_nac :
  forall A (sigma:Rln A),
  cycle sigma -> ~(acyclic sigma).
Proof.
unfold acyclic;
intros A sigma Hcy Hn.
destruct_cycle Hcy.
destruct Hnemp as [x [y Hxy]].
unfold cycle_sym in Hsym.
assert (udr sigma x) as Hudrx.
  left; exists y; auto.
assert (udr sigma y) as Hudry.
  right; exists x; auto.
generalize (Hsym x y Hudrx Hudry Hxy); intro Hyx.
assert (tc (sigma) x x) as Hc.
  apply trc_ind with y; apply trc_step; auto.
generalize (Hn x); intro; contradiction.
Qed.

Definition conflict E :=
  fun e1 => fun e2 => events E e1 /\ events E e2 /\
    loc e1 = loc e2 /\ proc_of e1 <> proc_of e2 /\ (writes E e1 \/ writes E e2).

Definition sigma_wf E sigma :=
  rel_incl sigma (tc (rel_union (A2n.ppo E) (rel_inter sigma (conflict E)))).

Definition crit_cy E sigma :=
  sigma_wf E sigma /\ ~ acyclic sigma /\
  acyclic (rel_union (rel_inter sigma (conflict E)) (rel_union (A1.ppo E) (pio_llh E))) /\
  (forall x y, sigma x y -> A2n.ppo E x y ->
  ~(exists z, (z <> y /\ sigma x z /\ A2n.ppo E x z /\ A2n.ppo E z y)) /\ loc x <> loc y) /\
  (forall x y, sigma x y -> conflict E x y ->
    (((reads E x /\ writes E y) \/
      (writes E x /\ reads E y) \/
      (writes E x /\ writes E y)) /\
      ~(exists z, conflict E z x /\ tc sigma x z /\ tc sigma z y)) \/
      (reads E x /\ reads E y /\ exists e, writes E e /\ tc sigma x e /\ tc sigma e y /\
       ~(exists z, conflict E z x /\ tc sigma x z /\ tc sigma z y))).

Definition mhbd E X :=
  fun x => fun y => (A2nWmm.mhb E X x y) /\ proc_of x <> proc_of y.

Ltac destruct_valid H :=
  destruct H as [[Hws_tot Hws_cands] [[Hrf_init [Hrf_cands Hrf_uni]] [Hsp [Hth Hvalid]]]];
  unfold write_serialization_well_formed in Hws_tot.

Definition sigma_wf_or E X sigma :=
  rel_incl sigma (tc (rel_union (mhbd E X) (A2.ppo E))).

Definition crit_cy_or E X sigma :=
  sigma_wf_or E X sigma /\
  crit_cy E sigma.
Axiom exists_crit_cy_or : forall E X x,
  tc (A2nWmm.ghb E X) x x ->
  exists sigma, crit_cy_or E X sigma.

Module C <: Compete.
Parameter competing : Event_struct -> Execution_witness -> Rln Event.
Hypothesis compete_in_events :
  forall E X x y,
  well_formed_event_structure E ->
  rfmaps_well_formed E (events E) (rf X) ->
  competing E X x y ->
  events E x /\ events E y.
Parameter s : Event_struct -> Execution_witness -> Rln Event.
Definition covered E X r :=
  forall e1 e2, (competing E X e1 e2) -> (r E X e1 e2 \/ r E X e2 e1).
Definition covering s :=
  forall E X, well_formed_event_structure E ->
    A1Wmm.valid_execution E X ->
    covered E X s -> acyclic (A2nWmm.ghb E X).

Definition cns E X :=
  fun e1 => fun e2 => competing E X e1 e2 /\ ~ (s E X e1 e2 \/ s E X e2 e1).
Hypothesis competing_irr : forall E X,
  well_formed_event_structure E ->
    A1Wmm.valid_execution E X ->
  ~ (exists z, competing E X z z).
Hypothesis competing_not_po :
  forall E X x y, well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  competing E X x y -> ~ (po_iico E y x).
Hypothesis covering_s : covering s.
Hypothesis wf :
  forall E X x y,
  well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  competing E X x y ->
  ~ (s E X x y \/ s E X y x) ->
  (exists Y, A2nWmm.valid_execution E Y /\
  competing E Y x y /\ ~ (s E Y x y \/ s E Y y x)).
End C.

Module Cm <: Compete.
Definition competing E X :=
  fun e1 e2 => C.competing E X e1 e2 /\
    (exists sigma, crit_cy E sigma /\ sigma e1 e2).
Lemma compete_in_events :
  forall E X x y,
  well_formed_event_structure E ->
  rfmaps_well_formed E (events E) (rf X) ->
  competing E X x y ->
  events E x /\ events E y.
Proof.
intros E X x y Hwf Hrfwf [Hc ?].
apply C.compete_in_events with X; auto.
Qed.

Definition s E X :=
  fun e1 e2 => C.s E X e1 e2.
Definition covered E X r :=
  forall e1 e2, (competing E X e1 e2) -> (r E X e1 e2 \/ r E X e2 e1).
Definition covering s :=
  forall E X, well_formed_event_structure E ->
    A1Wmm.valid_execution E X ->
    covered E X s -> acyclic (A2nWmm.ghb E X).

Definition cns E X :=
  fun e1 => fun e2 => competing E X e1 e2 /\ ~ (s E X e1 e2 \/ s E X e2 e1).
Lemma competing_irr : forall E X,
  well_formed_event_structure E ->
    A1Wmm.valid_execution E X ->
  ~ (exists z, competing E X z z).
Proof.
intros E X Hwf Hv1 [z [Hz ?]].
assert (exists z, C.competing E X z z) as Hc.
  exists z; auto.
apply (C.competing_irr Hwf Hv1 Hc).
Qed.
Lemma competing_not_po :
  forall E X x y, well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  competing E X x y -> ~ (po_iico E y x).
Proof.
intros E X x y Hwf Hv1 [Hc ?].
apply (C.competing_not_po Hwf Hv1 Hc).
Qed.

Lemma mhbd_in_conflict :
  forall E X,
  well_formed_event_structure E ->
  write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X) ->
  rel_incl (mhbd E X) (conflict E).
Proof.
intros E X Hwf Hs x y [? ?].
generalize (A2nBasic.mhb_in_com E X x y H); intro Hhb.
split; [|split; [|split; [|split]]]; auto.
  change (events E x) with (In _ (events E) x); apply A2nBasic.hb_dom_in_evts with X y; auto.
  change (events E y) with (In _ (events E) y); apply A2nBasic.hb_ran_in_evts with X x; auto.
  apply A2nBasic.com_implies_same_loc with E X; auto.
  apply A2nBasic.com_implies_writes with X; auto.
Qed.

Set Implicit Arguments.
Lemma nac_incl :
  forall A (d s s' : Rln A),
  rel_incl s' s ->
  ~ acyclic (rel_union d s') ->
  ~ acyclic (rel_union d s).
Proof.
unfold not; unfold acyclic;
intros A d s1 s1' Hi Hnac Hc.
apply Hnac; intros x Hx.
assert (tc (rel_union d s1) x x) as Hin.
  generalize Hx; apply tc_incl; intros e1 e2 H12.
  inversion H12; [left | right; apply Hi]; auto.
  generalize (Hc x); intro; contradiction.
Qed.
Lemma nac_incl2 :
  forall A (s s' : Rln A),
  rel_incl s' s ->
  ~ acyclic s' ->
  ~ acyclic s.
Proof.
unfold not; unfold acyclic;
intros A s1 s1' Hi Hnac Hc.
apply Hnac; intros x Hx.
assert (tc s1 x x) as Hin.
  generalize Hx; apply tc_incl; intros e1 e2 H12.
  apply Hi; auto.
  generalize (Hc x); intro; contradiction.
Qed.
Lemma not_forall_exists_tc :
  forall A (s : Rln A), ~(forall x, ~ tc s x x) ->
  exists x, tc s x x.
Proof.
intros A s1 Hn.
generalize (excluded_middle (exists x, tc s1 x x)); intro Hor;
  inversion Hor; auto.
assert (forall x, ~ tc s1 x x) as Hc.
  intro x.
  generalize (excluded_middle (tc s1 x x)); intro Hor2;
  inversion Hor2; auto.
  assert (exists x, tc s1 x x) as Hc.
    exists x; auto.
  contradiction.
contradiction.
Qed.
Unset Implicit Arguments.

Hypothesis covering_s :
  forall E X, well_formed_event_structure E ->
    A1Wmm.valid_execution E X ->
    covered E X s -> acyclic (A2nWmm.ghb E X).

Lemma wf :
  forall E X x y,
  well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  competing E X x y ->
  ~ (s E X x y \/ s E X y x) ->
  (exists Y, A2nWmm.valid_execution E Y /\
  competing E Y x y /\ ~ (s E Y x y \/ s E Y y x)).
Proof.
intros E X x y Hwf Hv1 [Hc [cy [Hmcy Hcy]]] Hns.
unfold s in Hns.
generalize (C.wf Hwf Hv1 Hc Hns);
  intros [Y [Hv2 [HcY HnsY]]].
exists Y; split; [|split]; auto.
split; auto.
exists cy; split; auto.
Qed.

Module DrfG := DataRaceFree A1 A2 dp.

Module DrfMin (HB : DrfG.HappensBefore).

Module Drf := DrfG.Drf0 (HB).

Hypothesis s_com :
  forall E X x y,
  s E X x y -> ~(com E X y x).
Hypothesis s_po :
  forall E X,
  acyclic (rel_union (s E X) (po_iico E)).

Lemma tc_mhbd_ppo2_in_s_ppo2 :
  forall E X x y,
  well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  Drf.covered E X s ->
  tc (rel_union (mhbd E X) (A2.ppo E)) x y ->
  tc (rel_union (s E X) (A2.ppo E)) x y.
Proof.
intros E X e1 e2 Hwf Hv1 Hcov; apply tc_incl.
intros x y Hxy.
      assert ( write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X)) as Hs.
        split; split; destruct_valid Hv1; auto.

inversion Hxy as [Hc | Hppo2]; [left | right]; auto.

assert (Drf.competing E X x y) as Hcomp.

  destruct Hc as [Hmhbdxy ?]; split; [|split; [|split; [|split]]]; auto.

      assert (mhbd E X x y) as Hmhbd.
        split; auto.
      generalize (mhbd_in_conflict Hwf Hs Hmhbd); intro Hcxy.
      destruct Hcxy; auto.

      assert (mhbd E X x y) as Hmhbd.
        split; auto.
      generalize (mhbd_in_conflict Hwf Hs Hmhbd); intro Hcxy.
      destruct Hcxy as [? [? ?]]; auto.

      assert (mhbd E X x y) as Hmhbd.
        split; auto.
      generalize (mhbd_in_conflict Hwf Hs Hmhbd); intro Hcxy.
      destruct Hcxy as [? [? [? ?]]]; auto.

      assert (mhbd E X x y) as Hmhbd.
        split; auto.
      generalize (mhbd_in_conflict Hwf Hs Hmhbd); intro Hcxy.
      destruct Hcxy as [? [? [? [? ?]]]]; auto.

    destruct Hs as [? [? [? ?]]]; auto.

generalize (Hcov x y Hcomp); intro Hor; inversion Hor; auto.

inversion Hxy as [Hmhbd | Hppo].
  destruct Hmhbd as [Hmhbdxy ?].
  assert (com E X x y) as Hhb.
    apply A2nBasic.mhb_in_com; auto.
  generalize (s_com E X y x H3); intro; contradiction.

  assert (exists x, tc (rel_union (s E X) (po_iico E)) x x) as Hcy.
    exists x; apply trc_ind with y; apply trc_step;
      [right | left]; auto.
    apply A2.ppo_valid; auto.
  destruct Hcy as [e Hcy].
  generalize (s_po E X); intro Hac.
  generalize (Hac e Hcy); intro Ht; inversion Ht.
Qed.

Lemma tc_cy_in_tc :
  forall E X cy,
  rel_incl cy (tc (rel_union (s E X) (A2.ppo E))) ->
  rel_incl (tc cy) (tc (rel_union (s E X) (A2.ppo E))).
Proof.
intros E X cy Hi x y Hxy.
induction Hxy.
  apply Hi; auto.
  apply trc_ind with z; auto.
Qed.

Lemma min_covered_implies_no_min_cy :
  forall E X, well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  Drf.covered E X s ->
  ~(exists cy, crit_cy_or E X cy).
Proof.
intros E X Hwf Hv1 Hc [cy [Hicy [? [Hnac ?]]]].
assert (rel_incl cy (tc (rel_union (s E X) (A2.ppo E)))) as Hi.
  intros x y Hxy; generalize (Hicy x y Hxy); intro Htc.
    apply tc_mhbd_ppo2_in_s_ppo2; auto.
assert (~(acyclic (rel_union (s E X) (po_iico E)))) as Hco.
  apply nac_incl2 with (rel_union (s E X) (A2.ppo E)).
    intros e1 e2 H12; inversion H12; [left | right]; auto.
    apply A2.ppo_valid; auto.
  unfold acyclic; intros Hex.
  generalize (not_forall_exists_tc Hnac); intros [e He].
  assert (rel_incl (tc cy) (tc (rel_union (s E X) (A2.ppo E)))) as Hitc.
    apply tc_cy_in_tc; auto.
  generalize (Hitc e e He); intro Hxx.
  generalize (Hex e); intro; contradiction.
generalize (s_po E X); intro; contradiction.
Qed.

Lemma covering_s :
  forall E X, well_formed_event_structure E ->
    A1Wmm.valid_execution E X ->
    Drf.covered E X s -> acyclic (A2nWmm.ghb E X).
Proof.
intros E X Hwf Hv1 Hc z Hz.
generalize (exists_crit_cy_or E X Hz);
intros [cy Hcy].
assert (exists cy, crit_cy_or E X cy) as Hex.
  exists cy; auto.
generalize (min_covered_implies_no_min_cy E X Hwf Hv1 Hc); intro Hnex.
contradiction.
Qed.

End DrfMin.

Module Racy := Racy A1 A2 dp.
Module RacyMin (SN:Racy.SafetyNet).

Module R := Racy.Barriers (SN).

Definition AC X s :=
  forall (x z y:Event), rf_sub X x z /\ s z y -> s x y.
Hypothesis s_ghb :
  forall E X,
  well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  acyclic (rel_union (s E X) (A1bWmm.ghb E X)).
Hypothesis s_ppo2 :
  forall E X,
  well_formed_event_structure E ->
  acyclic (rel_union (s E X) (A2n.ppo E)).
Hypothesis s_ac : forall E X, AC X (s E X).

Lemma tc_cy_in_tc :
  forall E X cy,
  rel_incl cy (tc (rel_union (mhbd E X) (A2.ppo E))) ->
  rel_incl (tc cy) (tc (rel_union (mhbd E X) (A2.ppo E))).
Proof.
intros E X cy Hi x y Hxy.
induction Hxy; auto.
apply trc_ind with z; auto.
Qed.

Lemma tc_mhbd_ppo2_in_mhb_ppo2 :
  forall E X x y,
  tc (rel_union (mhbd E X) (A2.ppo E)) x y ->
  tc (rel_union (A2nBasic.AWmm.mhb E X) (A2n.ppo E)) x y.
Proof.
intros E X x y Hxy; induction Hxy as [x y Hu |].
  apply trc_step; inversion Hu as [Hmhbd | Hppo]; [left | right]; auto.
    destruct Hmhbd; auto.
  apply trc_ind with z; auto.
Qed.

Lemma ppo2_in_ghb1 :
  forall E X x y,
  well_formed_event_structure E ->
  R.covered E X s ->
  A2n.ppo E x y ->
  rel_union (A1bWmm.ghb E X) (s E X) x y.
Proof.
intros E X x y Hwf Hfb Hxy.
  generalize (excluded_middle (A1b.ppo E x y)); intro Hor.
  inversion Hor as [Hppo1 | Hnppo1].
   left; apply A1bBasic.ppo_in_ghb; auto.
   assert (ppo_sub E x y) as Hppos.
     split; auto.

   assert (R.competing E X x y) as Hc.
    left; auto.
   right; generalize (Hfb x y Hc); intro Hors; auto.
   inversion Hors as [|Hsyx]; auto.
     assert (tc (rel_union (s E X) (A2n.ppo E)) y y) as Hcy.
       apply trc_ind with x; apply trc_step; [left | right]; auto.
     generalize (s_ppo2 E X Hwf); unfold acyclic; intro Hac;
     generalize (Hac y Hcy); intro Ht; inversion Ht.
Qed.

Lemma rf_sub_seq_ppo2_in_ab1 :
  forall E X x z y,
  well_formed_event_structure E ->
  R.covered E X s ->
  rf_sub X x z ->
  A2n.ppo E z y ->
  s E X x y.
Proof.
intros E X x z y Hwf Hfb Hxz Hzy.
   assert (R.competing E X z y) as Hc.
     right; split; auto.
     exists x; auto.
generalize (Hfb z y Hc); intro Hor.
inversion Hor.
assert (rf_sub X x z /\ s E X z y) as Hand.
  split; auto.

apply (s_ac E X x z y Hand).
     assert (tc (rel_union (s E X) (A2n.ppo E)) y y) as Hcy.
       apply trc_ind with z; apply trc_step; [left | right]; auto.
     generalize (s_ppo2 E X Hwf); unfold acyclic; intro Hac;
     generalize (Hac y Hcy); intro Ht; inversion Ht.
Qed.

Lemma seq_implies_ghb1_int :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
  R.covered E X s ->
  tc (rel_seq (rel_union (rel_union (A1bWmm.mhb' E X) (rf_sub X))
   (rel_union (rel_seq (ws X) (rf_sub X)) (rel_seq (fr E X) (rf_sub X)))) (tc (A2n.ppo E))) x y ->
  tc (rel_union (A1bWmm.ghb E X) (s E X)) x y.
Proof.
intros E X x y Hwk Hwf Hfb Hxy.

induction Hxy.
  destruct H as [z [Hxz Hzy]].
    inversion Hxz as [Hu | Hs].
    inversion Hu as [Hmhb'1 | Hrf_sub].
      apply trc_ind with z.
        rewrite (ghb1b_eq E X).
        apply tc_incl with (rel_union (rel_union (ws X) (fr E X))
        (rel_union (rel_union (mrf1 X) (A1.ppo E)) (A1b.abc E X))).
        intros e1 e2 H12; left; auto.
        apply (mhb'1_eq Hmhb'1).

        apply tc_incl with (A2n.ppo E); auto.
        intros e1 e2 H12; apply ppo2_in_ghb1; auto.

        generalize (tc_dec Hzy); intros [z' [Hzz' Hor]].
        inversion Hor as [Htc | Heq].
          apply trc_ind with z'.

        inversion Hu as [Hmhb | Hrfs].
          apply trc_ind with z.
        rewrite (ghb1b_eq E X).
        apply tc_incl with (rel_union (rel_union (ws X) (fr E X))
        (rel_union (rel_union (mrf1 X) (A1.ppo E)) (A1b.abc E X))).
        intros e1 e2 H12; left; auto.
        apply (mhb'1_eq Hmhb).
        apply tc_incl with (A2n.ppo E); auto.
        intros e1 e2 H12; apply ppo2_in_ghb1; auto.
          apply trc_step; auto.
       apply trc_step; right;
       apply (rf_sub_seq_ppo2_in_ab1 E X x z z' Hwf Hfb Hrf_sub Hzz').
        apply tc_incl with (A2n.ppo E); auto.
        intros e1 e2 H12; apply ppo2_in_ghb1; auto.
       rewrite <- Heq; apply trc_step; right;
       apply (rf_sub_seq_ppo2_in_ab1 E X x z z' Hwf Hfb Hrf_sub Hzz').

  inversion Hs as [Hsws | Hsfr].
    destruct Hsws as [e [Hxe Hez]].
        generalize (tc_dec Hzy); intros [z' [Hzz' Hor]].
        inversion Hor as [Htc | Heq].
          apply trc_ind with z'.
    apply trc_ind with e; apply trc_step.
        rewrite (ghb1b_eq E X).
      left; left; left; auto.

      right. apply rf_sub_seq_ppo2_in_ab1 with z; auto.
      apply tc_incl with (A2n.ppo E); auto.
      intros e1 e2 H12; apply ppo2_in_ghb1; auto.

    apply trc_ind with e; apply trc_step.
        rewrite (ghb1b_eq E X).
      left; left; left; auto.

      right. apply rf_sub_seq_ppo2_in_ab1 with z; auto.
      rewrite <- Heq; auto.

    destruct Hsfr as [e [Hxe Hez]].

        generalize (tc_dec Hzy); intros [z' [Hzz' Hor]].
        inversion Hor as [Htc | Heq].
          apply trc_ind with z'.
    apply trc_ind with e.
    apply trc_step.
        rewrite (ghb1b_eq E X).
      left; left; right; auto.

      apply trc_step; right; apply rf_sub_seq_ppo2_in_ab1 with z; auto.
      apply tc_incl with (A2n.ppo E); auto.
          intros e1 e2 H12; apply ppo2_in_ghb1; auto.

    rewrite <- Heq; apply trc_ind with e.
    apply trc_step.
        rewrite (ghb1b_eq E X).
      left; left; right; auto.

      apply trc_step; right; apply rf_sub_seq_ppo2_in_ab1 with z; auto.

apply trc_ind with z; auto.
Qed.

Lemma seq_implies_ghb1 :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
  R.covered E X s ->
  tc (rel_seq (maybe (rel_union (rel_union (A1bWmm.mhb' E X) (rf_sub X))
   (rel_union (rel_seq (ws X) (rf_sub X)) (rel_seq (fr E X) (rf_sub X))))) (tc (A2n.ppo E))) x y ->
  tc (rel_union (A1bWmm.ghb E X) (s E X)) x y.
Proof.
intros E X x y Hwk Hwf Hfb Hxy.

induction Hxy.
  destruct H as [z [Hor Hzy]].
    inversion Hor as [Hxz | Heq].
      apply seq_implies_ghb1_int; auto.
        apply trc_step; exists z; auto.
   subst; generalize Hzy; apply tc_incl.
  intros e1 e2 H12; apply ppo2_in_ghb1; auto.

  apply trc_ind with z; auto.
Qed.

Lemma min_covered_implies_no_min_cy :
  forall E X, well_formed_event_structure E ->
  A1Wmm.valid_execution E X ->
  R.covered E X s ->
  ~(exists cy, crit_cy_or E X cy).
Proof.
intros E X Hwf Hv1 Hc [cy [Hicy [? [Hnac ?]]]].
assert (  write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X)) as Hs.
  destruct_valid Hv1; split; split; auto.
generalize (not_forall_exists_tc Hnac); intros [x Hx].
generalize (tc_cy_in_tc E X cy Hicy x x Hx); intros Hx'.
generalize (tc_mhbd_ppo2_in_mhb_ppo2 E X x x Hx'); intro Htc.
change (A2.ppo E) with (A2n.ppo E) in Htc.
change (A2nWmm.mhb E X) with (A2nBasic.AWmm.mhb E X) in Htc.
assert (exists y, tc (rel_seq (maybe (A2nWmm.mhb' E X)) (tc (A2.ppo E))) y y) as Hcyc.
eapply (A2nBasic.mhb_union_ppo_cycle_implies_mhb'_seq_ppo_cycle2
  X Hwf Hs Htc); auto; apply Htc.
destruct Hcyc as [y Hcyc].
generalize (mhb'_ppo2_is_u_seq wk Hwf Hcyc); intro Hcy'.
assert (rfmaps_well_formed E (events E) (rf X)) as Hrfwf.
  destruct Hs; auto.
generalize (seq_implies_ghb1 E X y y wk Hwf Hc Hcy');
rewrite union_triv; intro Hcycle.
generalize (s_ghb E X Hwf Hv1 y); intro. contradiction.
Qed.

Lemma covering_s :
  forall E X, well_formed_event_structure E ->
    A1Wmm.valid_execution E X ->
    R.covered E X s -> acyclic (A2nWmm.ghb E X).
Proof.
intros E X Hwf Hv1 Hc z Hz.
generalize (exists_crit_cy_or E X Hz);
intros [cy Hcy].
assert (exists cy, crit_cy_or E X cy) as Hex.
  exists cy; auto.
generalize (min_covered_implies_no_min_cy E X Hwf Hv1 Hc); intro Hnex.
contradiction.
Qed.

End RacyMin.

End Cm.

End CritSC.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ support :  cast\_between\_subsets.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export Map_embed.
Require Export algebra_omissions.

(** - Various casting functions between equal but non-convertible types *)

(** - This one maps elements of a subset to the same subset under a different name
 %\label{mapbetweenequalsubsets}% *)
Definition map_between_equal_subsets :
  forall (A : Setoid) (X Y : part_set A), X =' Y in _ -> X -> Y.
intros A X Y H x.
inversion_clear x.
apply (Build_subtype (E:=A) (P:=Y) (subtype_elt:=subtype_elt)).
simpl in H.
red in H.
generalize (H subtype_elt).
intro H'.
inversion_clear H'.
apply H0; auto with algebra.
Defined.

Lemma subtype_elt_eats_map_between_equal_subsets :
 forall (A : Setoid) (X Y : part_set A) (H : X =' Y in _) (x : X),
 subtype_elt (map_between_equal_subsets H x) =' subtype_elt x in _.
intros.
elim x.
simpl in |- *.
auto with algebra.
Qed.

Hint Resolve subtype_elt_eats_map_between_equal_subsets: algebra.

Lemma map_between_equal_subsets_inj :
 forall (A : Setoid) (X Y : part_set A) (H H' : X =' Y in _) (x x' : X),
 map_between_equal_subsets H x =' map_between_equal_subsets H' x' in _ ->
 x =' x' in _.
simpl in |- *.
unfold subtype_image_equal in |- *; simpl in |- *.
intros.
apply Trans with (subtype_elt (map_between_equal_subsets H x));
 auto with algebra.
apply Trans with (subtype_elt (map_between_equal_subsets H' x'));
 auto with algebra.
Qed.

(** - This one turns $f:A\to X$ into $A\to Y$ whenever $X='Y$ *)

(** %\label{Maptoequalsubsets}% *)
Definition Map_to_equal_subsets :
  forall (A B : Setoid) (X Y : part_set A), X =' Y in _ -> MAP B X -> MAP B Y.
intros.
apply (Build_Map (Ap:=fun b : B => map_between_equal_subsets H (X0 b))).
red in |- *; simpl in |- *; red in |- *.
intros.
unfold map_between_equal_subsets in |- *.
generalize (Map_compatible_prf X0 H0).
case (X0 x); case (X0 y).
simpl in |- *.
auto.
Defined.

Lemma subtype_elt_eats_Map_to_equal_subsets :
 forall (A B : Setoid) (X Y : part_set A) (H : X =' Y in _)
   (b : B) (M : Map B X),
 subtype_elt (Map_to_equal_subsets H M b) =' subtype_elt (M b) in _.
intros.
simpl in |- *.
case (M b).
simpl in |- *.
auto with algebra.
Qed.

Hint Resolve subtype_elt_eats_Map_to_equal_subsets: algebra.

Lemma Map_embed_eats_Map_to_equal_subsets :
 forall (A B : Setoid) (X Y : part_set A) (H : X =' Y in _) (M : Map B X),
 Map_embed (Map_to_equal_subsets H M) =' Map_embed M in _.
intros.
simpl in |- *.
red in |- *.
intros b.
simpl in |- *.
auto with algebra.
Qed.

Hint Resolve Map_embed_eats_Map_to_equal_subsets: algebra.

Lemma Map_to_equal_subsets_inj :
 forall (A B : Setoid) (X Y : part_set A) (H H' : X =' Y in _)
   (f g : Map B X),
 Map_to_equal_subsets H f =' Map_to_equal_subsets H' g in _ ->
 f =' g in MAP _ _.
unfold Map_to_equal_subsets in |- *; simpl in |- *; unfold Map_eq in |- *;
 simpl in |- *; unfold subtype_image_equal in |- *;
 simpl in |- *.
intros.
apply subtype_elt_comp.
apply map_between_equal_subsets_inj with Y H H'; auto with algebra.
simpl in |- *; red in |- *; simpl in |- *.
auto.
Qed.

(** - if $\forall b\in B, f(b)\in W\subset A$ for $f:B\to A$ then $f$ can be seen as
 $f:B\to W$. This is done by cast_map_to_subset. *)

Definition cast_to_subset_fun :
  forall (A B : Setoid) (v : MAP B A) (W : part_set A),
  (forall i : B, in_part (v i) W) -> (B -> W:Type).
intros A B v.
elim v.
intros vseq vprf; intros.
generalize X; clear X.
simpl in |- *.
exact (fun i : B => Build_subtype (H i)).
Defined.

Lemma cast_doesn't_change :
 forall (A B : Setoid) (v : MAP B A) (W : part_set A)
   (H : forall i : B, in_part (v i) W) (i : B),
 subtype_elt (cast_to_subset_fun H i) =' v i in _.
intros A B v.
elim v.
simpl in |- *.
auto with algebra.
Qed.

Hint Resolve cast_doesn't_change: algebra.

(** %\label{castmaptosubset}% *)
Definition cast_map_to_subset :
  forall (A B : Setoid) (v : MAP B A) (W : part_set A),
  (forall i : B, in_part (v i) W) -> MAP B W.
intros.
cut (fun_compatible (cast_to_subset_fun H)).
intro.
exact (Build_Map H0).
red in |- *.
simpl in |- *.
red in |- *.
intros.
apply Trans with (v x); auto with algebra.
apply Trans with (v y); auto with algebra.
Defined.

Lemma cast_map_to_subset_doesn't_change :
 forall (A B : Setoid) (v : MAP B A) (W : part_set A)
   (H : forall i : B, in_part (v i) W) (i : B),
 subtype_elt (cast_map_to_subset H i) =' v i in _.
intros.
simpl in |- *.
auto with algebra.
Qed.

Hint Resolve cast_map_to_subset_doesn't_change: algebra.

Lemma Map_embed_cast_map_to_subset_inv :
 forall (A B : Setoid) (v : MAP B A) (W : part_set A)
   (H : forall i : B, in_part (v i) W),
 Map_embed (cast_map_to_subset H) =' v in _.
intros.
simpl in |- *.
red in |- *.
simpl in |- *.
auto with algebra.
Qed.

Hint Resolve Map_embed_cast_map_to_subset_inv: algebra.

Lemma Map_embed_eats_cast_map_to_subset :
 forall (A D : Setoid) (B C : part_set A) (v : MAP D B)
   (H : forall i : D, in_part (Map_embed v i) C),
 Map_embed (cast_map_to_subset H) =' Map_embed v in _.
intros.
auto with algebra.
Qed.

Hint Resolve Map_embed_eats_cast_map_to_subset: algebra.

Lemma seq_castable :
 forall (A B : Setoid) (v : MAP B A) (W : part_set A),
 (forall i : B, in_part (v i) W) -> exists w : MAP B W, Map_embed w =' v in _.
intros.
exists (cast_map_to_subset H).
auto with algebra.
Qed.

Hint Resolve seq_castable: algebra.

Lemma subset_seq_castable :
 forall (A D : Setoid) (B C : part_set A) (v : MAP D B)
   (H : forall i : D, in_part (Map_embed v i) C),
 exists w : MAP D C, Map_embed w =' Map_embed v in _.
intros.
exists (cast_map_to_subset H).
auto with algebra.
Qed.

Hint Resolve subset_seq_castable: algebra.

Lemma cast_seq_nice :
 forall (A B : Setoid) (v : MAP B A) (W : part_set A)
   (H : forall i : B, in_part (v i) W) (P : Predicate (MAP B A)),
 Pred_fun P v -> Pred_fun P (Map_embed (cast_map_to_subset H)).
destruct P.
intros.
red in Pred_compatible_prf.
simpl in |- *.
simpl in H0.
apply Pred_compatible_prf with v; auto with algebra.
Qed.

Hint Resolve cast_seq_nice: algebra.

Lemma cast_subset_seq_nice :
 forall (A D : Setoid) (B C : part_set A) (v : MAP D B)
   (H : forall i : D, in_part (Map_embed v i) C) (P : Predicate (MAP D A)),
 Pred_fun P (Map_embed v) -> Pred_fun P (Map_embed (cast_map_to_subset H)).
intros.
auto with algebra.
Qed.

Hint Resolve cast_subset_seq_nice: algebra.

Lemma cast_respects_predicates_per_elt :
 forall (A D : Setoid) (B C : part_set A) (v : MAP D B)
   (P : Predicate A) (H : forall i : D, in_part (Map_embed v i) C)
   (i : D),
 Pred_fun P (Map_embed v i) ->
 Pred_fun P (Map_embed (cast_map_to_subset H) i).
intros.
generalize H0; clear H0; elim P.
intros Pf pc H0.
simpl in |- *.
simpl in H0.
auto.
Qed.

Lemma cast_respects_all_elt_predicates :
 forall (A D : Setoid) (B C : part_set A) (v : MAP D B)
   (P : Predicate A) (H : forall i : D, in_part (Map_embed v i) C),
 (forall i : D, Pred_fun P (Map_embed v i)) ->
 forall j : D, Pred_fun P (Map_embed (cast_map_to_subset H) j).
intros.
generalize H0; clear H0; elim P.
intros Pf pc H0.
simpl in |- *.
simpl in H0.
auto.
Qed.

Hint Resolve cast_respects_predicates_per_elt
  cast_respects_all_elt_predicates: algebra.

(** - Similarly, if $B\subset C$ are subsets of $A$, then $f:D\to B$ is also $f:D\to C$. *)

Definition Map_include :
  forall (A D : Setoid) (B C : part_set A),
  included B C -> MAP D B -> MAP D C.
intros.
apply (cast_map_to_subset (v:=Map_embed X)).
red in H.
intro.
apply H; auto with algebra.
apply Map_embed_prop; auto with algebra.
Defined.

Definition Map_include_map :
  forall (A D : Setoid) (B C : part_set A),
  included B C -> MAP (MAP D B) (MAP D C).
intros.
simpl in |- *.
apply Build_Map with (Map_include (D:=D) H).
red in |- *.
intuition.
Defined.


(** Coq coding by choukh, May 2022 **)

From ZF Require Import Basic Embedding Universe.

(*** 范畴性 ***)

(** 等势模型 **)
Section Equipotent.
Variable 𝓜 𝓝 : ZF.
Notation i := (i 𝓝).
Notation j := (j 𝓜).

Variable f : 𝓜 → 𝓝.
Variable g : 𝓝 → 𝓜.
Variable fg : ∀ a, f (g a) = a.
Variable gf : ∀ x, g (f x) = x.

Theorem 等势模型同构 : 𝓜 ≅ 𝓝.
Proof.
  destruct (相似的完全性三歧 𝓜 𝓝) as [H|[[l[a s]]|[r[x s]]]].
  - apply H.
  - exfalso.
    set (a ∩ₚ (λ b, b ∉ f (j b))) as b.
    set (i (g b)) as c.
    assert (ca: c ∈ a) by apply s, i值域, l.
    assert (H: c ∈ b ↔ c ∈ a ∧ c ∉ f (j c)). unfold b. now rewrite 分离.
    unfold c in H at 4. rewrite ji, fg in H. 2:apply l.
    intuition.
  - exfalso.
    set (x ∩ₚ (λ y, y ∉ g (i y))) as y.
    set (j (f y)) as z.
    assert (zx: z ∈ x) by apply s, j定义域, r.
    assert (H: z ∈ y ↔ z ∈ x ∧ z ∉ g (i z)). unfold y. now rewrite 分离.
    unfold z in H at 4. rewrite ij, gf in H. 2:apply r.
    intuition.
Qed.

End Equipotent.

(** 极小模型 **)
Section Minimal.
Variable 𝓜 𝓝 : ZF.
Arguments 𝕯 : clear implicits.
Arguments 𝕹 : clear implicits.

Theorem 极小模型同构 : ZFₙ 0 𝓜 → ZFₙ 0 𝓝 → 𝓜 ≅ 𝓝.
Proof.
  intros minM%ZFₙO minN%ZFₙO.
  destruct (相似的完全性三歧 𝓜 𝓝) as [H|[[l[a s]]|[r[x s]]]].
  - apply H.
  - exfalso. apply minN. exists a.
    apply (@集化值域是宇宙 𝓝 𝓜), s.
  - exfalso. apply minM. exists x.
    apply 集化定义域是宇宙, s.
Qed.

End Minimal.

(** 有穷序数宇宙模型 **)
Section ZFsn.
Variable 𝓜 𝓝 : ZF.
Notation i := (i 𝓝).
Notation j := (j 𝓜).

Theorem 有穷序数宇宙模型同构 n : ZFₙ n 𝓜 → ZFₙ n 𝓝 → 𝓜 ≅ 𝓝.
Proof.
  intros Mn Nn. destruct n. apply 极小模型同构; trivial.
  destruct (相似的完全性三歧 𝓜 𝓝) as [H|[[l[a s]]|[r[x s]]]].
  - apply H.
  - exfalso. apply ZFₙS in Mn as [u [U [H _]]].
    apply Nn. apply 等级S. exists a. split.
    + apply (@集化值域是宇宙 𝓝 𝓜), s.
    + exists (i u). split. now apply s, i值域.
      assert (u ≈ i u) by apply i规范, l. split.
      * apply (相似保宇宙 (x:=u)); auto.
      * apply (相似保宇宙等级 (x:=u)); auto.
  - exfalso. apply ZFₙS in Nn as [u [U [H _]]].
    apply Mn. apply 等级S. exists x. split.
    + apply 集化定义域是宇宙, s.
    + exists (j u). split. now apply s, j定义域.
      assert (u ≈ j u) by apply 相似的对称性, j规范, r. split.
      * apply (相似保宇宙 (x:=u)); auto.
      * apply (相似保宇宙等级 (x:=u)); auto.
Qed.

End ZFsn.


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 A B C D U Bu Xu Du Bprime Dprime Dprimeprime : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ Xu O /\ (wd_ Dprimeprime O /\ (wd_ D Du /\ (wd_ Bu Xu /\ (wd_ B Bu /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime Bu /\ (col_ O E Xu /\ (col_ O Eprime Du /\ (col_ O Eprime Bprime /\ (col_ O Eprime Dprime /\ (col_ O Eprime Dprimeprime /\ col_ O Xu Dprimeprime)))))))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import VST.floyd.proofauto.
Require Import curve448.
Require Import stdpp.list.
Require Import ZArith.
Require Import compcert.lib.Coqlib.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Local Open Scope Z.

Definition curve448SetInt_spec : ident * funspec :=
DECLARE _curve448SetInt
WITH a : val,
     sha : share,
     contents_a : list val,
     b : Z,
     gv : globals
PRE [ tptr tuint, tuint ]
    PROP   (writable_share sha;
            Zlength contents_a = 14)
    PARAMS (a ; Vint(Int.repr b)) GLOBALS (gv)
    SEP    (data_at sha (tarray tuint 14) contents_a a)
POST [ tvoid ]
    PROP   ()
    RETURN ()
    SEP    (data_at sha (tarray tuint 14) (map Vint (map Int.repr (b :: (Zrepeat 0 13)))) a).

Definition curve448SetInt_INV a sha contents_a b :=
(EX i : Z,
(PROP   (writable_share sha;
        Zlength contents_a = 14)
LOCAL   (temp _a a)
SEP     (data_at sha (tarray tuint 14)
            ([Vint (Int.repr b)] ++ (Zrepeat (Vint (Int.repr 0)) (i-1)) ++
              sublist.sublist i 14 contents_a) a
        )))%assert.

Lemma L1 (h x : val) (l : list val) (i : Z) :
1 <= i -> upd_Znth i ([h] ++ l) x = [h] ++ (upd_Znth (i-1) l) x.
Proof. intros. list_simplify. Qed.

Lemma L2 (i : Z) (l1 l2 : list val) (x : val) :
Zlength l1 <= i ->
upd_Znth i (l1 ++ l2) x = l1 ++ (upd_Znth (i-(Zlength l1)) l2) x.
Proof. intros. list_simplify. Qed.

Lemma L3 (x h : val) (l : list val):
upd_Znth 0 ([h] ++ l) x  = [x] ++ l.
Proof. list_simplify. Qed.

Definition Gprog : funspecs := ltac:(with_library prog [ curve448SetInt_spec ]).

Lemma body_curve448SetInt : semax_body Vprog Gprog f_curve448SetInt curve448SetInt_spec.
Proof.
    start_function.
    forward.
    forward_for_simple_bound 14 (curve448SetInt_INV a sha contents_a b).
    -   entailer!.
        replace (upd_Znth 0 contents_a (Vint (Int.repr b))) with ([Vint (Int.repr b)] ++
        Zrepeat (Vint (Int.repr 0)) (1 - 1) ++ sublist.sublist 1 14 contents_a)
        by list_simplify; cancel.
    -   forward.
        entailer!.
        replace (upd_Znth i ([Vint (Int.repr b)] ++ Zrepeat (Vint (Int.repr 0)) (i - 1)
        ++ sublist.sublist i 14 contents_a) (Vint (Int.repr 0))) with
        ([Vint (Int.repr b)] ++ Zrepeat (Vint (Int.repr 0)) (i + 1 - 1) ++
        sublist.sublist (i + 1) 14 contents_a) by list_simplify; cancel.
    -   entailer!.
        replace ([Vint (Int.repr b)] ++
        Zrepeat (Vint (Int.repr 0)) (14 - 1) ++ sublist.sublist 14 14 contents_a) with
        (Vint (Int.repr b) :: map Vint (map Int.repr (Zrepeat 0 13))) by list_simplify;
        cancel.
Qed.