Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • iris/iris
  • jeehoon.kang/iris-coq
  • amintimany/iris-coq
  • dfrumin/iris-coq
  • Villetaneuse/iris
  • gares/iris
  • shiatsumat/iris
  • Blaisorblade/iris
  • jihgfee/iris-coq
  • mrhaandi/iris
  • tlsomers/iris
  • Quarkbeast/iris-coq
  • janno/iris
  • amaurremi/iris-coq
  • proux/iris
  • tchajed/iris
  • herbelin/iris-coq
  • msammler/iris-coq
  • maximedenes/iris-coq
  • bpeters/iris
  • haidang/iris
  • lepigre/iris
  • lczch/iris
  • simonspies/iris
  • gpirlea/iris
  • dkhalanskiyjb/iris
  • gmalecha/iris
  • germanD/iris
  • aa755/iris
  • jules/iris
  • abeln/iris
  • simonfv/iris
  • atrieu/iris
  • arthuraa/iris
  • simonh/iris
  • jung/iris
  • mattam82/iris
  • Armael/iris
  • adamAndMath/iris
  • gmevel/iris
  • snyke7/iris
  • johannes/iris
  • NiklasM/iris
  • simonspies/iris-parametric-index
  • svancollem/iris
  • proux1/iris
  • wmansky/iris
  • LukeXuan/iris
  • ivanbakel/iris
  • SkySkimmer/iris
  • tjhance/iris
  • yiyunliu/iris
  • Lee-Janggun/iris
  • thomas-lamiaux/iris
  • dongjae/iris
  • dnezam/iris
  • Tragicus/iris
  • clef-men/iris
  • ffengyu/iris
59 results
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 3938 additions and 1985 deletions
heap_lang/lang.v deleted 100644 → 0
View file @ 2bc4df02
From iris.program_logic Require Export ectx_language ectxi_language.
From iris.algebra Require Export cofe.
From iris.prelude Require Export strings.
From iris.prelude Require Import gmap.
Module heap_lang.
Open Scope Z_scope.
(** Expressions and vals. *)
Definition loc := positive. (* Really, any countable type. *)
Inductive base_lit : Set :=
| LitInt (n : Z) | LitBool (b : bool) | LitUnit | LitLoc (l : loc).
Inductive un_op : Set :=
| NegOp | MinusUnOp.
Inductive bin_op : Set :=
| PlusOp | MinusOp | LeOp | LtOp | EqOp.
Inductive binder := BAnon | BNamed : string → binder.
Delimit Scope binder_scope with bind.
Bind Scope binder_scope with binder.
Definition cons_binder (mx : binder) (X : list string) : list string :=
match mx with BAnon => X | BNamed x => x :: X end.
Infix ":b:" := cons_binder (at level 60, right associativity).
Instance binder_dec_eq (x1 x2 : binder) : Decision (x1 = x2).
Proof. solve_decision. Defined.
Instance set_unfold_cons_binder x mx X P :
SetUnfold (x ∈ X) P → SetUnfold (x ∈ mx :b: X) (BNamed x = mx ∨ P).
Proof.
constructor. rewrite -(set_unfold (x ∈ X) P).
destruct mx; rewrite /= ?elem_of_cons; naive_solver.
Qed.
(** A typeclass for whether a variable is bound in a given
context. Making this a typeclass means we can use typeclass search
to program solving these constraints, so this becomes extensible.
Also, since typeclass search runs *after* unification, Coq has already
inferred the X for us; if we were to go for embedded proof terms ot
tactics, Coq would do things in the wrong order. *)
Class VarBound (x : string) (X : list string) :=
var_bound : bool_decide (x ∈ X).
(* There is no need to restrict this hint to terms without evars, [vm_compute]
will fail in case evars are arround. *)
Hint Extern 0 (VarBound _ _) => vm_compute; exact I : typeclass_instances.
Instance var_bound_proof_irrel x X : ProofIrrel (VarBound x X).
Proof. rewrite /VarBound. apply _. Qed.
Instance set_unfold_var_bound x X P :
SetUnfold (x ∈ X) P → SetUnfold (VarBound x X) P.
Proof.
constructor. by rewrite /VarBound bool_decide_spec (set_unfold (x ∈ X) P).
Qed.
Inductive expr (X : list string) :=
(* Base lambda calculus *)
(* Var is the only place where the terms contain a proof. The fact that they
contain a proof at all is suboptimal, since this means two seeminlgy
convertible terms could differ in their proofs. However, this also has
some advantages:
* We can make the [X] an index, so we can do non-dependent match.
* In expr_weaken, we can push the proof all the way into Var, making
sure that proofs never block computation. *)
| Var (x : string) `{VarBound x X}
| Rec (f x : binder) (e : expr (f :b: x :b: X))
| App (e1 e2 : expr X)
(* Base types and their operations *)
| Lit (l : base_lit)
| UnOp (op : un_op) (e : expr X)
| BinOp (op : bin_op) (e1 e2 : expr X)
| If (e0 e1 e2 : expr X)
(* Products *)
| Pair (e1 e2 : expr X)
| Fst (e : expr X)
| Snd (e : expr X)
(* Sums *)
| InjL (e : expr X)
| InjR (e : expr X)
| Case (e0 : expr X) (e1 : expr X) (e2 : expr X)
(* Concurrency *)
| Fork (e : expr X)
(* Heap *)
| Alloc (e : expr X)
| Load (e : expr X)
| Store (e1 : expr X) (e2 : expr X)
| CAS (e0 : expr X) (e1 : expr X) (e2 : expr X).
Bind Scope expr_scope with expr.
Delimit Scope expr_scope with E.
Arguments Var {_} _ {_}.
Arguments Rec {_} _ _ _%E.
Arguments App {_} _%E _%E.
Arguments Lit {_} _.
Arguments UnOp {_} _ _%E.
Arguments BinOp {_} _ _%E _%E.
Arguments If {_} _%E _%E _%E.
Arguments Pair {_} _%E _%E.
Arguments Fst {_} _%E.
Arguments Snd {_} _%E.
Arguments InjL {_} _%E.
Arguments InjR {_} _%E.
Arguments Case {_} _%E _%E _%E.
Arguments Fork {_} _%E.
Arguments Alloc {_} _%E.
Arguments Load {_} _%E.
Arguments Store {_} _%E _%E.
Arguments CAS {_} _%E _%E _%E.
Inductive val :=
| RecV (f x : binder) (e : expr (f :b: x :b: []))
| LitV (l : base_lit)
| PairV (v1 v2 : val)
| InjLV (v : val)
| InjRV (v : val).
Bind Scope val_scope with val.
Delimit Scope val_scope with V.
Arguments PairV _%V _%V.
Arguments InjLV _%V.
Arguments InjRV _%V.
Fixpoint of_val (v : val) : expr [] :=
match v with
| RecV f x e => Rec f x e
| LitV l => Lit l
| PairV v1 v2 => Pair (of_val v1) (of_val v2)
| InjLV v => InjL (of_val v)
| InjRV v => InjR (of_val v)
end.
Fixpoint to_val (e : expr []) : option val :=
match e with
| Rec f x e => Some (RecV f x e)
| Lit l => Some (LitV l)
| Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
| InjL e => InjLV <$> to_val e
| InjR e => InjRV <$> to_val e
| _ => None
end.
(** The state: heaps of vals. *)
Definition state := gmap loc val.
(** Evaluation contexts *)
Inductive ectx_item :=
| AppLCtx (e2 : expr [])
| AppRCtx (v1 : val)
| UnOpCtx (op : un_op)
| BinOpLCtx (op : bin_op) (e2 : expr [])
| BinOpRCtx (op : bin_op) (v1 : val)
| IfCtx (e1 e2 : expr [])
| PairLCtx (e2 : expr [])
| PairRCtx (v1 : val)
| FstCtx
| SndCtx
| InjLCtx
| InjRCtx
| CaseCtx (e1 : expr []) (e2 : expr [])
| AllocCtx
| LoadCtx
| StoreLCtx (e2 : expr [])
| StoreRCtx (v1 : val)
| CasLCtx (e1 : expr []) (e2 : expr [])
| CasMCtx (v0 : val) (e2 : expr [])
| CasRCtx (v0 : val) (v1 : val).
Definition fill_item (Ki : ectx_item) (e : expr []) : expr [] :=
match Ki with
| AppLCtx e2 => App e e2
| AppRCtx v1 => App (of_val v1) e
| UnOpCtx op => UnOp op e
| BinOpLCtx op e2 => BinOp op e e2
| BinOpRCtx op v1 => BinOp op (of_val v1) e
| IfCtx e1 e2 => If e e1 e2
| PairLCtx e2 => Pair e e2
| PairRCtx v1 => Pair (of_val v1) e
| FstCtx => Fst e
| SndCtx => Snd e
| InjLCtx => InjL e
| InjRCtx => InjR e
| CaseCtx e1 e2 => Case e e1 e2
| AllocCtx => Alloc e
| LoadCtx => Load e
| StoreLCtx e2 => Store e e2
| StoreRCtx v1 => Store (of_val v1) e
| CasLCtx e1 e2 => CAS e e1 e2
| CasMCtx v0 e2 => CAS (of_val v0) e e2
| CasRCtx v0 v1 => CAS (of_val v0) (of_val v1) e
end.
(** Substitution *)
(** We have [subst' e BAnon v = e] to deal with anonymous binders *)
Lemma wexpr_rec_prf {X Y} (H : X `included` Y) {f x} :
f :b: x :b: X `included` f :b: x :b: Y.
Proof. set_solver. Qed.
Program Fixpoint wexpr {X Y} (H : X `included` Y) (e : expr X) : expr Y :=
match e return expr Y with
| Var x _ => @Var _ x _
| Rec f x e => Rec f x (wexpr (wexpr_rec_prf H) e)
| App e1 e2 => App (wexpr H e1) (wexpr H e2)
| Lit l => Lit l
| UnOp op e => UnOp op (wexpr H e)
| BinOp op e1 e2 => BinOp op (wexpr H e1) (wexpr H e2)
| If e0 e1 e2 => If (wexpr H e0) (wexpr H e1) (wexpr H e2)
| Pair e1 e2 => Pair (wexpr H e1) (wexpr H e2)
| Fst e => Fst (wexpr H e)
| Snd e => Snd (wexpr H e)
| InjL e => InjL (wexpr H e)
| InjR e => InjR (wexpr H e)
| Case e0 e1 e2 => Case (wexpr H e0) (wexpr H e1) (wexpr H e2)
| Fork e => Fork (wexpr H e)
| Alloc e => Alloc (wexpr H e)
| Load e => Load (wexpr H e)
| Store e1 e2 => Store (wexpr H e1) (wexpr H e2)
| CAS e0 e1 e2 => CAS (wexpr H e0) (wexpr H e1) (wexpr H e2)
end.
Solve Obligations with set_solver.
Definition wexpr' {X} (e : expr []) : expr X := wexpr (included_nil _) e.
Definition of_val' {X} (v : val) : expr X := wexpr (included_nil _) (of_val v).
Lemma wsubst_rec_true_prf {X Y x} (H : X `included` x :: Y) {f y}
(Hfy : BNamed x ≠ f ∧ BNamed x ≠ y) :
f :b: y :b: X `included` x :: f :b: y :b: Y.
Proof. set_solver. Qed.
Lemma wsubst_rec_false_prf {X Y x} (H : X `included` x :: Y) {f y}
(Hfy : ¬(BNamed x ≠ f ∧ BNamed x ≠ y)) :
f :b: y :b: X `included` f :b: y :b: Y.
Proof. move: Hfy=>/not_and_l [/dec_stable|/dec_stable]; set_solver. Qed.
Program Fixpoint wsubst {X Y} (x : string) (es : expr [])
(H : X `included` x :: Y) (e : expr X) : expr Y :=
match e return expr Y with
| Var y _ => if decide (x = y) then wexpr' es else @Var _ y _
| Rec f y e =>
Rec f y $ match decide (BNamed x ≠ f ∧ BNamed x ≠ y) return _ with
| left Hfy => wsubst x es (wsubst_rec_true_prf H Hfy) e
| right Hfy => wexpr (wsubst_rec_false_prf H Hfy) e
end
| App e1 e2 => App (wsubst x es H e1) (wsubst x es H e2)
| Lit l => Lit l
| UnOp op e => UnOp op (wsubst x es H e)
| BinOp op e1 e2 => BinOp op (wsubst x es H e1) (wsubst x es H e2)
| If e0 e1 e2 => If (wsubst x es H e0) (wsubst x es H e1) (wsubst x es H e2)
| Pair e1 e2 => Pair (wsubst x es H e1) (wsubst x es H e2)
| Fst e => Fst (wsubst x es H e)
| Snd e => Snd (wsubst x es H e)
| InjL e => InjL (wsubst x es H e)
| InjR e => InjR (wsubst x es H e)
| Case e0 e1 e2 =>
Case (wsubst x es H e0) (wsubst x es H e1) (wsubst x es H e2)
| Fork e => Fork (wsubst x es H e)
| Alloc e => Alloc (wsubst x es H e)
| Load e => Load (wsubst x es H e)
| Store e1 e2 => Store (wsubst x es H e1) (wsubst x es H e2)
| CAS e0 e1 e2 => CAS (wsubst x es H e0) (wsubst x es H e1) (wsubst x es H e2)
end.
Solve Obligations with set_solver.
Definition subst {X} (x : string) (es : expr []) (e : expr (x :: X)) : expr X :=
wsubst x es (λ z, id) e.
Definition subst' {X} (mx : binder) (es : expr []) : expr (mx :b: X) → expr X :=
match mx with BNamed x => subst x es | BAnon => id end.
(** The stepping relation *)
Definition un_op_eval (op : un_op) (l : base_lit) : option base_lit :=
match op, l with
| NegOp, LitBool b => Some (LitBool (negb b))
| MinusUnOp, LitInt n => Some (LitInt (- n))
| _, _ => None
end.
Definition bin_op_eval (op : bin_op) (l1 l2 : base_lit) : option base_lit :=
match op, l1, l2 with
| PlusOp, LitInt n1, LitInt n2 => Some $ LitInt (n1 + n2)
| MinusOp, LitInt n1, LitInt n2 => Some $ LitInt (n1 - n2)
| LeOp, LitInt n1, LitInt n2 => Some $ LitBool $ bool_decide (n1 ≤ n2)
| LtOp, LitInt n1, LitInt n2 => Some $ LitBool $ bool_decide (n1 < n2)
| EqOp, LitInt n1, LitInt n2 => Some $ LitBool $ bool_decide (n1 = n2)
| _, _, _ => None
end.
Inductive head_step : expr [] → state → expr [] → state → option (expr []) → Prop :=
| BetaS f x e1 e2 v2 e' σ :
to_val e2 = Some v2 →
e' = subst' x (of_val v2) (subst' f (Rec f x e1) e1) →
head_step (App (Rec f x e1) e2) σ e' σ None
| UnOpS op l l' σ :
un_op_eval op l = Some l' →
head_step (UnOp op (Lit l)) σ (Lit l') σ None
| BinOpS op l1 l2 l' σ :
bin_op_eval op l1 l2 = Some l' →
head_step (BinOp op (Lit l1) (Lit l2)) σ (Lit l') σ None
| IfTrueS e1 e2 σ :
head_step (If (Lit $ LitBool true) e1 e2) σ e1 σ None
| IfFalseS e1 e2 σ :
head_step (If (Lit $ LitBool false) e1 e2) σ e2 σ None
| FstS e1 v1 e2 v2 σ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
head_step (Fst (Pair e1 e2)) σ e1 σ None
| SndS e1 v1 e2 v2 σ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
head_step (Snd (Pair e1 e2)) σ e2 σ None
| CaseLS e0 v0 e1 e2 σ :
to_val e0 = Some v0 →
head_step (Case (InjL e0) e1 e2) σ (App e1 e0) σ None
| CaseRS e0 v0 e1 e2 σ :
to_val e0 = Some v0 →
head_step (Case (InjR e0) e1 e2) σ (App e2 e0) σ None
| ForkS e σ:
head_step (Fork e) σ (Lit LitUnit) σ (Some e)
| AllocS e v σ l :
to_val e = Some v → σ !! l = None →
head_step (Alloc e) σ (Lit $ LitLoc l) (<[l:=v]>σ) None
| LoadS l v σ :
σ !! l = Some v →
head_step (Load (Lit $ LitLoc l)) σ (of_val v) σ None
| StoreS l e v σ :
to_val e = Some v → is_Some (σ !! l) →
head_step (Store (Lit $ LitLoc l) e) σ (Lit LitUnit) (<[l:=v]>σ) None
| CasFailS l e1 v1 e2 v2 vl σ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
σ !! l = Some vl → vl ≠ v1 →
head_step (CAS (Lit $ LitLoc l) e1 e2) σ (Lit $ LitBool false) σ None
| CasSucS l e1 v1 e2 v2 σ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
σ !! l = Some v1 →
head_step (CAS (Lit $ LitLoc l) e1 e2) σ (Lit $ LitBool true) (<[l:=v2]>σ) None.
(** Atomic expressions *)
Definition atomic (e: expr []) : bool :=
match e with
| Alloc e => bool_decide (is_Some (to_val e))
| Load e => bool_decide (is_Some (to_val e))
| Store e1 e2 => bool_decide (is_Some (to_val e1) ∧ is_Some (to_val e2))
| CAS e0 e1 e2 =>
bool_decide (is_Some (to_val e0) ∧ is_Some (to_val e1) ∧ is_Some (to_val e2))
(* Make "skip" atomic *)
| App (Rec _ _ (Lit _)) (Lit _) => true
| _ => false
end.
(** Substitution *)
Lemma var_proof_irrel X x H1 H2 : @Var X x H1 = @Var X x H2.
Proof. f_equal. by apply (proof_irrel _). Qed.
Lemma wexpr_id X (H : X `included` X) e : wexpr H e = e.
Proof. induction e; f_equal/=; auto. by apply (proof_irrel _). Qed.
Lemma wexpr_proof_irrel X Y (H1 H2 : X `included` Y) e : wexpr H1 e = wexpr H2 e.
Proof.
revert Y H1 H2; induction e; simpl; auto using var_proof_irrel with f_equal.
Qed.
Lemma wexpr_wexpr X Y Z (H1 : X `included` Y) (H2 : Y `included` Z) H3 e :
wexpr H2 (wexpr H1 e) = wexpr H3 e.
Proof.
revert Y Z H1 H2 H3.
induction e; simpl; auto using var_proof_irrel with f_equal.
Qed.
Lemma wexpr_wexpr' X Y Z (H1 : X `included` Y) (H2 : Y `included` Z) e :
wexpr H2 (wexpr H1 e) = wexpr (transitivity H1 H2) e.
Proof. apply wexpr_wexpr. Qed.
Lemma wsubst_proof_irrel X Y x es (H1 H2 : X `included` x :: Y) e :
wsubst x es H1 e = wsubst x es H2 e.
Proof.
revert Y H1 H2; induction e; simpl; intros; repeat case_decide;
auto using var_proof_irrel, wexpr_proof_irrel with f_equal.
Qed.
Lemma wexpr_wsubst X Y Z x es (H1: X `included` x::Y) (H2: Y `included` Z) H3 e:
wexpr H2 (wsubst x es H1 e) = wsubst x es H3 e.
Proof.
revert Y Z H1 H2 H3.
induction e; intros; repeat (case_decide || simplify_eq/=);
unfold wexpr'; auto using var_proof_irrel, wexpr_wexpr with f_equal.
Qed.
Lemma wsubst_wexpr X Y Z x es (H1: X `included` Y) (H2: Y `included` x::Z) H3 e:
wsubst x es H2 (wexpr H1 e) = wsubst x es H3 e.
Proof.
revert Y Z H1 H2 H3.
induction e; intros; repeat (case_decide || simplify_eq/=);
auto using var_proof_irrel, wexpr_wexpr with f_equal.
Qed.
Lemma wsubst_wexpr' X Y Z x es (H1: X `included` Y) (H2: Y `included` x::Z) e:
wsubst x es H2 (wexpr H1 e) = wsubst x es (transitivity H1 H2) e.
Proof. apply wsubst_wexpr. Qed.
Lemma wsubst_closed X Y x es (H1 : X `included` x :: Y) H2 (e : expr X) :
x ∉ X → wsubst x es H1 e = wexpr H2 e.
Proof.
revert Y H1 H2.
induction e; intros; repeat (case_decide || simplify_eq/=);
auto using var_proof_irrel, wexpr_proof_irrel with f_equal set_solver.
exfalso; set_solver.
Qed.
Lemma wsubst_closed_nil x es H (e : expr []) : wsubst x es H e = e.
Proof.
rewrite -{2}(wexpr_id _ (reflexivity []) e).
apply wsubst_closed, not_elem_of_nil.
Qed.
(** Basic properties about the language *)
Lemma to_of_val v : to_val (of_val v) = Some v.
Proof. by induction v; simplify_option_eq. Qed.
Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof.
revert e v. cut (∀ X (e : expr X) (H : X = ∅) v,
to_val (eq_rect _ expr e _ H) = Some v → of_val v = eq_rect _ expr e _ H).
{ intros help e v. apply (help ∅ e eq_refl). }
intros X e; induction e; intros HX ??; simplify_option_eq;
repeat match goal with
| IH : ∀ _ : ∅ = ∅, _ |- _ => specialize (IH eq_refl); simpl in IH
end; auto with f_equal.
Qed.
Instance of_val_inj : Inj (=) (=) of_val.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.
Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.
Lemma fill_item_val Ki e :
is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.
Lemma val_stuck e1 σ1 e2 σ2 ef :
head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
Proof. destruct 1; naive_solver. Qed.
Lemma atomic_not_val e : atomic e → to_val e = None.
Proof. by destruct e. Qed.
Lemma atomic_fill_item Ki e : atomic (fill_item Ki e) → is_Some (to_val e).
Proof.
intros. destruct Ki; simplify_eq/=; destruct_and?;
repeat (case_match || contradiction); eauto.
Qed.
Lemma atomic_step e1 σ1 e2 σ2 ef :
atomic e1 → head_step e1 σ1 e2 σ2 ef → is_Some (to_val e2).
Proof.
destruct 2; simpl; rewrite ?to_of_val; try by eauto. subst.
unfold subst'; repeat (case_match || contradiction || simplify_eq/=); eauto.
Qed.
Lemma head_ctx_step_val Ki e σ1 e2 σ2 ef :
head_step (fill_item Ki e) σ1 e2 σ2 ef → is_Some (to_val e).
Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.
Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
to_val e1 = None → to_val e2 = None →
fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
destruct Ki1, Ki2; intros; try discriminate; simplify_eq/=;
repeat match goal with
| H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
end; auto.
Qed.
Lemma alloc_fresh e v σ :
let l := fresh (dom _ σ) in
to_val e = Some v → head_step (Alloc e) σ (Lit (LitLoc l)) (<[l:=v]>σ) None.
Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset _)), is_fresh. Qed.
(** Equality and other typeclass stuff *)
Instance base_lit_dec_eq (l1 l2 : base_lit) : Decision (l1 = l2).
Proof. solve_decision. Defined.
Instance un_op_dec_eq (op1 op2 : un_op) : Decision (op1 = op2).
Proof. solve_decision. Defined.
Instance bin_op_dec_eq (op1 op2 : bin_op) : Decision (op1 = op2).
Proof. solve_decision. Defined.
Fixpoint expr_beq {X Y} (e : expr X) (e' : expr Y) : bool :=
match e, e' with
| Var x _, Var x' _ => bool_decide (x = x')
| Rec f x e, Rec f' x' e' =>
bool_decide (f = f') && bool_decide (x = x') && expr_beq e e'
| App e1 e2, App e1' e2' | Pair e1 e2, Pair e1' e2' |
Store e1 e2, Store e1' e2' => expr_beq e1 e1' && expr_beq e2 e2'
| Lit l, Lit l' => bool_decide (l = l')
| UnOp op e, UnOp op' e' => bool_decide (op = op') && expr_beq e e'
| BinOp op e1 e2, BinOp op' e1' e2' =>
bool_decide (op = op') && expr_beq e1 e1' && expr_beq e2 e2'
| If e0 e1 e2, If e0' e1' e2' | Case e0 e1 e2, Case e0' e1' e2' |
CAS e0 e1 e2, CAS e0' e1' e2' =>
expr_beq e0 e0' && expr_beq e1 e1' && expr_beq e2 e2'
| Fst e, Fst e' | Snd e, Snd e' | InjL e, InjL e' | InjR e, InjR e' |
Fork e, Fork e' | Alloc e, Alloc e' | Load e, Load e' => expr_beq e e'
| _, _ => false
end.
Lemma expr_beq_correct {X} (e1 e2 : expr X) : expr_beq e1 e2 ↔ e1 = e2.
Proof.
split.
* revert e2; induction e1; intros [] * ?; simpl in *;
destruct_and?; subst; repeat f_equal/=; auto; try apply proof_irrel.
* intros ->. induction e2; naive_solver.
Qed.
Instance expr_dec_eq {X} (e1 e2 : expr X) : Decision (e1 = e2).
Proof.
refine (cast_if (decide (expr_beq e1 e2))); by rewrite -expr_beq_correct.
Defined.
Instance val_dec_eq (v1 v2 : val) : Decision (v1 = v2).
Proof.
refine (cast_if (decide (of_val v1 = of_val v2))); abstract naive_solver.
Defined.
Instance expr_inhabited X : Inhabited (expr X) := populate (Lit LitUnit).
Instance val_inhabited : Inhabited val := populate (LitV LitUnit).
Canonical Structure stateC := leibnizC state.
Canonical Structure valC := leibnizC val.
Canonical Structure exprC X := leibnizC (expr X).
End heap_lang.
(** Language *)
Program Instance heap_ectxi_lang :
EctxiLanguage
(heap_lang.expr []) heap_lang.val heap_lang.ectx_item heap_lang.state := {|
of_val := heap_lang.of_val; to_val := heap_lang.to_val;
fill_item := heap_lang.fill_item;
atomic := heap_lang.atomic; head_step := heap_lang.head_step;
|}.
Solve Obligations with eauto using heap_lang.to_of_val, heap_lang.of_to_val,
heap_lang.val_stuck, heap_lang.atomic_not_val, heap_lang.atomic_step,
heap_lang.fill_item_val, heap_lang.atomic_fill_item,
heap_lang.fill_item_no_val_inj, heap_lang.head_ctx_step_val.
Canonical Structure heap_lang := ectx_lang (heap_lang.expr []).
(* Prefer heap_lang names over ectx_language names. *)
Export heap_lang.
heap_lang/lib/assert.v deleted 100644 → 0
View file @ 2bc4df02
From iris.heap_lang Require Export derived.
From iris.heap_lang Require Import wp_tactics substitution notation.
Definition Assert {X} (e : expr X) : expr X :=
if: e then #() else #0 #0. (* #0 #0 is unsafe *)
Instance do_wexpr_assert {X Y} (H : X `included` Y) e er :
WExpr H e er → WExpr H (Assert e) (Assert er) := _.
Instance do_wsubst_assert {X Y} x es (H : X `included` x :: Y) e er :
WSubst x es H e er → WSubst x es H (Assert e) (Assert er).
Proof. intros; red. by rewrite /Assert /wsubst -/wsubst; f_equal/=. Qed.
Typeclasses Opaque Assert.
Lemma wp_assert {Σ} (Φ : val → iProp heap_lang Σ) :
▷ Φ #() ⊢ WP Assert #true {{ Φ }}.
Proof. by rewrite -wp_if_true -wp_value. Qed.
Lemma wp_assert' {Σ} (Φ : val → iProp heap_lang Σ) e :
WP e {{ v, v = #true ∧ ▷ Φ #() }} ⊢ WP Assert e {{ Φ }}.
Proof.
rewrite /Assert. wp_focus e; apply wp_mono=>v.
apply uPred.pure_elim_l=>->. apply wp_assert.
Qed.
heap_lang/lib/barrier/barrier.v deleted 100644 → 0
View file @ 2bc4df02
From iris.heap_lang Require Export notation.
Definition newbarrier : val := λ: <>, ref #0.
Definition signal : val := λ: "x", '"x" <- #1.
Definition wait : val :=
rec: "wait" "x" := if: !'"x" = #1 then #() else '"wait" '"x".
Global Opaque newbarrier signal wait.
heap_lang/lib/barrier/proof.v deleted 100644 → 0
View file @ 2bc4df02
From iris.prelude Require Import functions.
From iris.algebra Require Import upred_big_op.
From iris.program_logic Require Import saved_prop.
From iris.heap_lang Require Import proofmode.
From iris.proofmode Require Import sts.
From iris.heap_lang.lib.barrier Require Export barrier.
From iris.heap_lang.lib.barrier Require Import protocol.
Import uPred.
(** The CMRAs we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class barrierG Σ := BarrierG {
barrier_stsG :> stsG heap_lang Σ sts;
barrier_savedPropG :> savedPropG heap_lang Σ idCF;
}.
(** The Functors we need. *)
Definition barrierGF : gFunctorList := [stsGF sts; savedPropGF idCF].
(* Show and register that they match. *)
Instance inGF_barrierG `{H : inGFs heap_lang Σ barrierGF} : barrierG Σ.
Proof. destruct H as (?&?&?). split; apply _. Qed.
(** Now we come to the Iris part of the proof. *)
Section proof.
Context {Σ : gFunctors} `{!heapG Σ, !barrierG Σ}.
Context (heapN N : namespace).
Implicit Types I : gset gname.
Local Notation iProp := (iPropG heap_lang Σ).
Definition ress (P : iProp) (I : gset gname) : iProp :=
(∃ Ψ : gname → iProp,
▷ (P -★ [★ set] i ∈ I, Ψ i) ★ [★ set] i ∈ I, saved_prop_own i (Ψ i))%I.
Coercion state_to_val (s : state) : val :=
match s with State Low _ => #0 | State High _ => #1 end.
Arguments state_to_val !_ / : simpl nomatch.
Definition state_to_prop (s : state) (P : iProp) : iProp :=
match s with State Low _ => P | State High _ => True%I end.
Arguments state_to_prop !_ _ / : simpl nomatch.
Definition barrier_inv (l : loc) (P : iProp) (s : state) : iProp :=
(l ↦ s ★ ress (state_to_prop s P) (state_I s))%I.
Definition barrier_ctx (γ : gname) (l : loc) (P : iProp) : iProp :=
(■ (heapN ⊥ N) ★ heap_ctx heapN ★ sts_ctx γ N (barrier_inv l P))%I.
Definition send (l : loc) (P : iProp) : iProp :=
(∃ γ, barrier_ctx γ l P ★ sts_ownS γ low_states {[ Send ]})%I.
Definition recv (l : loc) (R : iProp) : iProp :=
(∃ γ P Q i,
barrier_ctx γ l P ★ sts_ownS γ (i_states i) {[ Change i ]} ★
saved_prop_own i Q ★ ▷ (Q -★ R))%I.
Global Instance barrier_ctx_persistent (γ : gname) (l : loc) (P : iProp) :
PersistentP (barrier_ctx γ l P).
Proof. apply _. Qed.
Typeclasses Opaque barrier_ctx send recv.
(** Setoids *)
Global Instance ress_ne n : Proper (dist n ==> (=) ==> dist n) ress.
Proof. solve_proper. Qed.
Global Instance state_to_prop_ne n s :
Proper (dist n ==> dist n) (state_to_prop s).
Proof. solve_proper. Qed.
Global Instance barrier_inv_ne n l :
Proper (dist n ==> eq ==> dist n) (barrier_inv l).
Proof. solve_proper. Qed.
Global Instance barrier_ctx_ne n γ l : Proper (dist n ==> dist n) (barrier_ctx γ l).
Proof. solve_proper. Qed.
Global Instance send_ne n l : Proper (dist n ==> dist n) (send l).
Proof. solve_proper. Qed.
Global Instance recv_ne n l : Proper (dist n ==> dist n) (recv l).
Proof. solve_proper. Qed.
(** Helper lemmas *)
Lemma ress_split i i1 i2 Q R1 R2 P I :
i ∈ I → i1 ∉ I → i2 ∉ I → i1 ≠ i2 →
saved_prop_own i Q ★ saved_prop_own i1 R1 ★ saved_prop_own i2 R2 ★
(Q -★ R1 ★ R2) ★ ress P I
⊢ ress P ({[i1;i2]} ∪ I ∖ {[i]}).
Proof.
iIntros {????} "(#HQ&#H1&#H2&HQR&H)"; iDestruct "H" as {Ψ} "[HPΨ HΨ]".
iDestruct (big_sepS_delete _ _ i with "HΨ") as "[#HΨi HΨ]"; first done.
iExists (<[i1:=R1]> (<[i2:=R2]> Ψ)). iSplitL "HQR HPΨ".
- iPoseProof (saved_prop_agree i Q (Ψ i) with "[#]") as "Heq"; first by iSplit.
iNext. iRewrite "Heq" in "HQR". iIntros "HP". iSpecialize ("HPΨ" with "HP").
iDestruct (big_sepS_delete _ _ i with "HPΨ") as "[HΨ HPΨ]"; first done.
iDestruct ("HQR" with "HΨ") as "[HR1 HR2]".
rewrite -assoc_L !big_sepS_fn_insert'; [|abstract set_solver ..].
by iFrame.
- rewrite -assoc_L !big_sepS_fn_insert; [|abstract set_solver ..]. eauto.
Qed.
(** Actual proofs *)
Lemma newbarrier_spec (P : iProp) (Φ : val → iProp) :
heapN ⊥ N →
heap_ctx heapN ★ (∀ l, recv l P ★ send l P -★ Φ #l)
⊢ WP newbarrier #() {{ Φ }}.
Proof.
iIntros {HN} "[#? HΦ]".
rewrite /newbarrier. wp_seq. wp_alloc l as "Hl".
iApply "HΦ".
iPvs (saved_prop_alloc (F:=idCF) _ P) as {γ} "#?".
iPvs (sts_alloc (barrier_inv l P) _ N (State Low {[ γ ]}) with "[-]")
as {γ'} "[#? Hγ']"; eauto.
{ iNext. rewrite /barrier_inv /=. iFrame.
iExists (const P). rewrite !big_sepS_singleton /=. eauto. }
iAssert (barrier_ctx γ' l P)%I as "#?".
{ rewrite /barrier_ctx. by repeat iSplit. }
iAssert (sts_ownS γ' (i_states γ) {[Change γ]}
★ sts_ownS γ' low_states {[Send]})%I with "|==>[-]" as "[Hr Hs]".
{ iApply sts_ownS_op; eauto using i_states_closed, low_states_closed.
+ set_solver.
+ iApply (sts_own_weaken with "Hγ'");
auto using sts.closed_op, i_states_closed, low_states_closed;
abstract set_solver. }
iPvsIntro. rewrite /recv /send. iSplitL "Hr".
- iExists γ', P, P, γ. iFrame. auto.
- auto.
Qed.
Lemma signal_spec l P (Φ : val → iProp) :
send l P ★ P ★ Φ #() ⊢ WP signal #l {{ Φ }}.
Proof.
rewrite /signal /send /barrier_ctx.
iIntros "(Hs&HP&HΦ)"; iDestruct "Hs" as {γ} "[#(%&Hh&Hsts) Hγ]". wp_let.
iSts γ as [p I]; iDestruct "Hγ" as "[Hl Hr]".
wp_store. iPvsIntro. destruct p; [|done].
iExists (State High I), (∅ : set token).
iSplit; [iPureIntro; by eauto using signal_step|].
iSplitR "HΦ"; [iNext|by auto].
rewrite {2}/barrier_inv /ress /=; iFrame "Hl".
iDestruct "Hr" as {Ψ} "[Hr Hsp]"; iExists Ψ; iFrame "Hsp".
iIntros "> _"; by iApply "Hr".
Qed.
Lemma wait_spec l P (Φ : val → iProp) :
recv l P ★ (P -★ Φ #()) ⊢ WP wait #l {{ Φ }}.
Proof.
rename P into R; rewrite /recv /barrier_ctx.
iIntros "[Hr HΦ]"; iDestruct "Hr" as {γ P Q i} "(#(%&Hh&Hsts)&Hγ&#HQ&HQR)".
iLöb as "IH". wp_rec. wp_focus (! _)%E.
iSts γ as [p I]; iDestruct "Hγ" as "[Hl Hr]".
wp_load. iPvsIntro. destruct p.
- (* a Low state. The comparison fails, and we recurse. *)
iExists (State Low I), {[ Change i ]}; iSplit; [done|iSplitL "Hl Hr"].
{ iNext. rewrite {2}/barrier_inv /=. by iFrame. }
iIntros "Hγ".
iAssert (sts_ownS γ (i_states i) {[Change i]})%I with "|==>[Hγ]" as "Hγ".
{ iApply (sts_own_weaken with "Hγ"); eauto using i_states_closed. }
wp_op=> ?; simplify_eq; wp_if. iApply ("IH" with "Hγ [HQR] HΦ"). auto.
- (* a High state: the comparison succeeds, and we perform a transition and
return to the client *)
iExists (State High (I ∖ {[ i ]})), (∅ : set token).
iSplit; [iPureIntro; by eauto using wait_step|].
iDestruct "Hr" as {Ψ} "[HΨ Hsp]".
iDestruct (big_sepS_delete _ _ i with "Hsp") as "[#HΨi Hsp]"; first done.
iAssert (▷ Ψ i ★ ▷ [★ set] j ∈ I ∖ {[i]}, Ψ j)%I with "[HΨ]" as "[HΨ HΨ']".
{ iNext. iApply (big_sepS_delete _ _ i); first done. by iApply "HΨ". }
iSplitL "HΨ' Hl Hsp"; [iNext|].
+ rewrite {2}/barrier_inv /=; iFrame "Hl".
iExists Ψ; iFrame. auto.
+ iPoseProof (saved_prop_agree i Q (Ψ i) with "[#]") as "Heq"; first by auto.
iIntros "_". wp_op=> ?; simplify_eq/=; wp_if.
iPvsIntro. iApply "HΦ". iApply "HQR". by iRewrite "Heq".
Qed.
Lemma recv_split E l P1 P2 :
nclose N ⊆ E → recv l (P1 ★ P2) ={E}=> recv l P1 ★ recv l P2.
Proof.
rename P1 into R1; rename P2 into R2. rewrite {1}/recv /barrier_ctx.
iIntros {?}. iDestruct 1 as {γ P Q i} "(#(%&Hh&Hsts)&Hγ&#HQ&HQR)".
iApply pvs_trans'.
iSts γ as [p I]; iDestruct "Hγ" as "[Hl Hr]".
iPvs (saved_prop_alloc_strong _ (R1: ∙%CF iProp) I) as {i1} "[% #Hi1]".
iPvs (saved_prop_alloc_strong _ (R2: ∙%CF iProp) (I ∪ {[i1]}))
as {i2} "[Hi2' #Hi2]"; iDestruct "Hi2'" as %Hi2; iPvsIntro.
rewrite ->not_elem_of_union, elem_of_singleton in Hi2; destruct Hi2.
iExists (State p ({[i1; i2]} ∪ I ∖ {[i]})).
iExists ({[Change i1; Change i2 ]}).
iSplit; [by eauto using split_step|iSplitL].
- iNext. rewrite {2}/barrier_inv /=. iFrame "Hl".
iApply (ress_split _ _ _ Q R1 R2); eauto. iFrame; auto.
- iIntros "Hγ".
iAssert (sts_ownS γ (i_states i1) {[Change i1]}
★ sts_ownS γ (i_states i2) {[Change i2]})%I with "|==>[-]" as "[Hγ1 Hγ2]".
{ iApply sts_ownS_op; eauto using i_states_closed, low_states_closed.
+ set_solver.
+ iApply (sts_own_weaken with "Hγ");
eauto using sts.closed_op, i_states_closed.
abstract set_solver. }
iPvsIntro; iSplitL "Hγ1"; rewrite /recv /barrier_ctx.
+ iExists γ, P, R1, i1. iFrame; auto.
+ iExists γ, P, R2, i2. iFrame; auto.
Qed.
Lemma recv_weaken l P1 P2 : (P1 -★ P2) ⊢ recv l P1 -★ recv l P2.
Proof.
rewrite /recv.
iIntros "HP HP1"; iDestruct "HP1" as {γ P Q i} "(#Hctx&Hγ&Hi&HP1)".
iExists γ, P, Q, i. iFrame "Hctx Hγ Hi".
iIntros "> HQ". by iApply "HP"; iApply "HP1".
Qed.
Lemma recv_mono l P1 P2 : (P1 ⊢ P2) → recv l P1 ⊢ recv l P2.
Proof.
intros HP%entails_wand. apply wand_entails. rewrite HP. apply recv_weaken.
Qed.
End proof.
Typeclasses Opaque barrier_ctx send recv.
heap_lang/lib/barrier/protocol.v deleted 100644 → 0
View file @ 2bc4df02
From iris.algebra Require Export sts.
From iris.program_logic Require Import ghost_ownership.
(** The STS describing the main barrier protocol. Every state has an index-set
associated with it. These indices are actually [gname], because we use them
with saved propositions. *)
Inductive phase := Low | High.
Record state := State { state_phase : phase; state_I : gset gname }.
Add Printing Constructor state.
Inductive token := Change (i : gname) | Send.
Global Instance stateT_inhabited: Inhabited state := populate (State Low ∅).
Global Instance Change_inj : Inj (=) (=) Change.
Proof. by injection 1. Qed.
Inductive prim_step : relation state :=
| ChangeI p I2 I1 : prim_step (State p I1) (State p I2)
| ChangePhase I : prim_step (State Low I) (State High I).
Definition tok (s : state) : set token :=
{[ t | ∃ i, t = Change i ∧ i ∉ state_I s ]} ∪
(if state_phase s is High then {[ Send ]} else ∅).
Global Arguments tok !_ /.
Canonical Structure sts := sts.STS prim_step tok.
(* The set of states containing some particular i *)
Definition i_states (i : gname) : set state := {[ s | i ∈ state_I s ]}.
(* The set of low states *)
Definition low_states : set state := {[ s | state_phase s = Low ]}.
Lemma i_states_closed i : sts.closed (i_states i) {[ Change i ]}.
Proof.
split; first (intros [[] I]; set_solver).
(* If we do the destruct of the states early, and then inversion
on the proof of a transition, it doesn't work - we do not obtain
the equalities we need. So we destruct the states late, because this
means we can use "destruct" instead of "inversion". *)
intros s1 s2 Hs1 [T1 T2 Hdisj Hstep'].
inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
destruct Htrans as [[] ??|]; done || set_solver.
Qed.
Lemma low_states_closed : sts.closed low_states {[ Send ]}.
Proof.
split; first (intros [??]; set_solver).
intros s1 s2 Hs1 [T1 T2 Hdisj Hstep'].
inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
destruct Htrans as [[] ??|]; done || set_solver.
Qed.
(* Proof that we can take the steps we need. *)
Lemma signal_step I : sts.steps (State Low I, {[Send]}) (State High I, ∅).
Proof. apply rtc_once. constructor; first constructor; set_solver. Qed.
Lemma wait_step i I :
i ∈ I →
sts.steps (State High I, {[ Change i ]}) (State High (I ∖ {[ i ]}), ∅).
Proof.
intros. apply rtc_once.
constructor; first constructor; [set_solver..|].
apply elem_of_equiv=>-[j|]; last set_solver.
destruct (decide (i = j)); set_solver.
Qed.
Lemma split_step p i i1 i2 I :
i ∈ I → i1 ∉ I → i2 ∉ I → i1 ≠ i2 →
sts.steps
(State p I, {[ Change i ]})
(State p ({[i1; i2]} ∪ I ∖ {[i]}), {[ Change i1; Change i2 ]}).
Proof.
intros. apply rtc_once. constructor; first constructor.
- destruct p; set_solver.
- destruct p; set_solver.
- apply elem_of_equiv=> /= -[j|]; last set_solver.
set_unfold; rewrite !(inj_iff Change).
assert (Change j ∈ match p with Low => ∅ | High => {[Send]} end ↔ False)
as -> by (destruct p; set_solver).
destruct (decide (i1 = j)) as [->|]; first naive_solver.
destruct (decide (i2 = j)) as [->|]; first naive_solver.
destruct (decide (i = j)) as [->|]; naive_solver.
Qed.
heap_lang/lib/barrier/specification.v deleted 100644 → 0
View file @ 2bc4df02
From iris.program_logic Require Export hoare.
From iris.heap_lang.lib.barrier Require Export barrier.
From iris.heap_lang.lib.barrier Require Import proof.
From iris.heap_lang Require Import proofmode.
Import uPred.
Section spec.
Context {Σ : gFunctors} `{!heapG Σ} `{!barrierG Σ}.
Local Notation iProp := (iPropG heap_lang Σ).
Lemma barrier_spec (heapN N : namespace) :
heapN ⊥ N →
∃ recv send : loc → iProp -n> iProp,
(∀ P, heap_ctx heapN ⊢ {{ True }} newbarrier #() {{ v,
∃ l : loc, v = #l ★ recv l P ★ send l P }}) ∧
(∀ l P, {{ send l P ★ P }} signal #l {{ _, True }}) ∧
(∀ l P, {{ recv l P }} wait #l {{ _, P }}) ∧
(∀ l P Q, recv l (P ★ Q) ={N}=> recv l P ★ recv l Q) ∧
(∀ l P Q, (P -★ Q) ⊢ recv l P -★ recv l Q).
Proof.
intros HN.
exists (λ l, CofeMor (recv heapN N l)), (λ l, CofeMor (send heapN N l)).
split_and?; simpl.
- iIntros {P} "#? ! _". iApply (newbarrier_spec _ _ P); eauto.
- iIntros {l P} "! [Hl HP]". by iApply signal_spec; iFrame "Hl HP".
- iIntros {l P} "! Hl". iApply wait_spec; iFrame "Hl"; eauto.
- intros; by apply recv_split.
- apply recv_weaken.
Qed.
End spec.
heap_lang/lib/lock.v deleted 100644 → 0
View file @ 2bc4df02
From iris.program_logic Require Export global_functor.
From iris.proofmode Require Import invariants ghost_ownership.
From iris.heap_lang Require Import proofmode notation.
Import uPred.
Definition newlock : val := λ: <>, ref #false.
Definition acquire : val :=
rec: "acquire" "l" :=
if: CAS '"l" #false #true then #() else '"acquire" '"l".
Definition release : val := λ: "l", '"l" <- #false.
Global Opaque newlock acquire release.
(** The CMRA we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class lockG Σ := LockG { lock_tokG :> inG heap_lang Σ (exclR unitC) }.
Definition lockGF : gFunctorList := [GFunctor (constRF (exclR unitC))].
Instance inGF_lockG `{H : inGFs heap_lang Σ lockGF} : lockG Σ.
Proof. destruct H. split. apply: inGF_inG. Qed.
Section proof.
Context {Σ : gFunctors} `{!heapG Σ, !lockG Σ}.
Context (heapN : namespace).
Local Notation iProp := (iPropG heap_lang Σ).
Definition lock_inv (γ : gname) (l : loc) (R : iProp) : iProp :=
(∃ b : bool, l ↦ #b ★ if b then True else own γ (Excl ()) ★ R)%I.
Definition is_lock (l : loc) (R : iProp) : iProp :=
(∃ N γ, heapN ⊥ N ∧ heap_ctx heapN ∧ inv N (lock_inv γ l R))%I.
Definition locked (l : loc) (R : iProp) : iProp :=
(∃ N γ, heapN ⊥ N ∧ heap_ctx heapN ∧
inv N (lock_inv γ l R) ∧ own γ (Excl ()))%I.
Global Instance lock_inv_ne n γ l : Proper (dist n ==> dist n) (lock_inv γ l).
Proof. solve_proper. Qed.
Global Instance is_lock_ne n l : Proper (dist n ==> dist n) (is_lock l).
Proof. solve_proper. Qed.
Global Instance locked_ne n l : Proper (dist n ==> dist n) (locked l).
Proof. solve_proper. Qed.
(** The main proofs. *)
Global Instance is_lock_persistent l R : PersistentP (is_lock l R).
Proof. apply _. Qed.
Lemma locked_is_lock l R : locked l R ⊢ is_lock l R.
Proof. rewrite /is_lock. iDestruct 1 as {N γ} "(?&?&?&_)"; eauto. Qed.
Lemma newlock_spec N (R : iProp) Φ :
heapN ⊥ N →
heap_ctx heapN ★ R ★ (∀ l, is_lock l R -★ Φ #l) ⊢ WP newlock #() {{ Φ }}.
Proof.
iIntros {?} "(#Hh & HR & HΦ)". rewrite /newlock.
wp_seq. wp_alloc l as "Hl".
iPvs (own_alloc (Excl ())) as {γ} "Hγ"; first done.
iPvs (inv_alloc N _ (lock_inv γ l R) with "[-HΦ]") as "#?"; first done.
{ iIntros ">". iExists false. by iFrame. }
iPvsIntro. iApply "HΦ". iExists N, γ; eauto.
Qed.
Lemma acquire_spec l R (Φ : val → iProp) :
is_lock l R ★ (locked l R -★ R -★ Φ #()) ⊢ WP acquire #l {{ Φ }}.
Proof.
iIntros "[Hl HΦ]". iDestruct "Hl" as {N γ} "(%&#?&#?)".
iLöb as "IH". wp_rec. wp_focus (CAS _ _ _)%E.
iInv N as { [] } "[Hl HR]".
- wp_cas_fail. iPvsIntro; iSplitL "Hl".
+ iNext. iExists true; eauto.
+ wp_if. by iApply "IH".
- wp_cas_suc. iPvsIntro. iDestruct "HR" as "[Hγ HR]". iSplitL "Hl".
+ iNext. iExists true; eauto.
+ wp_if. iApply ("HΦ" with "[-HR] HR"). iExists N, γ; eauto.
Qed.
Lemma release_spec R l (Φ : val → iProp) :
locked l R ★ R ★ Φ #() ⊢ WP release #l {{ Φ }}.
Proof.
iIntros "(Hl&HR&HΦ)"; iDestruct "Hl" as {N γ} "(% & #? & #? & Hγ)".
rewrite /release. wp_let. iInv N as {b} "[Hl _]".
wp_store. iPvsIntro. iFrame "HΦ". iNext. iExists false. by iFrame.
Qed.
End proof.
heap_lang/lib/par.v deleted 100644 → 0
View file @ 2bc4df02
From iris.heap_lang Require Export spawn.
From iris.heap_lang Require Import proofmode notation.
Import uPred.
Definition par {X} : expr X :=
λ: "fs",
let: "handle" := ^spawn (Fst '"fs") in
let: "v2" := Snd '"fs" #() in
let: "v1" := ^join '"handle" in
Pair '"v1" '"v2".
Notation Par e1 e2 := (par (Pair (λ: <>, e1) (λ: <>, e2)))%E.
Infix "||" := Par : expr_scope.
Instance do_wexpr_par {X Y} (H : X `included` Y) : WExpr H par par := _.
Instance do_wsubst_par {X Y} x es (H : X `included` x :: Y) :
WSubst x es H par par := do_wsubst_closed _ x es H _.
Global Opaque par.
Section proof.
Context {Σ : gFunctors} `{!heapG Σ, !spawnG Σ}.
Context (heapN N : namespace).
Local Notation iProp := (iPropG heap_lang Σ).
Lemma par_spec (Ψ1 Ψ2 : val → iProp) e (f1 f2 : val) (Φ : val → iProp) :
heapN ⊥ N → to_val e = Some (f1,f2)%V →
(heap_ctx heapN ★ WP f1 #() {{ Ψ1 }} ★ WP f2 #() {{ Ψ2 }} ★
∀ v1 v2, Ψ1 v1 ★ Ψ2 v2 -★ ▷ Φ (v1,v2)%V)
⊢ WP par e {{ Φ }}.
Proof.
iIntros {??} "(#Hh&Hf1&Hf2&HΦ)".
rewrite /par. wp_value. iPvsIntro. wp_let. wp_proj.
wp_apply spawn_spec; try wp_done. iFrame "Hf1 Hh".
iIntros {l} "Hl". wp_let. wp_proj. wp_focus (f2 _).
iApply wp_wand_l; iFrame "Hf2"; iIntros {v} "H2". wp_let.
wp_apply join_spec; iFrame "Hl". iIntros {w} "H1".
iSpecialize ("HΦ" with "* [-]"); first by iSplitL "H1". by wp_let.
Qed.
Lemma wp_par (Ψ1 Ψ2 : val → iProp) (e1 e2 : expr []) (Φ : val → iProp) :
heapN ⊥ N →
(heap_ctx heapN ★ WP e1 {{ Ψ1 }} ★ WP e2 {{ Ψ2 }} ★
∀ v1 v2, Ψ1 v1 ★ Ψ2 v2 -★ ▷ Φ (v1,v2)%V)
⊢ WP e1 || e2 {{ Φ }}.
Proof.
iIntros {?} "(#Hh&H1&H2&H)". iApply (par_spec Ψ1 Ψ2); auto.
iFrame "Hh H". iSplitL "H1"; by wp_let.
Qed.
End proof.
heap_lang/lib/spawn.v deleted 100644 → 0
View file @ 2bc4df02
From iris.program_logic Require Export global_functor.
From iris.proofmode Require Import invariants ghost_ownership.
From iris.heap_lang Require Import proofmode notation.
Import uPred.
Definition spawn : val :=
λ: "f",
let: "c" := ref (InjL #0) in
Fork ('"c" <- InjR ('"f" #())) ;; '"c".
Definition join : val :=
rec: "join" "c" :=
match: !'"c" with
InjR "x" => '"x"
| InjL <> => '"join" '"c"
end.
Global Opaque spawn join.
(** The CMRA we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class spawnG Σ := SpawnG {
spawn_tokG :> inG heap_lang Σ (exclR unitC);
}.
(** The functor we need. *)
Definition spawnGF : gFunctorList := [GFunctor (constRF (exclR unitC))].
(* Show and register that they match. *)
Instance inGF_spawnG `{H : inGFs heap_lang Σ spawnGF} : spawnG Σ.
Proof. destruct H as (?&?). split. apply: inGF_inG. Qed.
(** Now we come to the Iris part of the proof. *)
Section proof.
Context {Σ : gFunctors} `{!heapG Σ, !spawnG Σ}.
Context (heapN N : namespace).
Local Notation iProp := (iPropG heap_lang Σ).
Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp) : iProp :=
(∃ lv, l ↦ lv ★ (lv = InjLV #0 ∨
∃ v, lv = InjRV v ★ (Ψ v ∨ own γ (Excl ()))))%I.
Definition join_handle (l : loc) (Ψ : val → iProp) : iProp :=
(heapN ⊥ N ★ ∃ γ, heap_ctx heapN ★ own γ (Excl ()) ★
inv N (spawn_inv γ l Ψ))%I.
Typeclasses Opaque join_handle.
Global Instance spawn_inv_ne n γ l :
Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
Proof. solve_proper. Qed.
Global Instance join_handle_ne n l :
Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
Proof. solve_proper. Qed.
(** The main proofs. *)
Lemma spawn_spec (Ψ : val → iProp) e (f : val) (Φ : val → iProp) :
to_val e = Some f →
heapN ⊥ N →
heap_ctx heapN ★ WP f #() {{ Ψ }} ★ (∀ l, join_handle l Ψ -★ Φ #l)
⊢ WP spawn e {{ Φ }}.
Proof.
iIntros {<-%of_to_val ?} "(#Hh&Hf&HΦ)". rewrite /spawn.
wp_let. wp_alloc l as "Hl". wp_let.
iPvs (own_alloc (Excl ())) as {γ} "Hγ"; first done.
iPvs (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?"; first done.
{ iNext. iExists (InjLV #0). iFrame; eauto. }
wp_apply wp_fork. iSplitR "Hf".
- iPvsIntro. wp_seq. iPvsIntro. iApply "HΦ"; rewrite /join_handle. eauto.
- wp_focus (f _). iApply wp_wand_l; iFrame "Hf"; iIntros {v} "Hv".
iInv N as {v'} "[Hl _]"; first wp_done.
wp_store. iPvsIntro; iSplit; [iNext|done].
iExists (InjRV v); iFrame; eauto.
Qed.
Lemma join_spec (Ψ : val → iProp) l (Φ : val → iProp) :
join_handle l Ψ ★ (∀ v, Ψ v -★ Φ v) ⊢ WP join #l {{ Φ }}.
Proof.
rewrite /join_handle; iIntros "[[% H] Hv]"; iDestruct "H" as {γ} "(#?&Hγ&#?)".
iLöb as "IH". wp_rec. wp_focus (! _)%E. iInv N as {v} "[Hl Hinv]".
wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
- iPvsIntro; iSplitL "Hl"; [iNext; iExists _; iFrame; eauto|].
wp_match. iApply ("IH" with "Hγ Hv").
- iDestruct "Hinv" as {v'} "[% [HΨ|Hγ']]"; simplify_eq/=.
+ iPvsIntro; iSplitL "Hl Hγ".
{ iNext. iExists _; iFrame; eauto. }
wp_match. by iApply "Hv".
+ iCombine "Hγ" "Hγ'" as "Hγ". iDestruct (own_valid with "Hγ") as %[].
Qed.
End proof.
Typeclasses Opaque join_handle.
heap_lang/lifting.v deleted 100644 → 0
View file @ 2bc4df02
From iris.program_logic Require Export weakestpre.
From iris.program_logic Require Import ownership ectx_lifting. (* for ownP *)
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import tactics.
From iris.proofmode Require Import weakestpre.
Import uPred.
Local Hint Extern 0 (head_reducible _ _) => do_head_step eauto 2.
Section lifting.
Context {Σ : iFunctor}.
Implicit Types P Q : iProp heap_lang Σ.
Implicit Types Φ : val → iProp heap_lang Σ.
Implicit Types ef : option (expr []).
(** Bind. This bundles some arguments that wp_ectx_bind leaves as indices. *)
Lemma wp_bind {E e} K Φ :
WP e @ E {{ v, WP fill K (of_val v) @ E {{ Φ }} }} ⊢ WP fill K e @ E {{ Φ }}.
Proof. exact: wp_ectx_bind. Qed.
Lemma wp_bindi {E e} Ki Φ :
WP e @ E {{ v, WP fill_item Ki (of_val v) @ E {{ Φ }} }} ⊢
WP fill_item Ki e @ E {{ Φ }}.
Proof. exact: weakestpre.wp_bind. Qed.
(** Base axioms for core primitives of the language: Stateful reductions. *)
Lemma wp_alloc_pst E σ e v Φ :
to_val e = Some v →
▷ ownP σ ★ ▷ (∀ l, σ !! l = None ∧ ownP (<[l:=v]>σ) ={E}=★ Φ (LitV (LitLoc l)))
⊢ WP Alloc e @ E {{ Φ }}.
Proof.
iIntros {?} "[HP HΦ]".
(* TODO: This works around ssreflect bug #22. *)
set (φ (e' : expr []) σ' ef := ∃ l,
ef = None ∧ e' = Lit (LitLoc l) ∧ σ' = <[l:=v]>σ ∧ σ !! l = None).
iApply (wp_lift_atomic_head_step (Alloc e) φ σ); try (by simpl; eauto);
[by intros; subst φ; inv_head_step; eauto 8|].
iFrame "HP". iNext. iIntros {v2 σ2 ef} "[Hφ HP]".
iDestruct "Hφ" as %(l & -> & [= <-]%of_to_val_flip & -> & ?); simpl.
iSplit; last done. iApply "HΦ"; by iSplit.
Qed.
Lemma wp_load_pst E σ l v Φ :
σ !! l = Some v →
▷ ownP σ ★ ▷ (ownP σ ={E}=★ Φ v) ⊢ WP Load (Lit (LitLoc l)) @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_atomic_det_head_step σ v σ None) ?right_id //;
last (by intros; inv_head_step; eauto using to_of_val); simpl; by eauto.
Qed.
Lemma wp_store_pst E σ l e v v' Φ :
to_val e = Some v → σ !! l = Some v' →
▷ ownP σ ★ ▷ (ownP (<[l:=v]>σ) ={E}=★ Φ (LitV LitUnit))
⊢ WP Store (Lit (LitLoc l)) e @ E {{ Φ }}.
Proof.
intros. rewrite-(wp_lift_atomic_det_head_step σ (LitV LitUnit) (<[l:=v]>σ) None)
?right_id //; last (by intros; inv_head_step; eauto); simpl; by eauto.
Qed.
Lemma wp_cas_fail_pst E σ l e1 v1 e2 v2 v' Φ :
to_val e1 = Some v1 → to_val e2 = Some v2 → σ !! l = Some v' → v' ≠ v1 →
▷ ownP σ ★ ▷ (ownP σ ={E}=★ Φ (LitV $ LitBool false))
⊢ WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_atomic_det_head_step σ (LitV $ LitBool false) σ None)
?right_id //; last (by intros; inv_head_step; eauto);
simpl; by eauto 10.
Qed.
Lemma wp_cas_suc_pst E σ l e1 v1 e2 v2 Φ :
to_val e1 = Some v1 → to_val e2 = Some v2 → σ !! l = Some v1 →
▷ ownP σ ★ ▷ (ownP (<[l:=v2]>σ) ={E}=★ Φ (LitV $ LitBool true))
⊢ WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_atomic_det_head_step σ (LitV $ LitBool true)
(<[l:=v2]>σ) None) ?right_id //; last (by intros; inv_head_step; eauto);
simpl; by eauto 10.
Qed.
(** Base axioms for core primitives of the language: Stateless reductions *)
Lemma wp_fork E e Φ :
▷ (|={E}=> Φ (LitV LitUnit)) ★ ▷ WP e {{ _, True }} ⊢ WP Fork e @ E {{ Φ }}.
Proof.
rewrite -(wp_lift_pure_det_head_step (Fork e) (Lit LitUnit) (Some e)) //=;
last by intros; inv_head_step; eauto.
rewrite later_sep -(wp_value_pvs _ _ (Lit _)) //.
Qed.
Lemma wp_rec E f x erec e1 e2 v2 Φ :
e1 = Rec f x erec →
to_val e2 = Some v2 →
▷ WP subst' x e2 (subst' f e1 erec) @ E {{ Φ }} ⊢ WP App e1 e2 @ E {{ Φ }}.
Proof.
intros -> ?. rewrite -(wp_lift_pure_det_head_step (App _ _)
(subst' x e2 (subst' f (Rec f x erec) erec)) None) //= ?right_id;
intros; inv_head_step; eauto.
Qed.
Lemma wp_un_op E op l l' Φ :
un_op_eval op l = Some l' →
▷ (|={E}=> Φ (LitV l')) ⊢ WP UnOp op (Lit l) @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step (UnOp op _) (Lit l') None)
?right_id -?wp_value_pvs //; intros; inv_head_step; eauto.
Qed.
Lemma wp_bin_op E op l1 l2 l' Φ :
bin_op_eval op l1 l2 = Some l' →
▷ (|={E}=> Φ (LitV l')) ⊢ WP BinOp op (Lit l1) (Lit l2) @ E {{ Φ }}.
Proof.
intros Heval. rewrite -(wp_lift_pure_det_head_step (BinOp op _ _) (Lit l') None)
?right_id -?wp_value_pvs //; intros; inv_head_step; eauto.
Qed.
Lemma wp_if_true E e1 e2 Φ :
▷ WP e1 @ E {{ Φ }} ⊢ WP If (Lit (LitBool true)) e1 e2 @ E {{ Φ }}.
Proof.
rewrite -(wp_lift_pure_det_head_step (If _ _ _) e1 None)
?right_id //; intros; inv_head_step; eauto.
Qed.
Lemma wp_if_false E e1 e2 Φ :
▷ WP e2 @ E {{ Φ }} ⊢ WP If (Lit (LitBool false)) e1 e2 @ E {{ Φ }}.
Proof.
rewrite -(wp_lift_pure_det_head_step (If _ _ _) e2 None)
?right_id //; intros; inv_head_step; eauto.
Qed.
Lemma wp_fst E e1 v1 e2 v2 Φ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
▷ (|={E}=> Φ v1) ⊢ WP Fst (Pair e1 e2) @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step (Fst _) e1 None)
?right_id -?wp_value_pvs //; intros; inv_head_step; eauto.
Qed.
Lemma wp_snd E e1 v1 e2 v2 Φ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
▷ (|={E}=> Φ v2) ⊢ WP Snd (Pair e1 e2) @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step (Snd _) e2 None)
?right_id -?wp_value_pvs //; intros; inv_head_step; eauto.
Qed.
Lemma wp_case_inl E e0 v0 e1 e2 Φ :
to_val e0 = Some v0 →
▷ WP App e1 e0 @ E {{ Φ }} ⊢ WP Case (InjL e0) e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step (Case _ _ _)
(App e1 e0) None) ?right_id //; intros; inv_head_step; eauto.
Qed.
Lemma wp_case_inr E e0 v0 e1 e2 Φ :
to_val e0 = Some v0 →
▷ WP App e2 e0 @ E {{ Φ }} ⊢ WP Case (InjR e0) e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step (Case _ _ _)
(App e2 e0) None) ?right_id //; intros; inv_head_step; eauto.
Qed.
End lifting.
heap_lang/notation.v deleted 100644 → 0
View file @ 2bc4df02
From iris.heap_lang Require Export derived.
Export heap_lang.
Arguments wp {_ _} _ _%E _.
Notation "'WP' e @ E {{ Φ } }" := (wp E e%E Φ)
(at level 20, e, Φ at level 200,
format "'WP' e @ E {{ Φ } }") : uPred_scope.
Notation "'WP' e {{ Φ } }" := (wp ⊤ e%E Φ)
(at level 20, e, Φ at level 200,
format "'WP' e {{ Φ } }") : uPred_scope.
Notation "'WP' e @ E {{ v , Q } }" := (wp E e%E (λ v, Q))
(at level 20, e, Q at level 200,
format "'WP' e @ E {{ v , Q } }") : uPred_scope.
Notation "'WP' e {{ v , Q } }" := (wp ⊤ e%E (λ v, Q))
(at level 20, e, Q at level 200,
format "'WP' e {{ v , Q } }") : uPred_scope.
Coercion LitInt : Z >-> base_lit.
Coercion LitBool : bool >-> base_lit.
Coercion LitLoc : loc >-> base_lit.
Coercion App : expr >-> Funclass.
Coercion of_val : val >-> expr.
Coercion BNamed : string >-> binder.
Notation "<>" := BAnon : binder_scope.
(* No scope for the values, does not conflict and scope is often not inferred
properly. *)
Notation "# l" := (LitV l%Z%V) (at level 8, format "# l").
Notation "# l" := (Lit l%Z%V) (at level 8, format "# l") : expr_scope.
Notation "' x" := (Var x) (at level 8, format "' x") : expr_scope.
Notation "^ e" := (wexpr' e) (at level 8, format "^ e") : expr_scope.
(** Syntax inspired by Coq/Ocaml. Constructions with higher precedence come
first. *)
Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_scope.
Notation "( e1 , e2 , .. , en )" := (PairV .. (PairV e1 e2) .. en) : val_scope.
Notation "'match:' e0 'with' 'InjL' x1 => e1 | 'InjR' x2 => e2 'end'" :=
(Match e0 x1%bind e1 x2%bind e2)
(e0, x1, e1, x2, e2 at level 200) : expr_scope.
Notation "'match:' e0 'with' 'InjR' x1 => e1 | 'InjL' x2 => e2 'end'" :=
(Match e0 x2%bind e2 x1%bind e1)
(e0, x1, e1, x2, e2 at level 200, only parsing) : expr_scope.
Notation "()" := LitUnit : val_scope.
Notation "! e" := (Load e%E) (at level 9, right associativity) : expr_scope.
Notation "'ref' e" := (Alloc e%E)
(at level 30, right associativity) : expr_scope.
Notation "- e" := (UnOp MinusUnOp e%E)
(at level 35, right associativity) : expr_scope.
Notation "e1 + e2" := (BinOp PlusOp e1%E e2%E)
(at level 50, left associativity) : expr_scope.
Notation "e1 - e2" := (BinOp MinusOp e1%E e2%E)
(at level 50, left associativity) : expr_scope.
Notation "e1 ≤ e2" := (BinOp LeOp e1%E e2%E) (at level 70) : expr_scope.
Notation "e1 < e2" := (BinOp LtOp e1%E e2%E) (at level 70) : expr_scope.
Notation "e1 = e2" := (BinOp EqOp e1%E e2%E) (at level 70) : expr_scope.
Notation "~ e" := (UnOp NegOp e%E) (at level 75, right associativity) : expr_scope.
(* The unicode ← is already part of the notation "_ ← _; _" for bind. *)
Notation "e1 <- e2" := (Store e1%E e2%E) (at level 80) : expr_scope.
Notation "'rec:' f x := e" := (Rec f%bind x%bind e%E)
(at level 102, f at level 1, x at level 1, e at level 200) : expr_scope.
Notation "'rec:' f x := e" := (RecV f%bind x%bind e%E)
(at level 102, f at level 1, x at level 1, e at level 200) : val_scope.
Notation "'if:' e1 'then' e2 'else' e3" := (If e1%E e2%E e3%E)
(at level 200, e1, e2, e3 at level 200) : expr_scope.
(** Derived notions, in order of declaration. The notations for let and seq
are stated explicitly instead of relying on the Notations Let and Seq as
defined above. This is needed because App is now a coercion, and these
notations are otherwise not pretty printed back accordingly. *)
Notation "'rec:' f x y := e" := (Rec f%bind x%bind (Lam y%bind e%E))
(at level 102, f, x, y at level 1, e at level 200) : expr_scope.
Notation "'rec:' f x y := e" := (RecV f%bind x%bind (Lam y%bind e%E))
(at level 102, f, x, y at level 1, e at level 200) : val_scope.
Notation "'rec:' f x y .. z := e" := (Rec f%bind x%bind (Lam y%bind .. (Lam z%bind e%E) ..))
(at level 102, f, x, y, z at level 1, e at level 200) : expr_scope.
Notation "'rec:' f x y .. z := e" := (RecV f%bind x%bind (Lam y%bind .. (Lam z%bind e%E) ..))
(at level 102, f, x, y, z at level 1, e at level 200) : val_scope.
Notation "λ: x , e" := (Lam x%bind e%E)
(at level 102, x at level 1, e at level 200) : expr_scope.
Notation "λ: x y .. z , e" := (Lam x%bind (Lam y%bind .. (Lam z%bind e%E) ..))
(at level 102, x, y, z at level 1, e at level 200) : expr_scope.
Notation "λ: x , e" := (LamV x%bind e%E)
(at level 102, x at level 1, e at level 200) : val_scope.
Notation "λ: x y .. z , e" := (LamV x%bind (Lam y%bind .. (Lam z%bind e%E) .. ))
(at level 102, x, y, z at level 1, e at level 200) : val_scope.
Notation "'let:' x := e1 'in' e2" := (Lam x%bind e2%E e1%E)
(at level 102, x at level 1, e1, e2 at level 200) : expr_scope.
Notation "e1 ;; e2" := (Lam BAnon e2%E e1%E)
(at level 100, e2 at level 200, format "e1 ;; e2") : expr_scope.
(* These are not actually values, but we want them to be pretty-printed. *)
Notation "'let:' x := e1 'in' e2" := (LamV x%bind e2%E e1%E)
(at level 102, x at level 1, e1, e2 at level 200) : val_scope.
Notation "e1 ;; e2" := (LamV BAnon e2%E e1%E)
(at level 100, e2 at level 200, format "e1 ;; e2") : val_scope.
(** Notations for option *)
Notation NONE := (InjL #()).
Notation SOME x := (InjR x).
Notation NONEV := (InjLV #()).
Notation SOMEV x := (InjRV x).
Notation "'match:' e0 'with' 'NONE' => e1 | 'SOME' x => e2 'end'" :=
(Match e0 BAnon e1 x%bind e2)
(e0, e1, x, e2 at level 200) : expr_scope.
Notation "'match:' e0 'with' 'SOME' x => e2 | 'NONE' => e1 | 'end'" :=
(Match e0 BAnon e1 x%bind e2)
(e0, e1, x, e2 at level 200, only parsing) : expr_scope.
heap_lang/proofmode.v deleted 100644 → 0
View file @ 2bc4df02
From iris.proofmode Require Import coq_tactics.
From iris.proofmode Require Export weakestpre.
From iris.heap_lang Require Export wp_tactics heap.
Import uPred.
Ltac wp_strip_later ::= iNext.
Section heap.
Context {Σ : gFunctors} `{heapG Σ}.
Implicit Types N : namespace.
Implicit Types P Q : iPropG heap_lang Σ.
Implicit Types Φ : val → iPropG heap_lang Σ.
Implicit Types Δ : envs (iResUR heap_lang (globalF Σ)).
Global Instance into_sep_mapsto l q v :
IntoSep false (l ↦{q} v) (l ↦{q/2} v) (l ↦{q/2} v).
Proof. by rewrite /IntoSep heap_mapsto_op_split. Qed.
Lemma tac_wp_alloc Δ Δ' N E j e v Φ :
to_val e = Some v →
(Δ ⊢ heap_ctx N) → nclose N ⊆ E →
IntoLaterEnvs Δ Δ' →
(∀ l, ∃ Δ'',
envs_app false (Esnoc Enil j (l ↦ v)) Δ' = Some Δ'' ∧
(Δ'' ⊢ |={E}=> Φ (LitV (LitLoc l)))) →
Δ ⊢ WP Alloc e @ E {{ Φ }}.
Proof.
intros ???? HΔ. rewrite -wp_alloc // -always_and_sep_l.
apply and_intro; first done.
rewrite into_later_env_sound; apply later_mono, forall_intro=> l.
destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
by rewrite right_id HΔ'.
Qed.
Lemma tac_wp_load Δ Δ' N E i l q v Φ :
(Δ ⊢ heap_ctx N) → nclose N ⊆ E →
IntoLaterEnvs Δ Δ' →
envs_lookup i Δ' = Some (false, l ↦{q} v)%I →
(Δ' ⊢ |={E}=> Φ v) →
Δ ⊢ WP Load (Lit (LitLoc l)) @ E {{ Φ }}.
Proof.
intros. rewrite -wp_load // -always_and_sep_l. apply and_intro; first done.
rewrite into_later_env_sound -later_sep envs_lookup_split //; simpl.
by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_store Δ Δ' Δ'' N E i l v e v' Φ :
to_val e = Some v' →
(Δ ⊢ heap_ctx N) → nclose N ⊆ E →
IntoLaterEnvs Δ Δ' →
envs_lookup i Δ' = Some (false, l ↦ v)%I →
envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ' = Some Δ'' →
(Δ'' ⊢ |={E}=> Φ (LitV LitUnit)) →
Δ ⊢ WP Store (Lit (LitLoc l)) e @ E {{ Φ }}.
Proof.
intros. rewrite -wp_store // -always_and_sep_l. apply and_intro; first done.
rewrite into_later_env_sound -later_sep envs_simple_replace_sound //; simpl.
rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_cas_fail Δ Δ' N E i l q v e1 v1 e2 v2 Φ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
(Δ ⊢ heap_ctx N) → nclose N ⊆ E →
IntoLaterEnvs Δ Δ' →
envs_lookup i Δ' = Some (false, l ↦{q} v)%I → v ≠ v1 →
(Δ' ⊢ |={E}=> Φ (LitV (LitBool false))) →
Δ ⊢ WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -wp_cas_fail // -always_and_sep_l. apply and_intro; first done.
rewrite into_later_env_sound -later_sep envs_lookup_split //; simpl.
by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_cas_suc Δ Δ' Δ'' N E i l v e1 v1 e2 v2 Φ :
to_val e1 = Some v1 → to_val e2 = Some v2 →
(Δ ⊢ heap_ctx N) → nclose N ⊆ E →
IntoLaterEnvs Δ Δ' →
envs_lookup i Δ' = Some (false, l ↦ v)%I → v = v1 →
envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' = Some Δ'' →
(Δ'' ⊢ |={E}=> Φ (LitV (LitBool true))) →
Δ ⊢ WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof.
intros; subst.
rewrite -wp_cas_suc // -always_and_sep_l. apply and_intro; first done.
rewrite into_later_env_sound -later_sep envs_simple_replace_sound //; simpl.
rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
End heap.
Tactic Notation "wp_apply" open_constr(lem) :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
wp_bind K; iApply lem; try iNext)
| _ => fail "wp_apply: not a 'wp'"
end.
Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q =>
first
[reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with Alloc _ => wp_bind K end)
|fail 1 "wp_alloc: cannot find 'Alloc' in" e];
eapply tac_wp_alloc with _ _ H _;
[let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_alloc:" e' "not a value"
|iAssumption || fail "wp_alloc: cannot find heap_ctx"
|solve_ndisj
|apply _
|first [intros l | fail 1 "wp_alloc:" l "not fresh"];
eexists; split;
[env_cbv; reflexivity || fail "wp_alloc:" H "not fresh"
|wp_finish]]
| _ => fail "wp_alloc: not a 'wp'"
end.
Tactic Notation "wp_alloc" ident(l) :=
let H := iFresh in wp_alloc l as H.
Tactic Notation "wp_load" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q =>
first
[reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with Load _ => wp_bind K end)
|fail 1 "wp_load: cannot find 'Load' in" e];
eapply tac_wp_load;
[iAssumption || fail "wp_load: cannot find heap_ctx"
|solve_ndisj
|apply _
|let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
iAssumptionCore || fail "wp_cas_fail: cannot find" l "↦ ?"
|wp_finish]
| _ => fail "wp_load: not a 'wp'"
end.
Tactic Notation "wp_store" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q =>
first
[reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with Store _ _ => wp_bind K end)
|fail 1 "wp_store: cannot find 'Store' in" e];
eapply tac_wp_store;
[let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_store:" e' "not a value"
|iAssumption || fail "wp_store: cannot find heap_ctx"
|solve_ndisj
|apply _
|let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
iAssumptionCore || fail "wp_store: cannot find" l "↦ ?"
|env_cbv; reflexivity
|wp_finish]
| _ => fail "wp_store: not a 'wp'"
end.
Tactic Notation "wp_cas_fail" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q =>
first
[reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with CAS _ _ _ => wp_bind K end)
|fail 1 "wp_cas_fail: cannot find 'CAS' in" e];
eapply tac_wp_cas_fail;
[let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_cas_fail:" e' "not a value"
|let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_cas_fail:" e' "not a value"
|iAssumption || fail "wp_cas_fail: cannot find heap_ctx"
|solve_ndisj
|apply _
|let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
iAssumptionCore || fail "wp_cas_fail: cannot find" l "↦ ?"
|try congruence
|wp_finish]
| _ => fail "wp_cas_fail: not a 'wp'"
end.
Tactic Notation "wp_cas_suc" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q =>
first
[reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with CAS _ _ _ => wp_bind K end)
|fail 1 "wp_cas_suc: cannot find 'CAS' in" e];
eapply tac_wp_cas_suc;
[let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_cas_suc:" e' "not a value"
|let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_cas_suc:" e' "not a value"
|iAssumption || fail "wp_cas_suc: cannot find heap_ctx"
|solve_ndisj
|apply _
|let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
iAssumptionCore || fail "wp_cas_suc: cannot find" l "↦ ?"
|try congruence
|env_cbv; reflexivity
|wp_finish]
| _ => fail "wp_cas_suc: not a 'wp'"
end.
heap_lang/substitution.v deleted 100644 → 0
View file @ 2bc4df02
From iris.heap_lang Require Export lang.
Import heap_lang.
(** The tactic [simpl_subst] performs substitutions in the goal. Its behavior
can be tuned by declaring [WExpr] and [WSubst] instances. *)
(** * Weakening *)
Class WExpr {X Y} (H : X `included` Y) (e : expr X) (er : expr Y) :=
do_wexpr : wexpr H e = er.
Hint Mode WExpr + + + + - : typeclass_instances.
(* Variables *)
Hint Extern 0 (WExpr _ (Var ?y) _) =>
apply var_proof_irrel : typeclass_instances.
(* Rec *)
Instance do_wexpr_rec_true {X Y f y e} {H : X `included` Y} er :
WExpr (wexpr_rec_prf H) e er → WExpr H (Rec f y e) (Rec f y er) | 10.
Proof. intros; red; f_equal/=. by etrans; [apply wexpr_proof_irrel|]. Qed.
(* Values *)
Instance do_wexpr_wexpr X Y Z (H1 : X `included` Y) (H2 : Y `included` Z) e er :
WExpr (transitivity H1 H2) e er → WExpr H2 (wexpr H1 e) er | 0.
Proof. by rewrite /WExpr wexpr_wexpr'. Qed.
Instance do_wexpr_closed_closed (H : [] `included` []) e : WExpr H e e | 1.
Proof. apply wexpr_id. Qed.
Instance do_wexpr_closed_wexpr Y (H : [] `included` Y) e :
WExpr H e (wexpr' e) | 2.
Proof. apply wexpr_proof_irrel. Qed.
(* Boring connectives *)
Section do_wexpr.
Context {X Y : list string} (H : X `included` Y).
Notation W := (WExpr H).
(* Ground terms *)
Global Instance do_wexpr_lit l : W (Lit l) (Lit l).
Proof. done. Qed.
Global Instance do_wexpr_app e1 e2 e1r e2r :
W e1 e1r → W e2 e2r → W (App e1 e2) (App e1r e2r).
Proof. intros; red; f_equal/=; apply: do_wexpr. Qed.
Global Instance do_wexpr_unop op e er : W e er → W (UnOp op e) (UnOp op er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_binop op e1 e2 e1r e2r :
W e1 e1r → W e2 e2r → W (BinOp op e1 e2) (BinOp op e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_if e0 e1 e2 e0r e1r e2r :
W e0 e0r → W e1 e1r → W e2 e2r → W (If e0 e1 e2) (If e0r e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_pair e1 e2 e1r e2r :
W e1 e1r → W e2 e2r → W (Pair e1 e2) (Pair e1r e2r).
Proof. by intros ??; red; f_equal/=. Qed.
Global Instance do_wexpr_fst e er : W e er → W (Fst e) (Fst er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_snd e er : W e er → W (Snd e) (Snd er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_injL e er : W e er → W (InjL e) (InjL er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_injR e er : W e er → W (InjR e) (InjR er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_case e0 e1 e2 e0r e1r e2r :
W e0 e0r → W e1 e1r → W e2 e2r → W (Case e0 e1 e2) (Case e0r e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_fork e er : W e er → W (Fork e) (Fork er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_alloc e er : W e er → W (Alloc e) (Alloc er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_load e er : W e er → W (Load e) (Load er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_store e1 e2 e1r e2r :
W e1 e1r → W e2 e2r → W (Store e1 e2) (Store e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wexpr_cas e0 e1 e2 e0r e1r e2r :
W e0 e0r → W e1 e1r → W e2 e2r → W (CAS e0 e1 e2) (CAS e0r e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
End do_wexpr.
(** * WSubstitution *)
Class WSubst {X Y} (x : string) (es : expr []) H (e : expr X) (er : expr Y) :=
do_wsubst : wsubst x es H e = er.
Hint Mode WSubst + + + + + + - : typeclass_instances.
Lemma do_wsubst_closed (e: ∀ {X}, expr X) {X Y} x es (H : X `included` x :: Y) :
(∀ X, WExpr (included_nil X) e e) → WSubst x es H e e.
Proof.
rewrite /WSubst /WExpr=> He. rewrite -(He X) wsubst_wexpr'.
by rewrite (wsubst_closed _ _ _ _ _ (included_nil _)); last set_solver.
Qed.
(* Variables *)
Lemma do_wsubst_var_eq {X Y x es} {H : X `included` x :: Y} `{VarBound x X} er :
WExpr (included_nil _) es er → WSubst x es H (Var x) er.
Proof.
intros; red; simpl. case_decide; last done.
by etrans; [apply wexpr_proof_irrel|].
Qed.
Hint Extern 0 (WSubst ?x ?v _ (Var ?y) _) => first
[ apply var_proof_irrel
| apply do_wsubst_var_eq ] : typeclass_instances.
(** Rec *)
Lemma do_wsubst_rec_true {X Y x es f y e} {H : X `included` x :: Y}
(Hfy : BNamed x ≠ f ∧ BNamed x ≠ y) er :
WSubst x es (wsubst_rec_true_prf H Hfy) e er →
WSubst x es H (Rec f y e) (Rec f y er).
Proof.
intros ?; red; f_equal/=; case_decide; last done.
by etrans; [apply wsubst_proof_irrel|].
Qed.
Lemma do_wsubst_rec_false {X Y x es f y e} {H : X `included` x :: Y}
(Hfy : ¬(BNamed x ≠ f ∧ BNamed x ≠ y)) er :
WExpr (wsubst_rec_false_prf H Hfy) e er →
WSubst x es H (Rec f y e) (Rec f y er).
Proof.
intros; red; f_equal/=; case_decide; first done.
by etrans; [apply wexpr_proof_irrel|].
Qed.
Ltac bool_decide_no_check := apply (bool_decide_unpack _); vm_cast_no_check I.
Hint Extern 0 (WSubst ?x ?v _ (Rec ?f ?y ?e) _) =>
match eval vm_compute in (bool_decide (BNamed x ≠ f ∧ BNamed x ≠ y)) with
| true => eapply (do_wsubst_rec_true ltac:(bool_decide_no_check))
| false => eapply (do_wsubst_rec_false ltac:(bool_decide_no_check))
end : typeclass_instances.
(* Values *)
Instance do_wsubst_wexpr X Y Z x es
(H1 : X `included` Y) (H2 : Y `included` x :: Z) e er :
WSubst x es (transitivity H1 H2) e er → WSubst x es H2 (wexpr H1 e) er | 0.
Proof. by rewrite /WSubst wsubst_wexpr'. Qed.
Instance do_wsubst_closed_closed x es (H : [] `included` [x]) e :
WSubst x es H e e | 1.
Proof. apply wsubst_closed_nil. Qed.
Instance do_wsubst_closed_wexpr Y x es (H : [] `included` x :: Y) e :
WSubst x es H e (wexpr' e) | 2.
Proof. apply wsubst_closed, not_elem_of_nil. Qed.
(* Boring connectives *)
Section wsubst.
Context {X Y} (x : string) (es : expr []) (H : X `included` x :: Y).
Notation Sub := (WSubst x es H).
(* Ground terms *)
Global Instance do_wsubst_lit l : Sub (Lit l) (Lit l).
Proof. done. Qed.
Global Instance do_wsubst_app e1 e2 e1r e2r :
Sub e1 e1r → Sub e2 e2r → Sub (App e1 e2) (App e1r e2r).
Proof. intros; red; f_equal/=; apply: do_wsubst. Qed.
Global Instance do_wsubst_unop op e er : Sub e er → Sub (UnOp op e) (UnOp op er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_binop op e1 e2 e1r e2r :
Sub e1 e1r → Sub e2 e2r → Sub (BinOp op e1 e2) (BinOp op e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_if e0 e1 e2 e0r e1r e2r :
Sub e0 e0r → Sub e1 e1r → Sub e2 e2r → Sub (If e0 e1 e2) (If e0r e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_pair e1 e2 e1r e2r :
Sub e1 e1r → Sub e2 e2r → Sub (Pair e1 e2) (Pair e1r e2r).
Proof. by intros ??; red; f_equal/=. Qed.
Global Instance do_wsubst_fst e er : Sub e er → Sub (Fst e) (Fst er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_snd e er : Sub e er → Sub (Snd e) (Snd er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_injL e er : Sub e er → Sub (InjL e) (InjL er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_injR e er : Sub e er → Sub (InjR e) (InjR er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_case e0 e1 e2 e0r e1r e2r :
Sub e0 e0r → Sub e1 e1r → Sub e2 e2r → Sub (Case e0 e1 e2) (Case e0r e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_fork e er : Sub e er → Sub (Fork e) (Fork er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_alloc e er : Sub e er → Sub (Alloc e) (Alloc er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_load e er : Sub e er → Sub (Load e) (Load er).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_store e1 e2 e1r e2r :
Sub e1 e1r → Sub e2 e2r → Sub (Store e1 e2) (Store e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
Global Instance do_wsubst_cas e0 e1 e2 e0r e1r e2r :
Sub e0 e0r → Sub e1 e1r → Sub e2 e2r → Sub (CAS e0 e1 e2) (CAS e0r e1r e2r).
Proof. by intros; red; f_equal/=. Qed.
End wsubst.
(** * The tactic *)
Lemma do_subst {X} (x: string) (es: expr []) (e: expr (x :: X)) (er: expr X) :
WSubst x es (λ _, id) e er → subst x es e = er.
Proof. done. Qed.
Ltac simpl_subst :=
repeat match goal with
| |- context [subst ?x ?es ?e] => progress rewrite (@do_subst _ x es e)
| |- _ => progress csimpl
end.
Arguments wexpr : simpl never.
Arguments subst : simpl never.
Arguments wsubst : simpl never.
heap_lang/tactics.v deleted 100644 → 0
View file @ 2bc4df02
From iris.heap_lang Require Export substitution.
From iris.prelude Require Import fin_maps.
Import heap_lang.
(** The tactic [inv_head_step] performs inversion on hypotheses of the
shape [head_step]. The tactic will discharge head-reductions starting
from values, and simplifies hypothesis related to conversions from and
to values, and finite map operations. This tactic is slightly ad-hoc
and tuned for proving our lifting lemmas. *)
Ltac inv_head_step :=
repeat match goal with
| _ => progress simplify_map_eq/= (* simplify memory stuff *)
| H : to_val _ = Some _ |- _ => apply of_to_val in H
| H : context [to_val (of_val _)] |- _ => rewrite to_of_val in H
| H : head_step ?e _ _ _ _ |- _ =>
try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
and can thus better be avoided. *)
inversion H; subst; clear H
end.
(** The tactic [reshape_expr e tac] decomposes the expression [e] into an
evaluation context [K] and a subexpression [e']. It calls the tactic [tac K e']
for each possible decomposition until [tac] succeeds. *)
Ltac reshape_val e tac :=
let rec go e :=
match e with
| of_val ?v => v
| wexpr' ?e => reshape_val e tac
| Rec ?f ?x ?e => constr:(RecV f x e)
| Lit ?l => constr:(LitV l)
| Pair ?e1 ?e2 =>
let v1 := reshape_val e1 in let v2 := reshape_val e2 in constr:(PairV v1 v2)
| InjL ?e => let v := reshape_val e in constr:(InjLV v)
| InjR ?e => let v := reshape_val e in constr:(InjRV v)
end in let v := go e in first [tac v | fail 2].
Ltac reshape_expr e tac :=
let rec go K e :=
match e with
| _ => tac (reverse K) e
| App ?e1 ?e2 => reshape_val e1 ltac:(fun v1 => go (AppRCtx v1 :: K) e2)
| App ?e1 ?e2 => go (AppLCtx e2 :: K) e1
| UnOp ?op ?e => go (UnOpCtx op :: K) e
| BinOp ?op ?e1 ?e2 =>
reshape_val e1 ltac:(fun v1 => go (BinOpRCtx op v1 :: K) e2)
| BinOp ?op ?e1 ?e2 => go (BinOpLCtx op e2 :: K) e1
| If ?e0 ?e1 ?e2 => go (IfCtx e1 e2 :: K) e0
| Pair ?e1 ?e2 => reshape_val e1 ltac:(fun v1 => go (PairRCtx v1 :: K) e2)
| Pair ?e1 ?e2 => go (PairLCtx e2 :: K) e1
| Fst ?e => go (FstCtx :: K) e
| Snd ?e => go (SndCtx :: K) e
| InjL ?e => go (InjLCtx :: K) e
| InjR ?e => go (InjRCtx :: K) e
| Case ?e0 ?e1 ?e2 => go (CaseCtx e1 e2 :: K) e0
| Alloc ?e => go (AllocCtx :: K) e
| Load ?e => go (LoadCtx :: K) e
| Store ?e1 ?e2 => reshape_val e1 ltac:(fun v1 => go (StoreRCtx v1 :: K) e2)
| Store ?e1 ?e2 => go (StoreLCtx e2 :: K) e1
| CAS ?e0 ?e1 ?e2 => reshape_val e0 ltac:(fun v0 => first
[ reshape_val e1 ltac:(fun v1 => go (CasRCtx v0 v1 :: K) e2)
| go (CasMCtx v0 e2 :: K) e1 ])
| CAS ?e0 ?e1 ?e2 => go (CasLCtx e1 e2 :: K) e0
end in go (@nil ectx_item) e.
(** The tactic [do_head_step tac] solves goals of the shape [head_reducible] and
[head_step] by performing a reduction step and uses [tac] to solve any
side-conditions generated by individual steps. *)
Tactic Notation "do_head_step" tactic3(tac) :=
try match goal with |- head_reducible _ _ => eexists _, _, _ end;
simpl;
match goal with
| |- head_step ?e1 ?σ1 ?e2 ?σ2 ?ef =>
first [apply alloc_fresh|econstructor];
(* solve [to_val] side-conditions *)
first [rewrite ?to_of_val; reflexivity|simpl_subst; tac; fast_done]
end.
heap_lang/wp_tactics.v deleted 100644 → 0
View file @ 2bc4df02
From iris.algebra Require Export upred_tactics.
From iris.heap_lang Require Export tactics derived substitution.
Import uPred.
(** wp-specific helper tactics *)
Ltac wp_bind K :=
lazymatch eval hnf in K with
| [] => idtac
| _ => etrans; [|fast_by apply (wp_bind K)]; simpl
end.
Ltac wp_done := rewrite /= ?to_of_val; fast_done.
(* sometimes, we will have to do a final view shift, so only apply
pvs_intro if we obtain a consecutive wp *)
Ltac wp_strip_pvs :=
lazymatch goal with
| |- _ ⊢ |={?E}=> _ =>
etrans; [|apply pvs_intro];
match goal with |- _ ⊢ wp E _ _ => simpl | _ => fail end
end.
Ltac wp_value_head := etrans; [|eapply wp_value_pvs; wp_done]; lazy beta.
Ltac wp_strip_later := idtac. (* a hook to be redefined later *)
Ltac wp_seq_head :=
lazymatch goal with
| |- _ ⊢ wp ?E (Seq _ _) ?Q =>
etrans; [|eapply wp_seq; wp_done]; wp_strip_later
end.
Ltac wp_finish := intros_revert ltac:(
rewrite /= ?to_of_val;
try wp_strip_later;
repeat lazymatch goal with
| |- _ ⊢ wp ?E (Seq _ _) ?Q =>
etrans; [|eapply wp_seq; wp_done]; wp_strip_later
| |- _ ⊢ wp ?E _ ?Q => wp_value_head
| |- _ ⊢ |={_}=> _ => wp_strip_pvs
end).
Tactic Notation "wp_value" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
wp_bind K; wp_value_head) || fail "wp_value: cannot find value in" e
| _ => fail "wp_value: not a wp"
end.
Tactic Notation "wp_rec" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with App ?e1 _ =>
(* hnf does not reduce through an of_val *)
(* match eval hnf in e1 with Rec _ _ _ => *)
wp_bind K; etrans; [|eapply wp_rec; wp_done]; simpl_subst; wp_finish
(* end *) end) || fail "wp_rec: cannot find 'Rec' in" e
| _ => fail "wp_rec: not a 'wp'"
end.
Tactic Notation "wp_lam" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with App ?e1 _ =>
(* match eval hnf in e1 with Rec BAnon _ _ => *)
wp_bind K; etrans; [|eapply wp_lam; wp_done]; simpl_subst; wp_finish
(* end *) end) || fail "wp_lam: cannot find 'Lam' in" e
| _ => fail "wp_lam: not a 'wp'"
end.
Tactic Notation "wp_let" := wp_lam.
Tactic Notation "wp_seq" := wp_let.
Tactic Notation "wp_op" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| BinOp LtOp _ _ => wp_bind K; apply wp_lt; wp_finish
| BinOp LeOp _ _ => wp_bind K; apply wp_le; wp_finish
| BinOp EqOp _ _ => wp_bind K; apply wp_eq; wp_finish
| BinOp _ _ _ =>
wp_bind K; etrans; [|eapply wp_bin_op; try fast_done]; wp_finish
| UnOp _ _ =>
wp_bind K; etrans; [|eapply wp_un_op; try fast_done]; wp_finish
end) || fail "wp_op: cannot find 'BinOp' or 'UnOp' in" e
| _ => fail "wp_op: not a 'wp'"
end.
Tactic Notation "wp_proj" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| Fst _ => wp_bind K; etrans; [|eapply wp_fst; wp_done]; wp_finish
| Snd _ => wp_bind K; etrans; [|eapply wp_snd; wp_done]; wp_finish
end) || fail "wp_proj: cannot find 'Fst' or 'Snd' in" e
| _ => fail "wp_proj: not a 'wp'"
end.
Tactic Notation "wp_if" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| If _ _ _ =>
wp_bind K;
etrans; [|eapply wp_if_true || eapply wp_if_false]; wp_finish
end) || fail "wp_if: cannot find 'If' in" e
| _ => fail "wp_if: not a 'wp'"
end.
Tactic Notation "wp_match" :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| Case _ _ _ =>
wp_bind K;
etrans; [|first[eapply wp_match_inl; wp_done|eapply wp_match_inr; wp_done]];
simpl_subst; wp_finish
end) || fail "wp_match: cannot find 'Match' in" e
| _ => fail "wp_match: not a 'wp'"
end.
Tactic Notation "wp_focus" open_constr(efoc) :=
lazymatch goal with
| |- _ ⊢ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match e' with
| efoc => unify e' efoc; wp_bind K
end) || fail "wp_focus: cannot find" efoc "in" e
| _ => fail "wp_focus: not a 'wp'"
end.
iris-bot 0 → 100755
View file @ 9f18e97d
#!/usr/bin/python3
import sys, os, subprocess
import requests, argparse
from datetime import datetime, timezone
from collections import namedtuple
################################################################################
# This script lets you autoamtically trigger some operations on the Iris CI to
# do further test/analysis on a branch (usually an MR).
# Set the GITLAB_TOKEN environment variable to a GitLab access token.
# You can generate such a token at
# <https://gitlab.mpi-sws.org/-/user_settings/personal_access_tokens>.
# Select only the "api" scope.
#
# Set at least one of IRIS_REV or STDPP_REV to control which branches of these
# projects to build against (defaults to default git branch). IRIS_REPO and
# STDPP_REPO can be used to take branches from forks. Setting IRIS to
# "user:branch" will use the given branch on that user's fork of Iris, and
# similar for STDPP.
#
# Supported commands:
# - `./iris-bot build [$filter]`: Builds all reverse dependencies against the
# given branches. The optional `filter` argument only builds projects whose
# names contains that string.
# - `./iris-bot time $project`: Measure the impact of this branch on the build
# time of the given reverse dependency. Only Iris branches are supported for
# now.
################################################################################
PROJECTS = {
'lambda-rust': { 'name': 'lambda-rust', 'branch': 'master', 'timing': True },
'lambda-rust-weak': { 'name': 'lambda-rust', 'branch': 'masters/weak_mem' }, # covers GPFSL and ORC11
'examples': { 'name': 'examples', 'branch': 'master', 'timing': True },
'gpfsl': { 'name': 'gpfsl', 'branch': 'master', 'timing': True }, # need separate entry for timing
'iron': { 'name': 'iron', 'branch': 'master', 'timing': True },
'reloc': { 'name': 'reloc', 'branch': 'master' },
'actris': { 'name': 'actris', 'branch': 'master' },
'simuliris': { 'name': 'simuliris', 'branch': 'master' },
'tutorial-popl20': { 'name': 'tutorial-popl20', 'branch': 'master' },
'tutorial-popl21': { 'name': 'tutorial-popl21', 'branch': 'master' },
}
if not "GITLAB_TOKEN" in os.environ:
print("You need to set the GITLAB_TOKEN environment variable to a GitLab access token.")
print("You can create such tokens at <https://gitlab.mpi-sws.org/profile/personal_access_tokens>.")
print("Make sure you grant access to the 'api' scope.")
sys.exit(1)
GITLAB_TOKEN = os.environ["GITLAB_TOKEN"]
# Pre-processing for branch variables of dependency projects: you can set
# 'PROJECT' to 'user:branch', or set 'PROJECT_REPO' and 'PROJECT_REV'
# automatically.
BUILD_BRANCHES = {}
for project in ['stdpp', 'iris', 'orc11', 'gpfsl']:
var = project.upper()
if var in os.environ:
(repo, rev) = os.environ[var].split(':')
repo = repo + "/" + project
else:
repo = os.environ.get(var+"_REPO", "iris/"+project)
rev = os.environ.get(var+"_REV")
if rev is not None:
BUILD_BRANCHES[project] = (repo, rev)
if not "iris" in BUILD_BRANCHES:
print("Please set IRIS_REV, STDPP_REV, ORC11_REV and GPFSL_REV environment variables to the branch/tag/commit of the respective project that you want to use.")
print("Only IRIS_REV is mandatory, the rest defaults to the default git branch.")
sys.exit(1)
# Useful helpers
def trigger_build(project, branch, vars):
id = "iris%2F{}".format(project)
url = "https://gitlab.mpi-sws.org/api/v4/projects/{}/pipeline".format(id)
json = {
'ref': branch,
'variables': [{ 'key': key, 'value': val } for (key, val) in vars.items()],
}
r = requests.post(url, headers={'PRIVATE-TOKEN': GITLAB_TOKEN}, json=json)
r.raise_for_status()
return r.json()
# The commands
def build(args):
# Convert BUILD_BRANCHES into suitable dictionary
vars = {}
for project in BUILD_BRANCHES.keys():
(repo, rev) = BUILD_BRANCHES[project]
var = project.upper()
vars[var+"_REPO"] = repo
vars[var+"_REV"] = rev
if args.coq:
vars["NIGHTLY_COQ"] = args.coq
# Loop over all projects, and trigger build.
for (name, project) in PROJECTS.items():
if args.filter in name:
print("Triggering build for {}...".format(name))
pipeline_url = trigger_build(project['name'], project['branch'], vars)['web_url']
print(" Pipeline running at {}".format(pipeline_url))
TimeJob = namedtuple("TimeJob", "id base_commit base_pipeline test_commit test_pipeline compare")
def time_project(project, iris_repo, iris_rev, test_rev):
# Obtain a unique ID for this experiment
id = datetime.now(timezone.utc).strftime("%Y%m%d-%H%M%S")
# Determine the branch commit to build
subprocess.run(["git", "fetch", "-q", "https://gitlab.mpi-sws.org/{}".format(iris_repo), iris_rev], check=True)
test_commit = subprocess.run(["git", "rev-parse", "FETCH_HEAD"], check=True, stdout=subprocess.PIPE).stdout.decode().strip()
# Determine the base commit in master
subprocess.run(["git", "fetch", "-q", "https://gitlab.mpi-sws.org/iris/iris.git", "master"], check=True)
base_commit = subprocess.run(["git", "merge-base", test_commit, "FETCH_HEAD"], check=True, stdout=subprocess.PIPE).stdout.decode().strip()
# Trigger the builds
vars = {
'IRIS_REPO': iris_repo,
'IRIS_REV': base_commit,
'TIMING_AD_HOC_ID': id+"-base",
}
base_pipeline = trigger_build(project['name'], project['branch'], vars)
vars = {
'IRIS_REPO': iris_repo,
'IRIS_REV': test_commit,
'TIMING_AD_HOC_ID': id+"-test",
}
if test_rev is None:
# We hope that this repository did not change since the job we created just above...
test_pipeline = trigger_build(project['name'], project['branch'], vars)
else:
test_pipeline = trigger_build(project['name'], args.test_rev, vars)
compare = "https://coq-speed.mpi-sws.org/d/1QE_dqjiz/coq-compare?orgId=1&var-project={}&var-branch1=@hoc&var-commit1={}&var-config1={}&var-branch2=@hoc&var-commit2={}&var-config2={}".format(project['name'], base_pipeline['sha'], id+"-base", test_pipeline['sha'], id+"-test")
return TimeJob(id, base_commit, base_pipeline['web_url'], test_commit, test_pipeline['web_url'], compare)
def time(args):
# Make sure only 'iris' variables are set.
# One could imagine generalizing to "either Iris or std++", but then if the
# ad-hoc timing jobs honor STDPP_REV, how do we make it so that particular
# deterministic std++ versions are used for Iris timing? This does not
# currently seem worth the effort / hacks.
for project in BUILD_BRANCHES.keys():
if project != 'iris':
print("'time' command only supports Iris branches")
sys.exit(1)
(iris_repo, iris_rev) = BUILD_BRANCHES['iris']
# Special mode: time everything
if args.project == 'all':
if args.test_rev is not None:
print("'time all' does not support '--test-rev'")
sys.exit(1)
for (name, project) in PROJECTS.items():
if not project.get('timing'):
continue
job = time_project(project, iris_repo, iris_rev, None)
print("- [{}]({})".format(name, job.compare))
return
# Get project to test and ensure it supports timing
project_name = args.project
if project_name not in PROJECTS:
print("ERROR: no such project: {}".format(project_name))
sys.exit(1)
project = PROJECTS[project_name]
if not project.get('timing'):
print("ERROR: {} does not support timing".format(project_name))
sys.exit(1)
# Run it!
job = time_project(project, iris_repo, iris_rev, args.test_rev)
print("Triggering timing builds for {} with Iris base commit {} and test commit {} using ad-hoc ID {}...".format(project_name, job.base_commit[:8], job.test_commit[:8], job.id))
print(" Base pipeline running at {}".format(job.base_pipeline))
if args.test_rev is None:
print(" Test pipeline running at {}".format(job.test_pipeline))
else:
print(" Test pipeline (on non-standard branch {}) running at {}".format(args.test_rev, job.test_pipeline))
print(" Once done, timing comparison will be available at {}".format(job.compare))
# Dispatch
if __name__ == "__main__":
parser = argparse.ArgumentParser(description='Iris CI utility')
subparsers = parser.add_subparsers(required=True, title='iris-bot command to execute', description='see "$command -h" for help', metavar="$command")
parser_build = subparsers.add_parser('build', help='Build many reverse dependencies against an Iris branch')
parser_build.set_defaults(func=build)
parser_build.add_argument('--coq', help='the (opam) Coq version to use for these tests')
parser_build.add_argument('filter', nargs='?', default='', help='(optional) restrict build to projects matching the filter')
parser_time = subparsers.add_parser('time', help='Time one reverse dependency against an Iris branch')
parser_time.add_argument("project", help="the project to measure the time of, or 'all' to measure all of them")
parser_time.add_argument("--test-rev", help="use different revision on project for the test build (in case the project requires changes to still build)")
parser_time.set_defaults(func=time)
# Parse, and dispatch to sub-command
args = parser.parse_args()
args.func(args)
iris/algebra/agree.v 0 → 100644
View file @ 9f18e97d
From iris.algebra Require Export cmra.
From iris.prelude Require Import options.
Local Arguments validN _ _ _ _ !_ /.
Local Arguments valid _ _ !_ /.
Local Arguments op _ _ _ !_ /.
Local Arguments pcore _ _ !_ /.
(** Define an agreement construction such that Agree A is discrete when A is discrete.
Notice that this construction is NOT complete. The following is due to Aleš:
Proposition: Ag(T) is not necessarily complete.
Proof.
Let T be the set of binary streams (infinite sequences) with the usual
ultrametric, measuring how far they agree.
Let Aₙ be the set of all binary strings of length n. Thus for Aₙ to be a
subset of T we have them continue as a stream of zeroes.
Now Aₙ is a finite non-empty subset of T. Moreover {Aₙ} is a Cauchy sequence
in the defined (Hausdorff) metric.
However the limit (if it were to exist as an element of Ag(T)) would have to
be the set of all binary streams, which is not exactly finite.
Thus Ag(T) is not necessarily complete.
*)
(** Note that the projection [agree_car] is not non-expansive, so it cannot be
used in the logic. If you need to get a witness out, you should use the
lemma [to_agree_uninjN] instead. In general, [agree_car] should ONLY be used
internally in this file. *)
Record agree (A : Type) : Type := {
agree_car : list A;
agree_not_nil : bool_decide (agree_car = []) = false
}.
Global Arguments agree_car {_} _.
Global Arguments agree_not_nil {_} _.
Local Coercion agree_car : agree >-> list.
Definition to_agree {A} (a : A) : agree A :=
{| agree_car := [a]; agree_not_nil := eq_refl |}.
Lemma elem_of_agree {A} (x : agree A) : ∃ a, a ∈ agree_car x.
Proof. destruct x as [[|a ?] ?]; set_solver+. Qed.
Lemma agree_eq {A} (x y : agree A) : agree_car x = agree_car y → x = y.
Proof.
destruct x as [a ?], y as [b ?]; simpl.
intros ->; f_equal. apply (proof_irrel _).
Qed.
Section agree.
Context {SI : sidx} {A : ofe}.
Implicit Types a b : A.
Implicit Types x y : agree A.
(* OFE *)
Local Instance agree_dist : Dist (agree A) := λ n x y,
(∀ a, a ∈ agree_car x → ∃ b, b ∈ agree_car y ∧ a ≡{n}≡ b) ∧
(∀ b, b ∈ agree_car y → ∃ a, a ∈ agree_car x ∧ a ≡{n}≡ b).
Local Instance agree_equiv : Equiv (agree A) := λ x y, ∀ n, x ≡{n}≡ y.
Definition agree_ofe_mixin : OfeMixin (agree A).
Proof.
split.
- done.
- intros n; split; rewrite /dist /agree_dist.
+ intros x; split; eauto.
+ intros x y [??]. naive_solver eauto.
+ intros x y z [H1 H1'] [H2 H2']; split.
* intros a ?. destruct (H1 a) as (b&?&?); auto.
destruct (H2 b) as (c&?&?); eauto. by exists c; split; last etrans.
* intros a ?. destruct (H2' a) as (b&?&?); auto.
destruct (H1' b) as (c&?&?); eauto. by exists c; split; last etrans.
- intros n m x y [??]; split; naive_solver eauto using dist_le.
Qed.
Canonical Structure agreeO := Ofe (agree A) agree_ofe_mixin.
(* CMRA *)
(* agree_validN is carefully written such that, when applied to a singleton, it
is convertible to True. This makes working with agreement much more pleasant. *)
Local Instance agree_validN_instance : ValidN (agree A) := λ n x,
match agree_car x with
| [a] => True
| _ => ∀ a b, a ∈ agree_car x → b ∈ agree_car x → a ≡{n}≡ b
end.
Local Instance agree_valid_instance : Valid (agree A) := λ x, ∀ n, ✓{n} x.
Local Program Instance agree_op_instance : Op (agree A) := λ x y,
{| agree_car := agree_car x ++ agree_car y |}.
Next Obligation. by intros [[|??]] y. Qed.
Local Instance agree_pcore_instance : PCore (agree A) := Some.
Lemma agree_validN_def n x :
✓{n} x ↔ ∀ a b, a ∈ agree_car x → b ∈ agree_car x → a ≡{n}≡ b.
Proof.
rewrite /validN /agree_validN_instance. destruct (agree_car _) as [|? [|??]]; auto.
setoid_rewrite elem_of_list_singleton; naive_solver.
Qed.
Local Instance agree_comm : Comm (≡) (@op (agree A) _).
Proof. intros x y n; split=> a /=; setoid_rewrite elem_of_app; naive_solver. Qed.
Local Instance agree_assoc : Assoc (≡) (@op (agree A) _).
Proof.
intros x y z n; split=> a /=; repeat setoid_rewrite elem_of_app; naive_solver.
Qed.
Lemma agree_idemp x : x ⋅ x ≡ x.
Proof. intros n; split=> a /=; setoid_rewrite elem_of_app; naive_solver. Qed.
Local Instance agree_validN_ne n :
Proper (dist n ==> impl) (@validN SI (agree A) _ n).
Proof.
intros x y [H H']; rewrite /impl !agree_validN_def; intros Hv a b Ha Hb.
destruct (H' a) as (a'&?&<-); auto. destruct (H' b) as (b'&?&<-); auto.
Qed.
Local Instance agree_validN_proper n :
Proper (equiv ==> iff) (@validN SI (agree A) _ n).
Proof. move=> x y /equiv_dist H. by split; rewrite (H n). Qed.
Local Instance agree_op_ne' x : NonExpansive (op x).
Proof.
intros n y1 y2 [H H']; split=> a /=; setoid_rewrite elem_of_app; naive_solver.
Qed.
Local Instance agree_op_ne : NonExpansive2 (@op (agree A) _).
Proof. by intros n x1 x2 Hx y1 y2 Hy; rewrite Hy !(comm _ _ y2) Hx. Qed.
Local Instance agree_op_proper : Proper ((≡) ==> (≡) ==> (≡)) (op (A := agree A)) :=
ne_proper_2 _.
Lemma agree_included x y : x ≼ y ↔ y ≡ x ⋅ y.
Proof.
split; [|by intros ?; exists y].
by intros [z Hz]; rewrite Hz assoc agree_idemp.
Qed.
Lemma agree_includedN n x y : x ≼{n} y ↔ y ≡{n}≡ x ⋅ y.
Proof.
split; [|by intros ?; exists y].
by intros [z Hz]; rewrite Hz assoc agree_idemp.
Qed.
Lemma agree_op_invN n x1 x2 : ✓{n} (x1 ⋅ x2) → x1 ≡{n}≡ x2.
Proof.
rewrite agree_validN_def /=. setoid_rewrite elem_of_app=> Hv; split=> a Ha.
- destruct (elem_of_agree x2); naive_solver.
- destruct (elem_of_agree x1); naive_solver.
Qed.
Definition agree_cmra_mixin : CmraMixin (agree A).
Proof.
apply cmra_total_mixin; try apply _ || by eauto.
- intros n m x; rewrite !agree_validN_def; eauto using dist_le.
- intros x. apply agree_idemp.
- intros n x y; rewrite !agree_validN_def /=.
setoid_rewrite elem_of_app; naive_solver.
- intros n x y1 y2 Hval Hx; exists x, x; simpl; split.
+ by rewrite agree_idemp.
+ by move: Hval; rewrite Hx; move=> /agree_op_invN->; rewrite agree_idemp.
Qed.
Canonical Structure agreeR : cmra := Cmra (agree A) agree_cmra_mixin.
Global Instance agree_cmra_total : CmraTotal agreeR.
Proof. rewrite /CmraTotal; eauto. Qed.
Global Instance agree_core_id x : CoreId x.
Proof. by constructor. Qed.
Global Instance agree_cmra_discrete : OfeDiscrete A → CmraDiscrete agreeR.
Proof.
intros HD. split.
- intros x y [H H'] n; split=> a; setoid_rewrite <-(discrete_iff_0 _ _); auto.
- intros x; rewrite agree_validN_def=> Hv n. apply agree_validN_def=> a b ??.
apply discrete_iff_0; auto.
Qed.
Global Instance to_agree_ne : NonExpansive to_agree.
Proof.
intros n a1 a2 Hx; split=> b /=;
setoid_rewrite elem_of_list_singleton; naive_solver.
Qed.
Global Instance to_agree_proper : Proper ((≡) ==> (≡)) to_agree := ne_proper _.
Global Instance to_agree_discrete a : Discrete a → Discrete (to_agree a).
Proof.
intros ? y [H H'] n; split.
- intros a' ->%elem_of_list_singleton. destruct (H a) as [b ?]; first by left.
exists b. by rewrite -discrete_iff_0.
- intros b Hb. destruct (H' b) as (b'&->%elem_of_list_singleton&?); auto.
exists a. by rewrite elem_of_list_singleton -discrete_iff_0.
Qed.
Lemma agree_op_inv x y : ✓ (x ⋅ y) → x ≡ y.
Proof.
intros ?. apply equiv_dist=> n. by apply agree_op_invN, cmra_valid_validN.
Qed.
Global Instance to_agree_injN n : Inj (dist n) (dist n) (to_agree).
Proof.
move=> a b [_] /=. setoid_rewrite elem_of_list_singleton. naive_solver.
Qed.
Global Instance to_agree_inj : Inj (≡) (≡) (to_agree).
Proof. intros a b ?. apply equiv_dist=>n. by apply (inj to_agree), equiv_dist. Qed.
Lemma to_agree_uninjN n x : ✓{n} x → ∃ a, to_agree a ≡{n}≡ x.
Proof.
rewrite agree_validN_def=> Hv.
destruct (elem_of_agree x) as [a ?].
exists a; split=> b /=; setoid_rewrite elem_of_list_singleton; naive_solver.
Qed.
Lemma to_agree_uninj x : ✓ x → ∃ a, to_agree a ≡ x.
Proof.
rewrite /valid /agree_valid_instance; setoid_rewrite agree_validN_def.
destruct (elem_of_agree x) as [a ?].
exists a; split=> b /=; setoid_rewrite elem_of_list_singleton; naive_solver.
Qed.
Lemma agree_valid_includedN n x y : ✓{n} y → x ≼{n} y → x ≡{n}≡ y.
Proof.
move=> Hval [z Hy]; move: Hval; rewrite Hy.
by move=> /agree_op_invN->; rewrite agree_idemp.
Qed.
Lemma agree_valid_included x y : ✓ y → x ≼ y → x ≡ y.
Proof.
move=> Hval [z Hy]; move: Hval; rewrite Hy.
by move=> /agree_op_inv->; rewrite agree_idemp.
Qed.
Lemma to_agree_includedN n a b : to_agree a ≼{n} to_agree b ↔ a ≡{n}≡ b.
Proof.
split; last by intros ->.
intros. by apply (inj to_agree), agree_valid_includedN.
Qed.
Lemma to_agree_included a b : to_agree a ≼ to_agree b ↔ a ≡ b.
Proof.
split; last by intros ->.
intros. by apply (inj to_agree), agree_valid_included.
Qed.
Lemma to_agree_included_L `{!LeibnizEquiv A} a b : to_agree a ≼ to_agree b ↔ a = b.
Proof. unfold_leibniz. apply to_agree_included. Qed.
Global Instance agree_cancelable x : Cancelable x.
Proof.
intros n y z Hv Heq.
destruct (to_agree_uninjN n x) as [x' EQx]; first by eapply cmra_validN_op_l.
destruct (to_agree_uninjN n y) as [y' EQy]; first by eapply cmra_validN_op_r.
destruct (to_agree_uninjN n z) as [z' EQz].
{ eapply (cmra_validN_op_r n x z). by rewrite -Heq. }
assert (Hx'y' : x' ≡{n}≡ y').
{ apply (inj to_agree), agree_op_invN. by rewrite EQx EQy. }
assert (Hx'z' : x' ≡{n}≡ z').
{ apply (inj to_agree), agree_op_invN. by rewrite EQx EQz -Heq. }
by rewrite -EQy -EQz -Hx'y' -Hx'z'.
Qed.
Lemma to_agree_op_invN a b n : ✓{n} (to_agree a ⋅ to_agree b) → a ≡{n}≡ b.
Proof. by intros ?%agree_op_invN%(inj to_agree). Qed.
Lemma to_agree_op_inv a b : ✓ (to_agree a ⋅ to_agree b) → a ≡ b.
Proof. by intros ?%agree_op_inv%(inj to_agree). Qed.
Lemma to_agree_op_inv_L `{!LeibnizEquiv A} a b : ✓ (to_agree a ⋅ to_agree b) → a = b.
Proof. by intros ?%to_agree_op_inv%leibniz_equiv. Qed.
Lemma to_agree_op_validN a b n : ✓{n} (to_agree a ⋅ to_agree b) ↔ a ≡{n}≡ b.
Proof.
split; first by apply to_agree_op_invN.
intros ->. rewrite agree_idemp //.
Qed.
Lemma to_agree_op_valid a b : ✓ (to_agree a ⋅ to_agree b) ↔ a ≡ b.
Proof.
split; first by apply to_agree_op_inv.
intros ->. rewrite agree_idemp //.
Qed.
Lemma to_agree_op_valid_L `{!LeibnizEquiv A} a b : ✓ (to_agree a ⋅ to_agree b) ↔ a = b.
Proof. rewrite to_agree_op_valid. by fold_leibniz. Qed.
End agree.
Global Instance: Params (@to_agree) 1 := {}.
Global Arguments agreeO {_} _.
Global Arguments agreeR {_} _.
Program Definition agree_map {A B} (f : A → B) (x : agree A) : agree B :=
{| agree_car := f <$> agree_car x |}.
Next Obligation. by intros A B f [[|??] ?]. Qed.
Lemma agree_map_id {A} (x : agree A) : agree_map id x = x.
Proof. apply agree_eq. by rewrite /= list_fmap_id. Qed.
Lemma agree_map_compose {A B C} (f : A → B) (g : B → C) (x : agree A) :
agree_map (g ∘ f) x = agree_map g (agree_map f x).
Proof. apply agree_eq. by rewrite /= list_fmap_compose. Qed.
Lemma agree_map_to_agree {A B} (f : A → B) (x : A) :
agree_map f (to_agree x) = to_agree (f x).
Proof. by apply agree_eq. Qed.
Section agree_map.
Context {SI : sidx} {A B : ofe} (f : A → B) {Hf: NonExpansive f}.
Local Instance agree_map_ne : NonExpansive (agree_map f).
Proof using Type*.
intros n x y [H H']; split=> b /=; setoid_rewrite elem_of_list_fmap.
- intros (a&->&?). destruct (H a) as (a'&?&?); auto. naive_solver.
- intros (a&->&?). destruct (H' a) as (a'&?&?); auto. naive_solver.
Qed.
Local Instance agree_map_proper : Proper ((≡) ==> (≡)) (agree_map f) := ne_proper _.
Lemma agree_map_ext (g : A → B) x :
(∀ a, f a ≡ g a) → agree_map f x ≡ agree_map g x.
Proof using Hf.
intros Hfg n; split=> b /=; setoid_rewrite elem_of_list_fmap.
- intros (a&->&?). exists (g a). rewrite Hfg; eauto.
- intros (a&->&?). exists (f a). rewrite -Hfg; eauto.
Qed.
Global Instance agree_map_morphism : CmraMorphism (agree_map f).
Proof using Hf.
split; first apply _.
- intros n x. rewrite !agree_validN_def=> Hv b b' /=.
intros (a&->&?)%elem_of_list_fmap (a'&->&?)%elem_of_list_fmap.
apply Hf; eauto.
- done.
- intros x y n; split=> b /=;
rewrite !fmap_app; setoid_rewrite elem_of_app; eauto.
Qed.
End agree_map.
Definition agreeO_map {SI : sidx} {A B : ofe}
(f : A -n> B) : agreeO A -n> agreeO B :=
OfeMor (agree_map f : agreeO A → agreeO B).
Global Instance agreeO_map_ne {SI : sidx} A B : NonExpansive (@agreeO_map SI A B).
Proof.
intros n f g Hfg x; split=> b /=;
setoid_rewrite elem_of_list_fmap; naive_solver.
Qed.
Program Definition agreeRF {SI : sidx} (F : oFunctor) : rFunctor := {|
rFunctor_car A _ B _ := agreeR (oFunctor_car F A B);
rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := agreeO_map (oFunctor_map F fg)
|}.
Next Obligation.
intros ? ? A1 ? A2 ? B1 ? B2 ? n ???; simpl.
by apply agreeO_map_ne, oFunctor_map_ne.
Qed.
Next Obligation.
intros ? F A ? B ? x; simpl. rewrite -{2}(agree_map_id x).
apply (agree_map_ext _)=>y. by rewrite oFunctor_map_id.
Qed.
Next Obligation.
intros ? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl.
rewrite -agree_map_compose.
apply (agree_map_ext _)=>y; apply oFunctor_map_compose.
Qed.
Global Instance agreeRF_contractive {SI : sidx} F :
oFunctorContractive F → rFunctorContractive (agreeRF F).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n ???; simpl.
by apply agreeO_map_ne, oFunctor_map_contractive.
Qed.
iris/algebra/auth.v 0 → 100644
View file @ 9f18e97d
From iris.algebra Require Export view frac.
From iris.algebra Require Import proofmode_classes big_op.
From iris.prelude Require Import options.
(** The authoritative camera with fractional authoritative elements *)
(** The authoritative camera has 2 types of elements: the authoritative element
[●{dq} a] and the fragment [◯ b] (of which there can be several). To enable
sharing of the authoritative element [●{dq} a], it is equipped with a
discardable fraction [dq]. Updates are only possible with the full
authoritative element [● a] (syntax for [●{#1} a]]), while fractional
authoritative elements have agreement, i.e., [✓ (●{dq1} a1 ⋅ ●{dq2} a2) → a1 ≡
a2]. *)
(** * Definition of the view relation *)
(** The authoritative camera is obtained by instantiating the view camera. *)
Definition auth_view_rel_raw {SI : sidx} {A : ucmra} (n : SI) (a b : A) : Prop :=
b ≼{n} a ∧ ✓{n} a.
Lemma auth_view_rel_raw_mono {SI : sidx} (A : ucmra) n1 n2 (a1 a2 b1 b2 : A) :
auth_view_rel_raw n1 a1 b1 →
a1 ≡{n2}≡ a2 →
b2 ≼{n2} b1 →
(n2 ≤ n1)%sidx →
auth_view_rel_raw n2 a2 b2.
Proof.
intros [??] Ha12 ??. split.
- trans b1; [done|]. rewrite -Ha12. by apply cmra_includedN_le with n1.
- rewrite -Ha12. by apply cmra_validN_le with n1.
Qed.
Lemma auth_view_rel_raw_valid {SI : sidx} (A : ucmra) n (a b : A) :
auth_view_rel_raw n a b → ✓{n} b.
Proof. intros [??]; eauto using cmra_validN_includedN. Qed.
Lemma auth_view_rel_raw_unit {SI : sidx} (A : ucmra) n :
∃ a : A, auth_view_rel_raw n a ε.
Proof. exists ε. split; [done|]. apply ucmra_unit_validN. Qed.
Canonical Structure auth_view_rel {SI : sidx} {A : ucmra} : view_rel A A :=
ViewRel auth_view_rel_raw (auth_view_rel_raw_mono A)
(auth_view_rel_raw_valid A) (auth_view_rel_raw_unit A).
Lemma auth_view_rel_unit {SI : sidx} {A : ucmra} n (a : A) :
auth_view_rel n a ε ↔ ✓{n} a.
Proof. split; [by intros [??]|]. split; auto using ucmra_unit_leastN. Qed.
Lemma auth_view_rel_exists {SI : sidx} {A : ucmra} n (b : A) :
(∃ a, auth_view_rel n a b) ↔ ✓{n} b.
Proof.
split; [|intros; exists b; by split].
intros [a Hrel]. eapply auth_view_rel_raw_valid, Hrel.
Qed.
Global Instance auth_view_rel_discrete {SI : sidx} {A : ucmra} :
CmraDiscrete A → ViewRelDiscrete (auth_view_rel (A:=A)).
Proof.
intros ? n a b [??]; split.
- by apply cmra_discrete_included_iff_0.
- by apply cmra_discrete_valid_iff_0.
Qed.
(** * Definition and operations on the authoritative camera *)
(** The type [auth] is not defined as a [Definition], but as a [Notation].
This way, one can use [auth A] with [A : Type] instead of [A : ucmra], and let
canonical structure search determine the corresponding camera instance. *)
Notation auth A := (view (A:=A) (B:=A) auth_view_rel_raw).
Definition authO {SI : sidx} (A : ucmra) : ofe :=
viewO (A:=A) (B:=A) auth_view_rel.
Definition authR {SI : sidx} (A : ucmra) : cmra :=
viewR (A:=A) (B:=A) auth_view_rel.
Definition authUR {SI : sidx} (A : ucmra) : ucmra :=
viewUR (A:=A) (B:=A) auth_view_rel.
Definition auth_auth {SI : sidx} {A: ucmra} : dfrac → A → auth A := view_auth.
Definition auth_frag {SI : sidx} {A: ucmra} : A → auth A := view_frag.
Global Typeclasses Opaque auth_auth auth_frag.
Global Instance: Params (@auth_auth) 3 := {}.
Global Instance: Params (@auth_frag) 2 := {}.
Notation "● dq a" := (auth_auth dq a)
(at level 20, dq custom dfrac at level 1, format "● dq a").
Notation "◯ a" := (auth_frag a) (at level 20).
(** * Laws of the authoritative camera *)
(** We omit the usual [equivI] lemma because it is hard to state a suitably
general version in terms of [●] and [◯], and because such a lemma has never
been needed in practice. *)
Section auth.
Context {SI : sidx} {A : ucmra}.
Implicit Types a b : A.
Implicit Types x y : auth A.
Implicit Types q : frac.
Implicit Types dq : dfrac.
Global Instance auth_auth_ne dq : NonExpansive (@auth_auth SI A dq).
Proof. rewrite /auth_auth. apply _. Qed.
Global Instance auth_auth_proper dq : Proper ((≡) ==> (≡)) (@auth_auth SI A dq).
Proof. rewrite /auth_auth. apply _. Qed.
Global Instance auth_frag_ne : NonExpansive (@auth_frag SI A).
Proof. rewrite /auth_frag. apply _. Qed.
Global Instance auth_frag_proper : Proper ((≡) ==> (≡)) (@auth_frag SI A).
Proof. rewrite /auth_frag. apply _. Qed.
Global Instance auth_auth_dist_inj n :
Inj2 (=) (dist n) (dist n) (@auth_auth SI A).
Proof. rewrite /auth_auth. apply _. Qed.
Global Instance auth_auth_inj : Inj2 (=) (≡) (≡) (@auth_auth SI A).
Proof. rewrite /auth_auth. apply _. Qed.
Global Instance auth_frag_dist_inj n : Inj (dist n) (dist n) (@auth_frag SI A).
Proof. rewrite /auth_frag. apply _. Qed.
Global Instance auth_frag_inj : Inj (≡) (≡) (@auth_frag SI A).
Proof. rewrite /auth_frag. apply _. Qed.
Global Instance auth_ofe_discrete : OfeDiscrete A → OfeDiscrete (authO A).
Proof. apply _. Qed.
Global Instance auth_auth_discrete dq a :
Discrete a → Discrete (ε : A) → Discrete (●{dq} a).
Proof. rewrite /auth_auth. apply _. Qed.
Global Instance auth_frag_discrete a : Discrete a → Discrete (◯ a).
Proof. rewrite /auth_frag. apply _. Qed.
Global Instance auth_cmra_discrete : CmraDiscrete A → CmraDiscrete (authR A).
Proof. apply _. Qed.
(** Operation *)
Lemma auth_auth_dfrac_op dq1 dq2 a : ●{dq1 ⋅ dq2} a ≡ ●{dq1} a ⋅ ●{dq2} a.
Proof. apply view_auth_dfrac_op. Qed.
Global Instance auth_auth_dfrac_is_op dq dq1 dq2 a :
IsOp dq dq1 dq2 → IsOp' (●{dq} a) (●{dq1} a) (●{dq2} a).
Proof. rewrite /auth_auth. apply _. Qed.
Lemma auth_frag_op a b : ◯ (a ⋅ b) = ◯ a ⋅ ◯ b.
Proof. apply view_frag_op. Qed.
Lemma auth_frag_mono a b : a ≼ b → ◯ a ≼ ◯ b.
Proof. apply view_frag_mono. Qed.
Lemma auth_frag_core a : core (◯ a) = ◯ (core a).
Proof. apply view_frag_core. Qed.
Lemma auth_both_core_discarded a b :
core (●□ a ⋅ ◯ b) ≡ ●□ a ⋅ ◯ (core b).
Proof. apply view_both_core_discarded. Qed.
Lemma auth_both_core_frac q a b :
core (●{#q} a ⋅ ◯ b) ≡ ◯ (core b).
Proof. apply view_both_core_frac. Qed.
Global Instance auth_auth_core_id a : CoreId (●□ a).
Proof. rewrite /auth_auth. apply _. Qed.
Global Instance auth_frag_core_id a : CoreId a → CoreId (◯ a).
Proof. rewrite /auth_frag. apply _. Qed.
Global Instance auth_both_core_id a1 a2 : CoreId a2 → CoreId (●□ a1 ⋅ ◯ a2).
Proof. rewrite /auth_auth /auth_frag. apply _. Qed.
Global Instance auth_frag_is_op a b1 b2 :
IsOp a b1 b2 → IsOp' (◯ a) (◯ b1) (◯ b2).
Proof. rewrite /auth_frag. apply _. Qed.
Global Instance auth_frag_sep_homomorphism :
MonoidHomomorphism op op (≡) (@auth_frag SI A).
Proof. rewrite /auth_frag. apply _. Qed.
Lemma big_opL_auth_frag {B} (g : nat → B → A) (l : list B) :
(◯ [^op list] k↦x ∈ l, g k x) ≡ [^op list] k↦x ∈ l, ◯ (g k x).
Proof. apply (big_opL_commute _). Qed.
Lemma big_opM_auth_frag `{Countable K} {B} (g : K → B → A) (m : gmap K B) :
(◯ [^op map] k↦x ∈ m, g k x) ≡ [^op map] k↦x ∈ m, ◯ (g k x).
Proof. apply (big_opM_commute _). Qed.
Lemma big_opS_auth_frag `{Countable B} (g : B → A) (X : gset B) :
(◯ [^op set] x ∈ X, g x) ≡ [^op set] x ∈ X, ◯ (g x).
Proof. apply (big_opS_commute _). Qed.
Lemma big_opMS_auth_frag `{Countable B} (g : B → A) (X : gmultiset B) :
(◯ [^op mset] x ∈ X, g x) ≡ [^op mset] x ∈ X, ◯ (g x).
Proof. apply (big_opMS_commute _). Qed.
(** Validity *)
Lemma auth_auth_dfrac_op_invN n dq1 a dq2 b : ✓{n} (●{dq1} a ⋅ ●{dq2} b) → a ≡{n}≡ b.
Proof. apply view_auth_dfrac_op_invN. Qed.
Lemma auth_auth_dfrac_op_inv dq1 a dq2 b : ✓ (●{dq1} a ⋅ ●{dq2} b) → a ≡ b.
Proof. apply view_auth_dfrac_op_inv. Qed.
Lemma auth_auth_dfrac_op_inv_L `{!LeibnizEquiv A} dq1 a dq2 b :
✓ (●{dq1} a ⋅ ●{dq2} b) → a = b.
Proof. by apply view_auth_dfrac_op_inv_L. Qed.
Lemma auth_auth_dfrac_validN n dq a : ✓{n} (●{dq} a) ↔ ✓ dq ∧ ✓{n} a.
Proof. by rewrite view_auth_dfrac_validN auth_view_rel_unit. Qed.
Lemma auth_auth_validN n a : ✓{n} (● a) ↔ ✓{n} a.
Proof. by rewrite view_auth_validN auth_view_rel_unit. Qed.
Lemma auth_auth_dfrac_op_validN n dq1 dq2 a1 a2 :
✓{n} (●{dq1} a1 ⋅ ●{dq2} a2) ↔ ✓ (dq1 ⋅ dq2) ∧ a1 ≡{n}≡ a2 ∧ ✓{n} a1.
Proof. by rewrite view_auth_dfrac_op_validN auth_view_rel_unit. Qed.
Lemma auth_auth_op_validN n a1 a2 : ✓{n} (● a1 ⋅ ● a2) ↔ False.
Proof. apply view_auth_op_validN. Qed.
(** The following lemmas are also stated as implications, which can be used
to force [apply] to use the lemma in the right direction. *)
Lemma auth_frag_validN n b : ✓{n} (◯ b) ↔ ✓{n} b.
Proof. by rewrite view_frag_validN auth_view_rel_exists. Qed.
Lemma auth_frag_validN_1 n b : ✓{n} (◯ b) → ✓{n} b.
Proof. apply auth_frag_validN. Qed.
Lemma auth_frag_validN_2 n b : ✓{n} b → ✓{n} (◯ b).
Proof. apply auth_frag_validN. Qed.
Lemma auth_frag_op_validN n b1 b2 : ✓{n} (◯ b1 ⋅ ◯ b2) ↔ ✓{n} (b1 ⋅ b2).
Proof. apply auth_frag_validN. Qed.
Lemma auth_frag_op_validN_1 n b1 b2 : ✓{n} (◯ b1 ⋅ ◯ b2) → ✓{n} (b1 ⋅ b2).
Proof. apply auth_frag_op_validN. Qed.
Lemma auth_frag_op_validN_2 n b1 b2 : ✓{n} (b1 ⋅ b2) → ✓{n} (◯ b1 ⋅ ◯ b2).
Proof. apply auth_frag_op_validN. Qed.
Lemma auth_both_dfrac_validN n dq a b :
✓{n} (●{dq} a ⋅ ◯ b) ↔ ✓ dq ∧ b ≼{n} a ∧ ✓{n} a.
Proof. apply view_both_dfrac_validN. Qed.
Lemma auth_both_validN n a b : ✓{n} (● a ⋅ ◯ b) ↔ b ≼{n} a ∧ ✓{n} a.
Proof. apply view_both_validN. Qed.
Lemma auth_auth_dfrac_valid dq a : ✓ (●{dq} a) ↔ ✓ dq ∧ ✓ a.
Proof.
rewrite view_auth_dfrac_valid !cmra_valid_validN.
by setoid_rewrite auth_view_rel_unit.
Qed.
Lemma auth_auth_valid a : ✓ (● a) ↔ ✓ a.
Proof.
rewrite view_auth_valid !cmra_valid_validN.
by setoid_rewrite auth_view_rel_unit.
Qed.
Lemma auth_auth_dfrac_op_valid dq1 dq2 a1 a2 :
✓ (●{dq1} a1 ⋅ ●{dq2} a2) ↔ ✓ (dq1 ⋅ dq2) ∧ a1 ≡ a2 ∧ ✓ a1.
Proof.
rewrite view_auth_dfrac_op_valid !cmra_valid_validN.
setoid_rewrite auth_view_rel_unit. done.
Qed.
Lemma auth_auth_op_valid a1 a2 : ✓ (● a1 ⋅ ● a2) ↔ False.
Proof. apply view_auth_op_valid. Qed.
(** The following lemmas are also stated as implications, which can be used
to force [apply] to use the lemma in the right direction. *)
Lemma auth_frag_valid b : ✓ (◯ b) ↔ ✓ b.
Proof.
rewrite view_frag_valid cmra_valid_validN.
by setoid_rewrite auth_view_rel_exists.
Qed.
Lemma auth_frag_valid_1 b : ✓ (◯ b) → ✓ b.
Proof. apply auth_frag_valid. Qed.
Lemma auth_frag_valid_2 b : ✓ b → ✓ (◯ b).
Proof. apply auth_frag_valid. Qed.
Lemma auth_frag_op_valid b1 b2 : ✓ (◯ b1 ⋅ ◯ b2) ↔ ✓ (b1 ⋅ b2).
Proof. apply auth_frag_valid. Qed.
Lemma auth_frag_op_valid_1 b1 b2 : ✓ (◯ b1 ⋅ ◯ b2) → ✓ (b1 ⋅ b2).
Proof. apply auth_frag_op_valid. Qed.
Lemma auth_frag_op_valid_2 b1 b2 : ✓ (b1 ⋅ b2) → ✓ (◯ b1 ⋅ ◯ b2).
Proof. apply auth_frag_op_valid. Qed.
(** These lemma statements are a bit awkward as we cannot possibly extract a
single witness for [b ≼ a] from validity, we have to make do with one witness
per step-index, i.e., [∀ n, b ≼{n} a]. *)
Lemma auth_both_dfrac_valid dq a b :
✓ (●{dq} a ⋅ ◯ b) ↔ ✓ dq ∧ (∀ n, b ≼{n} a) ∧ ✓ a.
Proof.
rewrite view_both_dfrac_valid. apply and_iff_compat_l. split.
- intros Hrel. split.
+ intros n. by destruct (Hrel n).
+ apply cmra_valid_validN=> n. by destruct (Hrel n).
- intros [Hincl Hval] n. split; [done|by apply cmra_valid_validN].
Qed.
Lemma auth_both_valid a b :
✓ (● a ⋅ ◯ b) ↔ (∀ n, b ≼{n} a) ∧ ✓ a.
Proof. rewrite auth_both_dfrac_valid. split; [naive_solver|done]. Qed.
(* The reverse direction of the two lemmas below only holds if the camera is
discrete. *)
Lemma auth_both_dfrac_valid_2 dq a b : ✓ dq → ✓ a → b ≼ a → ✓ (●{dq} a ⋅ ◯ b).
Proof.
intros. apply auth_both_dfrac_valid.
naive_solver eauto using cmra_included_includedN.
Qed.
Lemma auth_both_valid_2 a b : ✓ a → b ≼ a → ✓ (● a ⋅ ◯ b).
Proof. intros ??. by apply auth_both_dfrac_valid_2. Qed.
Lemma auth_both_dfrac_valid_discrete `{!CmraDiscrete A} dq a b :
✓ (●{dq} a ⋅ ◯ b) ↔ ✓ dq ∧ b ≼ a ∧ ✓ a.
Proof.
rewrite auth_both_dfrac_valid. setoid_rewrite <-cmra_discrete_included_iff.
pose 0ᵢ. naive_solver.
Qed.
Lemma auth_both_valid_discrete `{!CmraDiscrete A} a b :
✓ (● a ⋅ ◯ b) ↔ b ≼ a ∧ ✓ a.
Proof. rewrite auth_both_dfrac_valid_discrete. split; [naive_solver|done]. Qed.
(** Inclusion *)
Lemma auth_auth_dfrac_includedN n dq1 dq2 a1 a2 b :
●{dq1} a1 ≼{n} ●{dq2} a2 ⋅ ◯ b ↔ (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2.
Proof. apply view_auth_dfrac_includedN. Qed.
Lemma auth_auth_dfrac_included dq1 dq2 a1 a2 b :
●{dq1} a1 ≼ ●{dq2} a2 ⋅ ◯ b ↔ (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2.
Proof. apply view_auth_dfrac_included. Qed.
Lemma auth_auth_includedN n a1 a2 b :
● a1 ≼{n} ● a2 ⋅ ◯ b ↔ a1 ≡{n}≡ a2.
Proof. apply view_auth_includedN. Qed.
Lemma auth_auth_included a1 a2 b :
● a1 ≼ ● a2 ⋅ ◯ b ↔ a1 ≡ a2.
Proof. apply view_auth_included. Qed.
Lemma auth_frag_includedN n dq a b1 b2 :
◯ b1 ≼{n} ●{dq} a ⋅ ◯ b2 ↔ b1 ≼{n} b2.
Proof. apply view_frag_includedN. Qed.
Lemma auth_frag_included dq a b1 b2 :
◯ b1 ≼ ●{dq} a ⋅ ◯ b2 ↔ b1 ≼ b2.
Proof. apply view_frag_included. Qed.
(** The weaker [auth_both_included] lemmas below are a consequence of the
[auth_auth_included] and [auth_frag_included] lemmas above. *)
Lemma auth_both_dfrac_includedN n dq1 dq2 a1 a2 b1 b2 :
●{dq1} a1 ⋅ ◯ b1 ≼{n} ●{dq2} a2 ⋅ ◯ b2 ↔
(dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
Proof. apply view_both_dfrac_includedN. Qed.
Lemma auth_both_dfrac_included dq1 dq2 a1 a2 b1 b2 :
●{dq1} a1 ⋅ ◯ b1 ≼ ●{dq2} a2 ⋅ ◯ b2 ↔
(dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2 ∧ b1 ≼ b2.
Proof. apply view_both_dfrac_included. Qed.
Lemma auth_both_includedN n a1 a2 b1 b2 :
● a1 ⋅ ◯ b1 ≼{n} ● a2 ⋅ ◯ b2 ↔ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
Proof. apply view_both_includedN. Qed.
Lemma auth_both_included a1 a2 b1 b2 :
● a1 ⋅ ◯ b1 ≼ ● a2 ⋅ ◯ b2 ↔ a1 ≡ a2 ∧ b1 ≼ b2.
Proof. apply view_both_included. Qed.
(** Updates *)
Lemma auth_update a b a' b' :
(a,b) ~l~> (a',b') → ● a ⋅ ◯ b ~~> ● a' ⋅ ◯ b'.
Proof.
intros Hup. apply view_update=> n bf [[bf' Haeq] Hav].
destruct (Hup n (Some (bf ⋅ bf'))); simpl in *; [done|by rewrite assoc|].
split; [|done]. exists bf'. by rewrite -assoc.
Qed.
Lemma auth_update_alloc a a' b' : (a,ε) ~l~> (a',b') → ● a ~~> ● a' ⋅ ◯ b'.
Proof. intros. rewrite -(right_id _ _ (● a)). by apply auth_update. Qed.
Lemma auth_update_dealloc a b a' : (a,b) ~l~> (a',ε) → ● a ⋅ ◯ b ~~> ● a'.
Proof. intros. rewrite -(right_id _ _ (● a')). by apply auth_update. Qed.
Lemma auth_update_auth a a' b' : (a,ε) ~l~> (a',b') → ● a ~~> ● a'.
Proof.
intros. etrans; first exact: auth_update_alloc.
exact: cmra_update_op_l.
Qed.
Lemma auth_update_auth_persist dq a : ●{dq} a ~~> ●□ a.
Proof. apply view_update_auth_persist. Qed.
Lemma auth_updateP_auth_unpersist a : ●□ a ~~>: λ k, ∃ q, k = ●{#q} a.
Proof. apply view_updateP_auth_unpersist. Qed.
Lemma auth_updateP_both_unpersist a b : ●□ a ⋅ ◯ b ~~>: λ k, ∃ q, k = ●{#q} a ⋅ ◯ b.
Proof. apply view_updateP_both_unpersist. Qed.
Lemma auth_update_dfrac_alloc dq a b `{!CoreId b} :
b ≼ a → ●{dq} a ~~> ●{dq} a ⋅ ◯ b.
Proof.
intros Ha%(core_id_extract _ _). apply view_update_dfrac_alloc=> n bf [??].
split; [|done]. rewrite Ha (comm _ a). by apply cmra_monoN_l.
Qed.
Lemma auth_local_update a b0 b1 a' b0' b1' :
(b0, b1) ~l~> (b0', b1') → b0' ≼ a' → ✓ a' →
(● a ⋅ ◯ b0, ● a ⋅ ◯ b1) ~l~> (● a' ⋅ ◯ b0', ● a' ⋅ ◯ b1').
Proof.
intros. apply view_local_update; [done|]=> n [??]. split.
- by apply cmra_included_includedN.
- by apply cmra_valid_validN.
Qed.
End auth.
(** * Functor *)
Program Definition authURF {SI : sidx} (F : urFunctor) : urFunctor := {|
urFunctor_car A _ B _ := authUR (urFunctor_car F A B);
urFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
viewO_map (urFunctor_map F fg) (urFunctor_map F fg)
|}.
Next Obligation.
intros ? F A1 ? A2 ? B1 ? B2 ? n f g Hfg.
apply viewO_map_ne; by apply urFunctor_map_ne.
Qed.
Next Obligation.
intros ? F A ? B ? x; simpl in *. rewrite -{2}(view_map_id x).
apply (view_map_ext _ _ _ _)=> y; apply urFunctor_map_id.
Qed.
Next Obligation.
intros ? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl in *.
rewrite -view_map_compose.
apply (view_map_ext _ _ _ _)=> y; apply urFunctor_map_compose.
Qed.
Next Obligation.
intros ? F A1 ? A2 ? B1 ? B2 ? fg; simpl.
apply view_map_cmra_morphism; [apply _..|]=> n a b [??]; split.
- by apply (cmra_morphism_monotoneN _).
- by apply (cmra_morphism_validN _).
Qed.
Global Instance authURF_contractive {SI : sidx} F :
urFunctorContractive F → urFunctorContractive (authURF F).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg.
apply viewO_map_ne; by apply urFunctor_map_contractive.
Qed.
Program Definition authRF {SI : sidx} (F : urFunctor) : rFunctor := {|
rFunctor_car A _ B _ := authR (urFunctor_car F A B);
rFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
viewO_map (urFunctor_map F fg) (urFunctor_map F fg)
|}.
Solve Obligations with apply @authURF.
Global Instance authRF_contractive {SI : sidx} F :
urFunctorContractive F → rFunctorContractive (authRF F).
Proof. apply authURF_contractive. Qed.
iris/algebra/big_op.v 0 → 100644
View file @ 9f18e97d
From stdpp Require Export functions gmap gmultiset.
From iris.algebra Require Export monoid.
From iris.prelude Require Import options.
Local Existing Instances monoid_ne monoid_assoc monoid_comm
monoid_left_id monoid_right_id monoid_proper
monoid_homomorphism_rel_po monoid_homomorphism_rel_proper
monoid_homomorphism_op_proper
monoid_homomorphism_ne weak_monoid_homomorphism_proper.
(** We define the following big operators with binders build in:
- The operator [ [^o list] k ↦ x ∈ l, P ] folds over a list [l]. The binder [x]
refers to each element at index [k].
- The operator [ [^o map] k ↦ x ∈ m, P ] folds over a map [m]. The binder [x]
refers to each element at index [k].
- The operator [ [^o set] x ∈ X, P ] folds over a set [X]. The binder [x] refers
to each element.
Since these big operators are like quantifiers, they have the same precedence as
[∀] and [∃]. *)
(** * Big ops over lists *)
Fixpoint big_opL {SI : sidx} {M : ofe}
{o : M → M → M} `{!Monoid o} {A} (f : nat → A → M) (xs : list A) : M :=
match xs with
| [] => monoid_unit
| x :: xs => o (f 0 x) (big_opL (λ n, f (S n)) xs)
end.
Global Instance: Params (@big_opL) 5 := {}.
Global Arguments big_opL {SI} {M} o {_ A} _ !_ /.
Global Typeclasses Opaque big_opL.
Notation "'[^' o 'list]' k ↦ x ∈ l , P" := (big_opL o (λ k x, P) l)
(at level 200, o at level 1, l at level 10, k, x at level 1, right associativity,
format "[^ o list] k ↦ x ∈ l , P") : stdpp_scope.
Notation "'[^' o 'list]' x ∈ l , P" := (big_opL o (λ _ x, P) l)
(at level 200, o at level 1, l at level 10, x at level 1, right associativity,
format "[^ o list] x ∈ l , P") : stdpp_scope.
Local Definition big_opM_def {SI : sidx} {M : ofe}
{o : M → M → M} `{!Monoid o} `{Countable K} {A} (f : K → A → M)
(m : gmap K A) : M := big_opL o (λ _, uncurry f) (map_to_list m).
Local Definition big_opM_aux : seal (@big_opM_def). Proof. by eexists. Qed.
Definition big_opM := big_opM_aux.(unseal).
Global Arguments big_opM {SI} {M} o {_ K _ _ A} _ _.
Local Definition big_opM_unseal :
@big_opM = @big_opM_def := big_opM_aux.(seal_eq).
Global Instance: Params (@big_opM) 8 := {}.
Notation "'[^' o 'map]' k ↦ x ∈ m , P" := (big_opM o (λ k x, P) m)
(at level 200, o at level 1, m at level 10, k, x at level 1, right associativity,
format "[^ o map] k ↦ x ∈ m , P") : stdpp_scope.
Notation "'[^' o 'map]' x ∈ m , P" := (big_opM o (λ _ x, P) m)
(at level 200, o at level 1, m at level 10, x at level 1, right associativity,
format "[^ o map] x ∈ m , P") : stdpp_scope.
Local Definition big_opS_def {SI : sidx} {M : ofe}
{o : M → M → M} `{!Monoid o} `{Countable A} (f : A → M)
(X : gset A) : M := big_opL o (λ _, f) (elements X).
Local Definition big_opS_aux : seal (@big_opS_def). Proof. by eexists. Qed.
Definition big_opS := big_opS_aux.(unseal).
Global Arguments big_opS {SI} {M} o {_ A _ _} _ _.
Local Definition big_opS_unseal :
@big_opS = @big_opS_def := big_opS_aux.(seal_eq).
Global Instance: Params (@big_opS) 7 := {}.
Notation "'[^' o 'set]' x ∈ X , P" := (big_opS o (λ x, P) X)
(at level 200, o at level 1, X at level 10, x at level 1, right associativity,
format "[^ o set] x ∈ X , P") : stdpp_scope.
Local Definition big_opMS_def {SI : sidx} {M : ofe}
{o : M → M → M} `{!Monoid o} `{Countable A} (f : A → M)
(X : gmultiset A) : M := big_opL o (λ _, f) (elements X).
Local Definition big_opMS_aux : seal (@big_opMS_def). Proof. by eexists. Qed.
Definition big_opMS := big_opMS_aux.(unseal).
Global Arguments big_opMS {SI} {M} o {_ A _ _} _ _.
Local Definition big_opMS_unseal :
@big_opMS = @big_opMS_def := big_opMS_aux.(seal_eq).
Global Instance: Params (@big_opMS) 8 := {}.
Notation "'[^' o 'mset]' x ∈ X , P" := (big_opMS o (λ x, P) X)
(at level 200, o at level 1, X at level 10, x at level 1, right associativity,
format "[^ o mset] x ∈ X , P") : stdpp_scope.
(** * Properties about big ops *)
Section big_op.
Context {SI : sidx} {M : ofe} {o : M → M → M} `{!Monoid o}.
Implicit Types xs : list M.
Infix "`o`" := o (at level 50, left associativity).
(** ** Big ops over lists *)
Section list.
Context {A : Type}.
Implicit Types l : list A.
Implicit Types f g : nat → A → M.
Lemma big_opL_nil f : ([^o list] k↦y ∈ [], f k y) = monoid_unit.
Proof. done. Qed.
Lemma big_opL_cons f x l :
([^o list] k↦y ∈ x :: l, f k y) = f 0 x `o` [^o list] k↦y ∈ l, f (S k) y.
Proof. done. Qed.
Lemma big_opL_singleton f x : ([^o list] k↦y ∈ [x], f k y) ≡ f 0 x.
Proof. by rewrite /= right_id. Qed.
Lemma big_opL_app f l1 l2 :
([^o list] k↦y ∈ l1 ++ l2, f k y)
≡ ([^o list] k↦y ∈ l1, f k y) `o` ([^o list] k↦y ∈ l2, f (length l1 + k) y).
Proof.
revert f. induction l1 as [|x l1 IH]=> f /=; first by rewrite left_id.
by rewrite IH assoc.
Qed.
Lemma big_opL_snoc f l x :
([^o list] k↦y ∈ l ++ [x], f k y) ≡ ([^o list] k↦y ∈ l, f k y) `o` f (length l) x.
Proof. rewrite big_opL_app big_opL_singleton Nat.add_0_r //. Qed.
Lemma big_opL_unit l : ([^o list] k↦y ∈ l, monoid_unit) ≡ (monoid_unit : M).
Proof. induction l; rewrite /= ?left_id //. Qed.
Lemma big_opL_take_drop Φ l n :
([^o list] k ↦ x ∈ l, Φ k x) ≡
([^o list] k ↦ x ∈ take n l, Φ k x) `o` ([^o list] k ↦ x ∈ drop n l, Φ (n + k) x).
Proof.
rewrite -{1}(take_drop n l) big_opL_app length_take.
destruct (decide (length l ≤ n)).
- rewrite drop_ge //=.
- rewrite Nat.min_l //=; lia.
Qed.
Lemma big_opL_gen_proper_2 {B} (R : relation M) f (g : nat → B → M)
l1 (l2 : list B) :
R monoid_unit monoid_unit →
Proper (R ==> R ==> R) o →
(∀ k,
match l1 !! k, l2 !! k with
| Some y1, Some y2 => R (f k y1) (g k y2)
| None, None => True
| _, _ => False
end) →
R ([^o list] k ↦ y ∈ l1, f k y) ([^o list] k ↦ y ∈ l2, g k y).
Proof.
intros ??. revert l2 f g. induction l1 as [|x1 l1 IH]=> -[|x2 l2] //= f g Hfg.
- by specialize (Hfg 0).
- by specialize (Hfg 0).
- f_equiv; [apply (Hfg 0)|]. apply IH. intros k. apply (Hfg (S k)).
Qed.
Lemma big_opL_gen_proper R f g l :
Reflexive R →
Proper (R ==> R ==> R) o →
(∀ k y, l !! k = Some y → R (f k y) (g k y)) →
R ([^o list] k ↦ y ∈ l, f k y) ([^o list] k ↦ y ∈ l, g k y).
Proof.
intros. apply big_opL_gen_proper_2; [done..|].
intros k. destruct (l !! k) eqn:?; auto.
Qed.
Lemma big_opL_ext f g l :
(∀ k y, l !! k = Some y → f k y = g k y) →
([^o list] k ↦ y ∈ l, f k y) = [^o list] k ↦ y ∈ l, g k y.
Proof. apply big_opL_gen_proper; apply _. Qed.
Lemma big_opL_permutation (f : A → M) l1 l2 :
l1 ≡ₚ l2 → ([^o list] x ∈ l1, f x) ≡ ([^o list] x ∈ l2, f x).
Proof.
induction 1 as [|x xs1 xs2 ? IH|x y xs|xs1 xs2 xs3]; simpl; auto.
- by rewrite IH.
- by rewrite !assoc (comm _ (f x)).
- by etrans.
Qed.
Global Instance big_opL_permutation' (f : A → M) :
Proper ((≡ₚ) ==> (≡)) (big_opL o (λ _, f)).
Proof. intros xs1 xs2. apply big_opL_permutation. Qed.
(** The lemmas [big_opL_ne] and [big_opL_proper] are more generic than the
instances as they also give [l !! k = Some y] in the premise. *)
Lemma big_opL_ne f g l n :
(∀ k y, l !! k = Some y → f k y ≡{n}≡ g k y) →
([^o list] k ↦ y ∈ l, f k y) ≡{n}≡ ([^o list] k ↦ y ∈ l, g k y).
Proof. apply big_opL_gen_proper; apply _. Qed.
Lemma big_opL_proper f g l :
(∀ k y, l !! k = Some y → f k y ≡ g k y) →
([^o list] k ↦ y ∈ l, f k y) ≡ ([^o list] k ↦ y ∈ l, g k y).
Proof. apply big_opL_gen_proper; apply _. Qed.
(** The version [big_opL_proper_2] with [≡] for the list arguments can only be
used if there is a setoid on [A]. The version for [dist n] can be found in
[algebra.list]. We do not define this lemma as a [Proper] instance, since
[f_equiv] will then use sometimes use this one, and other times
[big_opL_proper'], depending on whether a setoid on [A] exists. *)
Lemma big_opL_proper_2 `{!Equiv A} f g l1 l2 :
l1 ≡ l2 →
(∀ k y1 y2,
l1 !! k = Some y1 → l2 !! k = Some y2 → y1 ≡ y2 → f k y1 ≡ g k y2) →
([^o list] k ↦ y ∈ l1, f k y) ≡ ([^o list] k ↦ y ∈ l2, g k y).
Proof.
intros Hl Hf. apply big_opL_gen_proper_2; try (apply _ || done).
(* FIXME (Coq #14441) unnecessary type annotation *)
intros k. assert (l1 !! k ≡@{option A} l2 !! k) as Hlk by (by f_equiv).
destruct (l1 !! k) eqn:?, (l2 !! k) eqn:?; inversion Hlk; naive_solver.
Qed.
Global Instance big_opL_ne' n :
Proper (pointwise_relation _ (pointwise_relation _ (dist n)) ==> (=) ==> dist n)
(big_opL o (A:=A)).
Proof. intros f f' Hf l ? <-. apply big_opL_ne; intros; apply Hf. Qed.
Global Instance big_opL_proper' :
Proper (pointwise_relation _ (pointwise_relation _ (≡)) ==> (=) ==> (≡))
(big_opL o (A:=A)).
Proof. intros f f' Hf l ? <-. apply big_opL_proper; intros; apply Hf. Qed.
Lemma big_opL_consZ_l (f : Z → A → M) x l :
([^o list] k↦y ∈ x :: l, f k y) = f 0 x `o` [^o list] k↦y ∈ l, f (1 + k)%Z y.
Proof. rewrite big_opL_cons. auto using big_opL_ext with f_equal lia. Qed.
Lemma big_opL_consZ_r (f : Z → A → M) x l :
([^o list] k↦y ∈ x :: l, f k y) = f 0 x `o` [^o list] k↦y ∈ l, f (k + 1)%Z y.
Proof. rewrite big_opL_cons. auto using big_opL_ext with f_equal lia. Qed.
Lemma big_opL_fmap {B} (h : A → B) (f : nat → B → M) l :
([^o list] k↦y ∈ h <$> l, f k y) ≡ ([^o list] k↦y ∈ l, f k (h y)).
Proof. revert f. induction l as [|x l IH]=> f; csimpl=> //. by rewrite IH. Qed.
Lemma big_opL_omap {B} (h : A → option B) (f : B → M) l :
([^o list] y ∈ omap h l, f y) ≡ ([^o list] y ∈ l, from_option f monoid_unit (h y)).
Proof.
revert f. induction l as [|x l IH]=> f //; csimpl.
case_match; csimpl; by rewrite IH // left_id.
Qed.
Lemma big_opL_op f g l :
([^o list] k↦x ∈ l, f k x `o` g k x)
≡ ([^o list] k↦x ∈ l, f k x) `o` ([^o list] k↦x ∈ l, g k x).
Proof.
revert f g; induction l as [|x l IH]=> f g /=; first by rewrite left_id.
by rewrite IH -!assoc (assoc _ (g _ _)) [(g _ _ `o` _)]comm -!assoc.
Qed.
(** Shows that some property [P] is closed under [big_opL]. Examples of [P]
are [Persistent], [Affine], [Timeless]. *)
Lemma big_opL_closed (P : M → Prop) f l :
P monoid_unit →
(∀ x y, P x → P y → P (x `o` y)) →
(∀ k x, l !! k = Some x → P (f k x)) →
P ([^o list] k↦x ∈ l, f k x).
Proof.
intros Hunit Hop. revert f. induction l as [|x l IH]=> f Hf /=; [done|].
apply Hop; first by auto. apply IH=> k. apply (Hf (S k)).
Qed.
End list.
Lemma big_opL_bind {A B} (h : A → list B) (f : B → M) l :
([^o list] y ∈ l ≫= h, f y) ≡ ([^o list] x ∈ l, [^o list] y ∈ h x, f y).
Proof.
revert f. induction l as [|x l IH]=> f; csimpl=> //. by rewrite big_opL_app IH.
Qed.
Lemma big_opL_sep_zip_with {A B C} (f : A → B → C) (g1 : C → A) (g2 : C → B)
(h1 : nat → A → M) (h2 : nat → B → M) l1 l2 :
(∀ x y, g1 (f x y) = x) →
(∀ x y, g2 (f x y) = y) →
length l1 = length l2 →
([^o list] k↦xy ∈ zip_with f l1 l2, h1 k (g1 xy) `o` h2 k (g2 xy)) ≡
([^o list] k↦x ∈ l1, h1 k x) `o` ([^o list] k↦y ∈ l2, h2 k y).
Proof.
intros Hlen Hg1 Hg2. rewrite big_opL_op.
rewrite -(big_opL_fmap g1) -(big_opL_fmap g2).
rewrite fmap_zip_with_r; [|auto with lia..].
by rewrite fmap_zip_with_l; [|auto with lia..].
Qed.
Lemma big_opL_sep_zip {A B} (h1 : nat → A → M) (h2 : nat → B → M) l1 l2 :
length l1 = length l2 →
([^o list] k↦xy ∈ zip l1 l2, h1 k xy.1 `o` h2 k xy.2) ≡
([^o list] k↦x ∈ l1, h1 k x) `o` ([^o list] k↦y ∈ l2, h2 k y).
Proof. by apply big_opL_sep_zip_with. Qed.
(** ** Big ops over finite maps *)
Lemma big_opM_empty `{Countable K} {B} (f : K → B → M) :
([^o map] k↦x ∈ ∅, f k x) = monoid_unit.
Proof. by rewrite big_opM_unseal /big_opM_def map_to_list_empty. Qed.
Lemma big_opM_insert `{Countable K} {B} (f : K → B → M) (m : gmap K B) i x :
m !! i = None →
([^o map] k↦y ∈ <[i:=x]> m, f k y) ≡ f i x `o` [^o map] k↦y ∈ m, f k y.
Proof. intros ?. by rewrite big_opM_unseal /big_opM_def map_to_list_insert. Qed.
Lemma big_opM_delete `{Countable K} {B} (f : K → B → M) (m : gmap K B) i x :
m !! i = Some x →
([^o map] k↦y ∈ m, f k y) ≡ f i x `o` [^o map] k↦y ∈ delete i m, f k y.
Proof.
intros. rewrite -big_opM_insert ?lookup_delete //.
by rewrite insert_delete.
Qed.
Section gmap.
Context `{Countable K} {A : Type}.
Implicit Types m : gmap K A.
Implicit Types f g : K → A → M.
Lemma big_opM_gen_proper_2 {B} (R : relation M) f (g : K → B → M)
m1 (m2 : gmap K B) :
subrelation (≡) R → Equivalence R →
Proper (R ==> R ==> R) o →
(∀ k,
match m1 !! k, m2 !! k with
| Some y1, Some y2 => R (f k y1) (g k y2)
| None, None => True
| _, _ => False
end) →
R ([^o map] k ↦ x ∈ m1, f k x) ([^o map] k ↦ x ∈ m2, g k x).
Proof.
intros HR ??. revert m2 f g.
induction m1 as [|k x1 m1 Hm1k IH] using map_ind=> m2 f g Hfg.
{ destruct m2 as [|k x2 m2 _ _] using map_ind.
{ rewrite !big_opM_empty. by apply HR. }
generalize (Hfg k). by rewrite lookup_empty lookup_insert. }
generalize (Hfg k). rewrite lookup_insert.
destruct (m2 !! k) as [x2|] eqn:Hm2k; [intros Hk|done].
etrans; [by apply HR, big_opM_insert|].
etrans; [|by symmetry; apply HR, big_opM_delete].
f_equiv; [done|]. apply IH=> k'. destruct (decide (k = k')) as [->|?].
- by rewrite lookup_delete Hm1k.
- generalize (Hfg k'). rewrite lookup_insert_ne // lookup_delete_ne //.
Qed.
Lemma big_opM_gen_proper R f g m :
Reflexive R →
Proper (R ==> R ==> R) o →
(∀ k x, m !! k = Some x → R (f k x) (g k x)) →
R ([^o map] k ↦ x ∈ m, f k x) ([^o map] k ↦ x ∈ m, g k x).
Proof.
intros ?? Hf. rewrite big_opM_unseal. apply (big_opL_gen_proper R); auto.
intros k [i x] ?%elem_of_list_lookup_2. by apply Hf, elem_of_map_to_list.
Qed.
Lemma big_opM_ext f g m :
(∀ k x, m !! k = Some x → f k x = g k x) →
([^o map] k ↦ x ∈ m, f k x) = ([^o map] k ↦ x ∈ m, g k x).
Proof. apply big_opM_gen_proper; apply _. Qed.
(** The lemmas [big_opM_ne] and [big_opM_proper] are more generic than the
instances as they also give [m !! k = Some y] in the premise. *)
Lemma big_opM_ne f g m n :
(∀ k x, m !! k = Some x → f k x ≡{n}≡ g k x) →
([^o map] k ↦ x ∈ m, f k x) ≡{n}≡ ([^o map] k ↦ x ∈ m, g k x).
Proof. apply big_opM_gen_proper; apply _. Qed.
Lemma big_opM_proper f g m :
(∀ k x, m !! k = Some x → f k x ≡ g k x) →
([^o map] k ↦ x ∈ m, f k x) ≡ ([^o map] k ↦ x ∈ m, g k x).
Proof. apply big_opM_gen_proper; apply _. Qed.
(** The version [big_opM_proper_2] with [≡] for the map arguments can only be
used if there is a setoid on [A]. The version for [dist n] can be found in
[algebra.gmap]. We do not define this lemma as a [Proper] instance, since
[f_equiv] will then use sometimes use this one, and other times
[big_opM_proper'], depending on whether a setoid on [A] exists. *)
Lemma big_opM_proper_2 `{!Equiv A} f g m1 m2 :
m1 ≡ m2 →
(∀ k y1 y2,
m1 !! k = Some y1 → m2 !! k = Some y2 → y1 ≡ y2 → f k y1 ≡ g k y2) →
([^o map] k ↦ y ∈ m1, f k y) ≡ ([^o map] k ↦ y ∈ m2, g k y).
Proof.
intros Hl Hf. apply big_opM_gen_proper_2; try (apply _ || done).
(* FIXME (Coq #14441) unnecessary type annotation *)
intros k. assert (m1 !! k ≡@{option A} m2 !! k) as Hlk by (by f_equiv).
destruct (m1 !! k) eqn:?, (m2 !! k) eqn:?; inversion Hlk; naive_solver.
Qed.
Global Instance big_opM_ne' n :
Proper (pointwise_relation _ (pointwise_relation _ (dist n)) ==> (=) ==> dist n)
(big_opM o (K:=K) (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opM_ne; intros; apply Hf. Qed.
Global Instance big_opM_proper' :
Proper (pointwise_relation _ (pointwise_relation _ (≡)) ==> (=) ==> (≡))
(big_opM o (K:=K) (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opM_proper; intros; apply Hf. Qed.
(* FIXME: This lemma could be generalized from [≡] to [=], but that breaks
[setoid_rewrite] in the proof of [big_sepS_sepS]. See Coq issue #14349. *)
Lemma big_opM_map_to_list f m :
([^o map] k↦x ∈ m, f k x) ≡ [^o list] xk ∈ map_to_list m, f (xk.1) (xk.2).
Proof. rewrite big_opM_unseal. apply big_opL_proper'; [|done]. by intros ? [??]. Qed.
Lemma big_opM_list_to_map f l :
NoDup l.*1 →
([^o map] k↦x ∈ list_to_map l, f k x) ≡ [^o list] xk ∈ l, f (xk.1) (xk.2).
Proof.
intros. rewrite big_opM_map_to_list.
by apply big_opL_permutation, map_to_list_to_map.
Qed.
Lemma big_opM_singleton f i x : ([^o map] k↦y ∈ {[i:=x]}, f k y) ≡ f i x.
Proof.
rewrite -insert_empty big_opM_insert/=; last eauto using lookup_empty.
by rewrite big_opM_empty right_id.
Qed.
Lemma big_opM_unit m : ([^o map] k↦y ∈ m, monoid_unit) ≡ (monoid_unit : M).
Proof.
by induction m using map_ind; rewrite /= ?big_opM_insert ?left_id // big_opM_unseal.
Qed.
Lemma big_opM_fmap {B} (h : A → B) (f : K → B → M) m :
([^o map] k↦y ∈ h <$> m, f k y) ≡ ([^o map] k↦y ∈ m, f k (h y)).
Proof.
rewrite big_opM_unseal /big_opM_def map_to_list_fmap big_opL_fmap.
by apply big_opL_proper=> ? [??].
Qed.
Lemma big_opM_omap {B} (h : A → option B) (f : K → B → M) m :
([^o map] k↦y ∈ omap h m, f k y)
≡ [^o map] k↦y ∈ m, from_option (f k) monoid_unit (h y).
Proof.
revert f. induction m as [|i x m Hmi IH] using map_ind=> f.
{ by rewrite omap_empty !big_opM_empty. }
assert (omap h m !! i = None) by (by rewrite lookup_omap Hmi).
destruct (h x) as [y|] eqn:Hhx.
- by rewrite omap_insert Hhx //= !big_opM_insert // IH Hhx.
- rewrite omap_insert_None // delete_notin // big_opM_insert //.
by rewrite Hhx /= left_id.
Qed.
Lemma big_opM_insert_delete `{Countable K} {B} (f : K → B → M) (m : gmap K B) i x :
([^o map] k↦y ∈ <[i:=x]> m, f k y) ≡ f i x `o` [^o map] k↦y ∈ delete i m, f k y.
Proof.
rewrite -insert_delete_insert big_opM_insert; first done. by rewrite lookup_delete.
Qed.
Lemma big_opM_insert_override (f : K → A → M) m i x x' :
m !! i = Some x → f i x ≡ f i x' →
([^o map] k↦y ∈ <[i:=x']> m, f k y) ≡ ([^o map] k↦y ∈ m, f k y).
Proof.
intros ? Hx. rewrite -insert_delete_insert big_opM_insert ?lookup_delete //.
by rewrite -Hx -big_opM_delete.
Qed.
Lemma big_opM_fn_insert {B} (g : K → A → B → M) (f : K → B) m i (x : A) b :
m !! i = None →
([^o map] k↦y ∈ <[i:=x]> m, g k y (<[i:=b]> f k))
≡ g i x b `o` [^o map] k↦y ∈ m, g k y (f k).
Proof.
intros. rewrite big_opM_insert // fn_lookup_insert.
f_equiv; apply big_opM_proper; auto=> k y ?.
by rewrite fn_lookup_insert_ne; last set_solver.
Qed.
Lemma big_opM_fn_insert' (f : K → M) m i x P :
m !! i = None →
([^o map] k↦y ∈ <[i:=x]> m, <[i:=P]> f k) ≡ (P `o` [^o map] k↦y ∈ m, f k).
Proof. apply (big_opM_fn_insert (λ _ _, id)). Qed.
Lemma big_opM_filter' (φ : K * A → Prop) `{∀ kx, Decision (φ kx)} f m :
([^o map] k ↦ x ∈ filter φ m, f k x)
≡ ([^o map] k ↦ x ∈ m, if decide (φ (k, x)) then f k x else monoid_unit).
Proof.
induction m as [|k v m ? IH] using map_ind.
{ by rewrite map_filter_empty !big_opM_empty. }
destruct (decide (φ (k, v))).
- rewrite map_filter_insert_True //.
assert (filter φ m !! k = None) by (apply map_lookup_filter_None; eauto).
by rewrite !big_opM_insert // decide_True // IH.
- rewrite map_filter_insert_not' //; last by congruence.
rewrite !big_opM_insert // decide_False // IH. by rewrite left_id.
Qed.
Lemma big_opM_union f m1 m2 :
m1 ##ₘ m2 →
([^o map] k↦y ∈ m1 ∪ m2, f k y)
≡ ([^o map] k↦y ∈ m1, f k y) `o` ([^o map] k↦y ∈ m2, f k y).
Proof.
intros. induction m1 as [|i x m ? IH] using map_ind.
{ by rewrite big_opM_empty !left_id. }
decompose_map_disjoint.
rewrite -insert_union_l !big_opM_insert //;
last by apply lookup_union_None.
rewrite -assoc IH //.
Qed.
Lemma big_opM_op f g m :
([^o map] k↦x ∈ m, f k x `o` g k x)
≡ ([^o map] k↦x ∈ m, f k x) `o` ([^o map] k↦x ∈ m, g k x).
Proof.
rewrite big_opM_unseal /big_opM_def -big_opL_op. by apply big_opL_proper=> ? [??].
Qed.
(** Shows that some property [P] is closed under [big_opM]. Examples of [P]
are [Persistent], [Affine], [Timeless]. *)
Lemma big_opM_closed (P : M → Prop) f m :
Proper ((≡) ==> iff) P →
P monoid_unit →
(∀ x y, P x → P y → P (x `o` y)) →
(∀ k x, m !! k = Some x → P (f k x)) →
P ([^o map] k↦x ∈ m, f k x).
Proof.
intros ?? Hop Hf. induction m as [|k x ?? IH] using map_ind.
{ by rewrite big_opM_empty. }
rewrite big_opM_insert //. apply Hop.
{ apply Hf. by rewrite lookup_insert. }
apply IH=> k' x' ?. apply Hf. rewrite lookup_insert_ne; naive_solver.
Qed.
End gmap.
Lemma big_opM_sep_zip_with `{Countable K} {A B C}
(f : A → B → C) (g1 : C → A) (g2 : C → B)
(h1 : K → A → M) (h2 : K → B → M) m1 m2 :
(∀ x y, g1 (f x y) = x) →
(∀ x y, g2 (f x y) = y) →
(∀ k, is_Some (m1 !! k) ↔ is_Some (m2 !! k)) →
([^o map] k↦xy ∈ map_zip_with f m1 m2, h1 k (g1 xy) `o` h2 k (g2 xy)) ≡
([^o map] k↦x ∈ m1, h1 k x) `o` ([^o map] k↦y ∈ m2, h2 k y).
Proof.
intros Hdom Hg1 Hg2. rewrite big_opM_op.
rewrite -(big_opM_fmap g1) -(big_opM_fmap g2).
rewrite map_fmap_zip_with_r; [|naive_solver..].
by rewrite map_fmap_zip_with_l; [|naive_solver..].
Qed.
Lemma big_opM_sep_zip `{Countable K} {A B}
(h1 : K → A → M) (h2 : K → B → M) m1 m2 :
(∀ k, is_Some (m1 !! k) ↔ is_Some (m2 !! k)) →
([^o map] k↦xy ∈ map_zip m1 m2, h1 k xy.1 `o` h2 k xy.2) ≡
([^o map] k↦x ∈ m1, h1 k x) `o` ([^o map] k↦y ∈ m2, h2 k y).
Proof. intros. by apply big_opM_sep_zip_with. Qed.
(** ** Big ops over finite sets *)
Section gset.
Context `{Countable A}.
Implicit Types X : gset A.
Implicit Types f : A → M.
Lemma big_opS_gen_proper R f g X :
Reflexive R → Proper (R ==> R ==> R) o →
(∀ x, x ∈ X → R (f x) (g x)) →
R ([^o set] x ∈ X, f x) ([^o set] x ∈ X, g x).
Proof.
rewrite big_opS_unseal. intros ?? Hf. apply (big_opL_gen_proper R); auto.
intros k x ?%elem_of_list_lookup_2. by apply Hf, elem_of_elements.
Qed.
Lemma big_opS_ext f g X :
(∀ x, x ∈ X → f x = g x) →
([^o set] x ∈ X, f x) = ([^o set] x ∈ X, g x).
Proof. apply big_opS_gen_proper; apply _. Qed.
(** The lemmas [big_opS_ne] and [big_opS_proper] are more generic than the
instances as they also give [x ∈ X] in the premise. *)
Lemma big_opS_ne f g X n :
(∀ x, x ∈ X → f x ≡{n}≡ g x) →
([^o set] x ∈ X, f x) ≡{n}≡ ([^o set] x ∈ X, g x).
Proof. apply big_opS_gen_proper; apply _. Qed.
Lemma big_opS_proper f g X :
(∀ x, x ∈ X → f x ≡ g x) →
([^o set] x ∈ X, f x) ≡ ([^o set] x ∈ X, g x).
Proof. apply big_opS_gen_proper; apply _. Qed.
Global Instance big_opS_ne' n :
Proper (pointwise_relation _ (dist n) ==> (=) ==> dist n) (big_opS o (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opS_ne; intros; apply Hf. Qed.
Global Instance big_opS_proper' :
Proper (pointwise_relation _ (≡) ==> (=) ==> (≡)) (big_opS o (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opS_proper; intros; apply Hf. Qed.
(* FIXME: This lemma could be generalized from [≡] to [=], but that breaks
[setoid_rewrite] in the proof of [big_sepS_sepS]. See Coq issue #14349. *)
Lemma big_opS_elements f X :
([^o set] x ∈ X, f x) ≡ [^o list] x ∈ elements X, f x.
Proof. by rewrite big_opS_unseal. Qed.
Lemma big_opS_empty f : ([^o set] x ∈ ∅, f x) = monoid_unit.
Proof. by rewrite big_opS_unseal /big_opS_def elements_empty. Qed.
Lemma big_opS_insert f X x :
x ∉ X → ([^o set] y ∈ {[ x ]} ∪ X, f y) ≡ (f x `o` [^o set] y ∈ X, f y).
Proof. intros. by rewrite !big_opS_elements elements_union_singleton. Qed.
Lemma big_opS_fn_insert {B} (f : A → B → M) h X x b :
x ∉ X →
([^o set] y ∈ {[ x ]} ∪ X, f y (<[x:=b]> h y))
≡ f x b `o` [^o set] y ∈ X, f y (h y).
Proof.
intros. rewrite big_opS_insert // fn_lookup_insert.
f_equiv; apply big_opS_proper; auto=> y ?.
by rewrite fn_lookup_insert_ne; last set_solver.
Qed.
Lemma big_opS_fn_insert' f X x P :
x ∉ X → ([^o set] y ∈ {[ x ]} ∪ X, <[x:=P]> f y) ≡ (P `o` [^o set] y ∈ X, f y).
Proof. apply (big_opS_fn_insert (λ y, id)). Qed.
Lemma big_opS_union f X Y :
X ## Y →
([^o set] y ∈ X ∪ Y, f y) ≡ ([^o set] y ∈ X, f y) `o` ([^o set] y ∈ Y, f y).
Proof.
intros. induction X as [|x X ? IH] using set_ind_L.
{ by rewrite left_id_L big_opS_empty left_id. }
rewrite -assoc_L !big_opS_insert; [|set_solver..].
by rewrite -assoc IH; last set_solver.
Qed.
Lemma big_opS_delete f X x :
x ∈ X → ([^o set] y ∈ X, f y) ≡ f x `o` [^o set] y ∈ X ∖ {[ x ]}, f y.
Proof.
intros. rewrite -big_opS_insert; last set_solver.
by rewrite -union_difference_L; last set_solver.
Qed.
Lemma big_opS_singleton f x : ([^o set] y ∈ {[ x ]}, f y) ≡ f x.
Proof. intros. by rewrite big_opS_elements elements_singleton /= right_id. Qed.
Lemma big_opS_unit X : ([^o set] y ∈ X, monoid_unit) ≡ (monoid_unit : M).
Proof.
by induction X using set_ind_L; rewrite /= ?big_opS_insert ?left_id // big_opS_unseal.
Qed.
Lemma big_opS_filter' (φ : A → Prop) `{∀ x, Decision (φ x)} f X :
([^o set] y ∈ filter φ X, f y)
≡ ([^o set] y ∈ X, if decide (φ y) then f y else monoid_unit).
Proof.
induction X as [|x X ? IH] using set_ind_L.
{ by rewrite filter_empty_L !big_opS_empty. }
destruct (decide (φ x)).
- rewrite filter_union_L filter_singleton_L //.
rewrite !big_opS_insert //; last set_solver.
by rewrite decide_True // IH.
- rewrite filter_union_L filter_singleton_not_L // left_id_L.
by rewrite !big_opS_insert // decide_False // IH left_id.
Qed.
Lemma big_opS_op f g X :
([^o set] y ∈ X, f y `o` g y) ≡ ([^o set] y ∈ X, f y) `o` ([^o set] y ∈ X, g y).
Proof. by rewrite !big_opS_elements -big_opL_op. Qed.
Lemma big_opS_list_to_set f (l : list A) :
NoDup l →
([^o set] x ∈ list_to_set l, f x) ≡ [^o list] x ∈ l, f x.
Proof.
induction 1 as [|x l ?? IHl].
- rewrite big_opS_empty //.
- rewrite /= big_opS_union; last set_solver.
by rewrite big_opS_singleton IHl.
Qed.
(** Shows that some property [P] is closed under [big_opS]. Examples of [P]
are [Persistent], [Affine], [Timeless]. *)
Lemma big_opS_closed (P : M → Prop) f X :
Proper ((≡) ==> iff) P →
P monoid_unit →
(∀ x y, P x → P y → P (x `o` y)) →
(∀ x, x ∈ X → P (f x)) →
P ([^o set] x ∈ X, f x).
Proof.
intros ?? Hop Hf. induction X as [|x X ? IH] using set_ind_L.
{ by rewrite big_opS_empty. }
rewrite big_opS_insert //. apply Hop.
{ apply Hf. set_solver. }
apply IH=> x' ?. apply Hf. set_solver.
Qed.
End gset.
Lemma big_opS_set_map `{Countable A, Countable B} (h : A → B) (X : gset A) (f : B → M) :
Inj (=) (=) h →
([^o set] x ∈ set_map h X, f x) ≡ ([^o set] x ∈ X, f (h x)).
Proof.
intros Hinj.
induction X as [|x X ? IH] using set_ind_L.
{ by rewrite set_map_empty !big_opS_empty. }
rewrite set_map_union_L set_map_singleton_L.
rewrite !big_opS_union; [|set_solver..].
rewrite !big_opS_singleton IH //.
Qed.
Lemma big_opM_dom `{Countable K} {A} (f : K → M) (m : gmap K A) :
([^o map] k↦_ ∈ m, f k) ≡ ([^o set] k ∈ dom m, f k).
Proof.
induction m as [|i x ?? IH] using map_ind.
{ by rewrite big_opM_unseal big_opS_unseal dom_empty_L. }
by rewrite dom_insert_L big_opM_insert // IH big_opS_insert ?not_elem_of_dom.
Qed.
Lemma big_opM_gset_to_gmap `{Countable K} {A} (f : K → A → M) (X : gset K) c :
([^o map] k↦a ∈ gset_to_gmap c X, f k a) ≡ ([^o set] k ∈ X, f k c).
Proof.
rewrite -{2}(dom_gset_to_gmap X c) -big_opM_dom.
apply big_opM_proper. by intros k ? [_ ->]%lookup_gset_to_gmap_Some.
Qed.
(** ** Big ops over finite msets *)
Section gmultiset.
Context `{Countable A}.
Implicit Types X : gmultiset A.
Implicit Types f : A → M.
Lemma big_opMS_gen_proper R f g X :
Reflexive R → Proper (R ==> R ==> R) o →
(∀ x, x ∈ X → R (f x) (g x)) →
R ([^o mset] x ∈ X, f x) ([^o mset] x ∈ X, g x).
Proof.
rewrite big_opMS_unseal. intros ?? Hf. apply (big_opL_gen_proper R); auto.
intros k x ?%elem_of_list_lookup_2. by apply Hf, gmultiset_elem_of_elements.
Qed.
Lemma big_opMS_ext f g X :
(∀ x, x ∈ X → f x = g x) →
([^o mset] x ∈ X, f x) = ([^o mset] x ∈ X, g x).
Proof. apply big_opMS_gen_proper; apply _. Qed.
(** The lemmas [big_opMS_ne] and [big_opMS_proper] are more generic than the
instances as they also give [x ∈ X] in the premise. *)
Lemma big_opMS_ne f g X n :
(∀ x, x ∈ X → f x ≡{n}≡ g x) →
([^o mset] x ∈ X, f x) ≡{n}≡ ([^o mset] x ∈ X, g x).
Proof. apply big_opMS_gen_proper; apply _. Qed.
Lemma big_opMS_proper f g X :
(∀ x, x ∈ X → f x ≡ g x) →
([^o mset] x ∈ X, f x) ≡ ([^o mset] x ∈ X, g x).
Proof. apply big_opMS_gen_proper; apply _. Qed.
Global Instance big_opMS_ne' n :
Proper (pointwise_relation _ (dist n) ==> (=) ==> dist n) (big_opMS o (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opMS_ne; intros; apply Hf. Qed.
Global Instance big_opMS_proper' :
Proper (pointwise_relation _ (≡) ==> (=) ==> (≡)) (big_opMS o (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opMS_proper; intros; apply Hf. Qed.
(* FIXME: This lemma could be generalized from [≡] to [=], but that breaks
[setoid_rewrite] in the proof of [big_sepS_sepS]. See Coq issue #14349. *)
Lemma big_opMS_elements f X :
([^o mset] x ∈ X, f x) ≡ [^o list] x ∈ elements X, f x.
Proof. by rewrite big_opMS_unseal. Qed.
Lemma big_opMS_empty f : ([^o mset] x ∈ ∅, f x) = monoid_unit.
Proof. by rewrite big_opMS_unseal /big_opMS_def gmultiset_elements_empty. Qed.
Lemma big_opMS_disj_union f X Y :
([^o mset] y ∈ X ⊎ Y, f y) ≡ ([^o mset] y ∈ X, f y) `o` [^o mset] y ∈ Y, f y.
Proof. by rewrite big_opMS_unseal /big_opMS_def gmultiset_elements_disj_union big_opL_app. Qed.
Lemma big_opMS_singleton f x : ([^o mset] y ∈ {[+ x +]}, f y) ≡ f x.
Proof.
intros. by rewrite big_opMS_unseal /big_opMS_def gmultiset_elements_singleton /= right_id.
Qed.
Lemma big_opMS_insert f X x :
([^o mset] y ∈ {[+ x +]} ⊎ X, f y) ≡ (f x `o` [^o mset] y ∈ X, f y).
Proof. intros. rewrite big_opMS_disj_union big_opMS_singleton //. Qed.
Lemma big_opMS_delete f X x :
x ∈ X → ([^o mset] y ∈ X, f y) ≡ f x `o` [^o mset] y ∈ X ∖ {[+ x +]}, f y.
Proof.
intros. rewrite -big_opMS_singleton -big_opMS_disj_union.
by rewrite -gmultiset_disj_union_difference'.
Qed.
Lemma big_opMS_unit X : ([^o mset] y ∈ X, monoid_unit) ≡ (monoid_unit : M).
Proof.
by induction X using gmultiset_ind;
rewrite /= ?big_opMS_disj_union ?big_opMS_singleton ?left_id // big_opMS_unseal.
Qed.
Lemma big_opMS_op f g X :
([^o mset] y ∈ X, f y `o` g y) ≡ ([^o mset] y ∈ X, f y) `o` ([^o mset] y ∈ X, g y).
Proof. by rewrite big_opMS_unseal /big_opMS_def -big_opL_op. Qed.
(** Shows that some property [P] is closed under [big_opMS]. Examples of [P]
are [Persistent], [Affine], [Timeless]. *)
Lemma big_opMS_closed (P : M → Prop) f X :
Proper ((≡) ==> iff) P →
P monoid_unit →
(∀ x y, P x → P y → P (x `o` y)) →
(∀ x, x ∈ X → P (f x)) →
P ([^o mset] x ∈ X, f x).
Proof.
intros ?? Hop Hf. induction X as [|x X IH] using gmultiset_ind.
{ by rewrite big_opMS_empty. }
rewrite big_opMS_insert //. apply Hop.
{ apply Hf. set_solver. }
apply IH=> x' ?. apply Hf. set_solver.
Qed.
End gmultiset.
(** Commuting lemmas *)
Lemma big_opL_opL {A B} (f : nat → A → nat → B → M) (l1 : list A) (l2 : list B) :
([^o list] k1↦x1 ∈ l1, [^o list] k2↦x2 ∈ l2, f k1 x1 k2 x2) ≡
([^o list] k2↦x2 ∈ l2, [^o list] k1↦x1 ∈ l1, f k1 x1 k2 x2).
Proof.
revert f l2. induction l1 as [|x1 l1 IH]; simpl; intros Φ l2.
{ by rewrite big_opL_unit. }
by rewrite IH big_opL_op.
Qed.
Lemma big_opL_opM {A} `{Countable K} {B}
(f : nat → A → K → B → M) (l1 : list A) (m2 : gmap K B) :
([^o list] k1↦x1 ∈ l1, [^o map] k2↦x2 ∈ m2, f k1 x1 k2 x2) ≡
([^o map] k2↦x2 ∈ m2, [^o list] k1↦x1 ∈ l1, f k1 x1 k2 x2).
Proof. repeat setoid_rewrite big_opM_map_to_list. by rewrite big_opL_opL. Qed.
Lemma big_opL_opS {A} `{Countable B}
(f : nat → A → B → M) (l1 : list A) (X2 : gset B) :
([^o list] k1↦x1 ∈ l1, [^o set] x2 ∈ X2, f k1 x1 x2) ≡
([^o set] x2 ∈ X2, [^o list] k1↦x1 ∈ l1, f k1 x1 x2).
Proof. repeat setoid_rewrite big_opS_elements. by rewrite big_opL_opL. Qed.
Lemma big_opL_opMS {A} `{Countable B}
(f : nat → A → B → M) (l1 : list A) (X2 : gmultiset B) :
([^o list] k1↦x1 ∈ l1, [^o mset] x2 ∈ X2, f k1 x1 x2) ≡
([^o mset] x2 ∈ X2, [^o list] k1↦x1 ∈ l1, f k1 x1 x2).
Proof. repeat setoid_rewrite big_opMS_elements. by rewrite big_opL_opL. Qed.
Lemma big_opM_opL {A} `{Countable K} {B}
(f : K → A → nat → B → M) (m1 : gmap K A) (l2 : list B) :
([^o map] k1↦x1 ∈ m1, [^o list] k2↦x2 ∈ l2, f k1 x1 k2 x2) ≡
([^o list] k2↦x2 ∈ l2, [^o map] k1↦x1 ∈ m1, f k1 x1 k2 x2).
Proof. symmetry. apply big_opL_opM. Qed.
Lemma big_opM_opM `{Countable K1} {A} `{Countable K2} {B}
(f : K1 → A → K2 → B → M) (m1 : gmap K1 A) (m2 : gmap K2 B) :
([^o map] k1↦x1 ∈ m1, [^o map] k2↦x2 ∈ m2, f k1 x1 k2 x2) ≡
([^o map] k2↦x2 ∈ m2, [^o map] k1↦x1 ∈ m1, f k1 x1 k2 x2).
Proof. repeat setoid_rewrite big_opM_map_to_list. by rewrite big_opL_opL. Qed.
Lemma big_opM_opS `{Countable K} {A} `{Countable B}
(f : K → A → B → M) (m1 : gmap K A) (X2 : gset B) :
([^o map] k1↦x1 ∈ m1, [^o set] x2 ∈ X2, f k1 x1 x2) ≡
([^o set] x2 ∈ X2, [^o map] k1↦x1 ∈ m1, f k1 x1 x2).
Proof.
repeat setoid_rewrite big_opM_map_to_list.
repeat setoid_rewrite big_opS_elements. by rewrite big_opL_opL.
Qed.
Lemma big_opM_opMS `{Countable K} {A} `{Countable B} (f : K → A → B → M)
(m1 : gmap K A) (X2 : gmultiset B) :
([^o map] k1↦x1 ∈ m1, [^o mset] x2 ∈ X2, f k1 x1 x2) ≡
([^o mset] x2 ∈ X2, [^o map] k1↦x1 ∈ m1, f k1 x1 x2).
Proof.
repeat setoid_rewrite big_opM_map_to_list.
repeat setoid_rewrite big_opMS_elements. by rewrite big_opL_opL.
Qed.
Lemma big_opS_opL `{Countable A} {B}
(f : A → nat → B → M) (X1 : gset A) (l2 : list B) :
([^o set] x1 ∈ X1, [^o list] k2↦x2 ∈ l2, f x1 k2 x2) ≡
([^o list] k2↦x2 ∈ l2, [^o set] x1 ∈ X1, f x1 k2 x2).
Proof. symmetry. apply big_opL_opS. Qed.
Lemma big_opS_opM `{Countable A} `{Countable K} {B}
(f : A → K → B → M) (X1 : gset A) (m2 : gmap K B) :
([^o set] x1 ∈ X1, [^o map] k2↦x2 ∈ m2, f x1 k2 x2) ≡
([^o map] k2↦x2 ∈ m2, [^o set] x1 ∈ X1, f x1 k2 x2).
Proof. symmetry. apply big_opM_opS. Qed.
Lemma big_opS_opS `{Countable A, Countable B}
(X : gset A) (Y : gset B) (f : A → B → M) :
([^o set] x ∈ X, [^o set] y ∈ Y, f x y) ≡ ([^o set] y ∈ Y, [^o set] x ∈ X, f x y).
Proof. repeat setoid_rewrite big_opS_elements. by rewrite big_opL_opL. Qed.
Lemma big_opS_opMS `{Countable A, Countable B}
(X : gset A) (Y : gmultiset B) (f : A → B → M) :
([^o set] x ∈ X, [^o mset] y ∈ Y, f x y) ≡ ([^o mset] y ∈ Y, [^o set] x ∈ X, f x y).
Proof.
repeat setoid_rewrite big_opS_elements.
repeat setoid_rewrite big_opMS_elements. by rewrite big_opL_opL.
Qed.
Lemma big_opMS_opL `{Countable A} {B}
(f : A → nat → B → M) (X1 : gmultiset A) (l2 : list B) :
([^o mset] x1 ∈ X1, [^o list] k2↦x2 ∈ l2, f x1 k2 x2) ≡
([^o list] k2↦x2 ∈ l2, [^o mset] x1 ∈ X1, f x1 k2 x2).
Proof. symmetry. apply big_opL_opMS. Qed.
Lemma big_opMS_opM `{Countable A} `{Countable K} {B} (f : A → K → B → M)
(X1 : gmultiset A) (m2 : gmap K B) :
([^o mset] x1 ∈ X1, [^o map] k2↦x2 ∈ m2, f x1 k2 x2) ≡
([^o map] k2↦x2 ∈ m2, [^o mset] x1 ∈ X1, f x1 k2 x2).
Proof. symmetry. apply big_opM_opMS. Qed.
Lemma big_opMS_opS `{Countable A, Countable B}
(X : gmultiset A) (Y : gset B) (f : A → B → M) :
([^o mset] x ∈ X, [^o set] y ∈ Y, f x y) ≡ ([^o set] y ∈ Y, [^o mset] x ∈ X, f x y).
Proof. symmetry. apply big_opS_opMS. Qed.
Lemma big_opMS_opMS `{Countable A, Countable B}
(X : gmultiset A) (Y : gmultiset B) (f : A → B → M) :
([^o mset] x ∈ X, [^o mset] y ∈ Y, f x y) ≡ ([^o mset] y ∈ Y, [^o mset] x ∈ X, f x y).
Proof. repeat setoid_rewrite big_opMS_elements. by rewrite big_opL_opL. Qed.
End big_op.
Section homomorphisms.
Context {SI : sidx} {M1 M2 : ofe}.
Context {o1 : M1 → M1 → M1} {o2 : M2 → M2 → M2} `{!Monoid o1, !Monoid o2}.
Infix "`o1`" := o1 (at level 50, left associativity).
Infix "`o2`" := o2 (at level 50, left associativity).
(** The ssreflect rewrite tactic only works for relations that have a
[RewriteRelation] instance. For the purpose of this section, we want to
rewrite with arbitrary relations, so we declare any relation to be a
[RewriteRelation]. *)
Local Instance: ∀ {A} (R : relation A), RewriteRelation R := {}.
Lemma big_opL_commute {A} (h : M1 → M2) `{!MonoidHomomorphism o1 o2 R h}
(f : nat → A → M1) l :
R (h ([^o1 list] k↦x ∈ l, f k x)) ([^o2 list] k↦x ∈ l, h (f k x)).
Proof.
revert f. induction l as [|x l IH]=> f /=.
- apply monoid_homomorphism_unit.
- by rewrite monoid_homomorphism IH.
Qed.
Lemma big_opL_commute1 {A} (h : M1 → M2) `{!WeakMonoidHomomorphism o1 o2 R h}
(f : nat → A → M1) l :
l ≠ [] → R (h ([^o1 list] k↦x ∈ l, f k x)) ([^o2 list] k↦x ∈ l, h (f k x)).
Proof.
intros ?. revert f. induction l as [|x [|x' l'] IH]=> f //.
- by rewrite !big_opL_singleton.
- by rewrite !(big_opL_cons _ x) monoid_homomorphism IH.
Qed.
Lemma big_opM_commute `{Countable K} {A} (h : M1 → M2)
`{!MonoidHomomorphism o1 o2 R h} (f : K → A → M1) m :
R (h ([^o1 map] k↦x ∈ m, f k x)) ([^o2 map] k↦x ∈ m, h (f k x)).
Proof.
intros. induction m as [|i x m ? IH] using map_ind.
- by rewrite !big_opM_empty monoid_homomorphism_unit.
- by rewrite !big_opM_insert // monoid_homomorphism -IH.
Qed.
Lemma big_opM_commute1 `{Countable K} {A} (h : M1 → M2)
`{!WeakMonoidHomomorphism o1 o2 R h} (f : K → A → M1) m :
m ≠ ∅ → R (h ([^o1 map] k↦x ∈ m, f k x)) ([^o2 map] k↦x ∈ m, h (f k x)).
Proof.
intros. induction m as [|i x m ? IH] using map_ind; [done|].
destruct (decide (m = ∅)) as [->|].
- by rewrite !big_opM_insert // !big_opM_empty !right_id.
- by rewrite !big_opM_insert // monoid_homomorphism -IH //.
Qed.
Lemma big_opS_commute `{Countable A} (h : M1 → M2)
`{!MonoidHomomorphism o1 o2 R h} (f : A → M1) X :
R (h ([^o1 set] x ∈ X, f x)) ([^o2 set] x ∈ X, h (f x)).
Proof.
intros. induction X as [|x X ? IH] using set_ind_L.
- by rewrite !big_opS_empty monoid_homomorphism_unit.
- by rewrite !big_opS_insert // monoid_homomorphism -IH.
Qed.
Lemma big_opS_commute1 `{Countable A} (h : M1 → M2)
`{!WeakMonoidHomomorphism o1 o2 R h} (f : A → M1) X :
X ≠ ∅ → R (h ([^o1 set] x ∈ X, f x)) ([^o2 set] x ∈ X, h (f x)).
Proof.
intros. induction X as [|x X ? IH] using set_ind_L; [done|].
destruct (decide (X = ∅)) as [->|].
- by rewrite !big_opS_insert // !big_opS_empty !right_id.
- by rewrite !big_opS_insert // monoid_homomorphism -IH //.
Qed.
Lemma big_opMS_commute `{Countable A} (h : M1 → M2)
`{!MonoidHomomorphism o1 o2 R h} (f : A → M1) X :
R (h ([^o1 mset] x ∈ X, f x)) ([^o2 mset] x ∈ X, h (f x)).
Proof.
intros. induction X as [|x X IH] using gmultiset_ind.
- by rewrite !big_opMS_empty monoid_homomorphism_unit.
- by rewrite !big_opMS_disj_union !big_opMS_singleton monoid_homomorphism -IH.
Qed.
Lemma big_opMS_commute1 `{Countable A} (h : M1 → M2)
`{!WeakMonoidHomomorphism o1 o2 R h} (f : A → M1) X :
X ≠ ∅ → R (h ([^o1 mset] x ∈ X, f x)) ([^o2 mset] x ∈ X, h (f x)).
Proof.
intros. induction X as [|x X IH] using gmultiset_ind; [done|].
destruct (decide (X = ∅)) as [->|].
- by rewrite !big_opMS_disj_union !big_opMS_singleton !big_opMS_empty !right_id.
- by rewrite !big_opMS_disj_union !big_opMS_singleton monoid_homomorphism -IH //.
Qed.
Context `{!LeibnizEquiv M2}.
Lemma big_opL_commute_L {A} (h : M1 → M2)
`{!MonoidHomomorphism o1 o2 (≡) h} (f : nat → A → M1) l :
h ([^o1 list] k↦x ∈ l, f k x) = ([^o2 list] k↦x ∈ l, h (f k x)).
Proof using Type*. unfold_leibniz. by apply big_opL_commute. Qed.
Lemma big_opL_commute1_L {A} (h : M1 → M2)
`{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : nat → A → M1) l :
l ≠ [] → h ([^o1 list] k↦x ∈ l, f k x) = ([^o2 list] k↦x ∈ l, h (f k x)).
Proof using Type*. unfold_leibniz. by apply big_opL_commute1. Qed.
Lemma big_opM_commute_L `{Countable K} {A} (h : M1 → M2)
`{!MonoidHomomorphism o1 o2 (≡) h} (f : K → A → M1) m :
h ([^o1 map] k↦x ∈ m, f k x) = ([^o2 map] k↦x ∈ m, h (f k x)).
Proof using Type*. unfold_leibniz. by apply big_opM_commute. Qed.
Lemma big_opM_commute1_L `{Countable K} {A} (h : M1 → M2)
`{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : K → A → M1) m :
m ≠ ∅ → h ([^o1 map] k↦x ∈ m, f k x) = ([^o2 map] k↦x ∈ m, h (f k x)).
Proof using Type*. unfold_leibniz. by apply big_opM_commute1. Qed.
Lemma big_opS_commute_L `{Countable A} (h : M1 → M2)
`{!MonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
h ([^o1 set] x ∈ X, f x) = ([^o2 set] x ∈ X, h (f x)).
Proof using Type*. unfold_leibniz. by apply big_opS_commute. Qed.
Lemma big_opS_commute1_L `{ Countable A} (h : M1 → M2)
`{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
X ≠ ∅ → h ([^o1 set] x ∈ X, f x) = ([^o2 set] x ∈ X, h (f x)).
Proof using Type*. intros. rewrite <-leibniz_equiv_iff. by apply big_opS_commute1. Qed.
Lemma big_opMS_commute_L `{Countable A} (h : M1 → M2)
`{!MonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
h ([^o1 mset] x ∈ X, f x) = ([^o2 mset] x ∈ X, h (f x)).
Proof using Type*. unfold_leibniz. by apply big_opMS_commute. Qed.
Lemma big_opMS_commute1_L `{Countable A} (h : M1 → M2)
`{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
X ≠ ∅ → h ([^o1 mset] x ∈ X, f x) = ([^o2 mset] x ∈ X, h (f x)).
Proof using Type*. intros. rewrite <-leibniz_equiv_iff. by apply big_opMS_commute1. Qed.
End homomorphisms.
iris/algebra/cmra.v 0 → 100644
View file @ 9f18e97d
From stdpp Require Import finite.
From iris.algebra Require Export ofe monoid.
From iris.prelude Require Import options.
Local Set Primitive Projections.
Local Open Scope sidx_scope.
Class PCore (A : Type) := pcore : A → option A.
Global Hint Mode PCore ! : typeclass_instances.
Global Instance: Params (@pcore) 2 := {}.
Class Op (A : Type) := op : A → A → A.
Global Hint Mode Op ! : typeclass_instances.
Global Instance: Params (@op) 2 := {}.
Infix "⋅" := op (at level 50, left associativity) : stdpp_scope.
Notation "(⋅)" := op (only parsing) : stdpp_scope.
(* The inclusion quantifies over [A], not [option A]. This means we do not get
reflexivity. However, if we used [option A], the following would no longer
hold:
x ≼ y ↔ x.1 ≼ y.1 ∧ x.2 ≼ y.2
If you need the reflexive closure of the inclusion relation, you can use
[Some a ≼ Some b]. There are various [Some_included] lemmas that help
deal with propositions of this shape.
*)
Definition included {A} `{!Equiv A, !Op A} (x y : A) := ∃ z, y ≡ x ⋅ z.
Infix "≼" := included (at level 70) : stdpp_scope.
Notation "(≼)" := included (only parsing) : stdpp_scope.
Global Hint Extern 0 (_ ≼ _) => reflexivity : core.
Global Instance: Params (@included) 3 := {}.
(** [opM] is used in some lemma statements where [A] has not yet been shown to
be a CMRA, so we define it directly in terms of [Op]. *)
Definition opM `{!Op A} (x : A) (my : option A) :=
match my with Some y => x ⋅ y | None => x end.
Infix "⋅?" := opM (at level 50, left associativity) : stdpp_scope.
Class ValidN {SI : sidx} (A : Type) := validN : SI → A → Prop.
Global Hint Mode ValidN - ! : typeclass_instances.
Global Instance: Params (@validN) 4 := {}.
Notation "✓{ n } x" := (validN n x)
(at level 20, n at next level, format "✓{ n } x").
Class Valid (A : Type) := valid : A → Prop.
Global Hint Mode Valid ! : typeclass_instances.
Global Instance: Params (@valid) 2 := {}.
Notation "✓ x" := (valid x) (at level 20) : stdpp_scope.
Definition includedN {SI : sidx} `{!Dist A, Op A} (n : SI) (x y : A) :=
∃ z, y ≡{n}≡ x ⋅ z.
Notation "x ≼{ n } y" := (includedN n x y)
(at level 70, n at next level, format "x ≼{ n } y") : stdpp_scope.
Global Instance: Params (@includedN) 5 := {}.
Global Hint Extern 0 (_ ≼{_} _) => reflexivity : core.
Section mixin.
Record CmraMixin {SI : sidx} A
`{!Dist A, !Equiv A, !PCore A, !Op A, !Valid A, !ValidN A} := {
(* setoids *)
mixin_cmra_op_ne (x : A) : NonExpansive (op x);
mixin_cmra_pcore_ne n (x y : A) cx :
x ≡{n}≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡{n}≡ cy;
mixin_cmra_validN_ne n : Proper (dist (A := A) n ==> impl) (validN n);
(* valid *)
mixin_cmra_valid_validN (x : A) : ✓ x ↔ ∀ n, ✓{n} x;
mixin_cmra_validN_le n n' (x : A) : ✓{n} x → n' ≤ n → ✓{n'} x;
(* monoid *)
mixin_cmra_assoc : Assoc (≡@{A}) (⋅);
mixin_cmra_comm : Comm (≡@{A}) (⋅);
mixin_cmra_pcore_l (x : A) cx : pcore x = Some cx → cx ⋅ x ≡ x;
mixin_cmra_pcore_idemp (x : A) cx : pcore x = Some cx → pcore cx ≡ Some cx;
mixin_cmra_pcore_mono (x y : A) cx :
x ≼ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼ cy;
mixin_cmra_validN_op_l n (x y : A) : ✓{n} (x ⋅ y) → ✓{n} x;
mixin_cmra_extend n (x y1 y2 : A) :
✓{n} x → x ≡{n}≡ y1 ⋅ y2 →
{ z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{n}≡ y1 ∧ z2 ≡{n}≡ y2 } }
}.
End mixin.
(** Bundled version *)
#[projections(primitive=no)] (* FIXME: making this primitive leads to strange
TC resolution failures in view.v *)
Structure cmra {SI : sidx} := Cmra' {
cmra_car :> Type;
cmra_equiv : Equiv cmra_car;
cmra_dist : Dist cmra_car;
cmra_pcore : PCore cmra_car;
cmra_op : Op cmra_car;
cmra_valid : Valid cmra_car;
cmra_validN : ValidN cmra_car;
cmra_ofe_mixin : OfeMixin cmra_car;
cmra_mixin : CmraMixin cmra_car;
}.
Global Arguments Cmra' {_} _ {_ _ _ _ _ _} _ _.
(* Given [m : CmraMixin A], the notation [Cmra A m] provides a smart
constructor, which uses [ofe_mixin_of A] to infer the canonical OFE mixin of
the type [A], so that it does not have to be given manually. *)
Notation Cmra A m := (Cmra' A (ofe_mixin_of A%type) m) (only parsing).
Global Arguments cmra_car : simpl never.
Global Arguments cmra_equiv : simpl never.
Global Arguments cmra_dist : simpl never.
Global Arguments cmra_pcore : simpl never.
Global Arguments cmra_op : simpl never.
Global Arguments cmra_valid : simpl never.
Global Arguments cmra_validN : simpl never.
Global Arguments cmra_ofe_mixin : simpl never.
Global Arguments cmra_mixin : simpl never.
Add Printing Constructor cmra.
(* FIXME(Coq #6294) : we need the new unification algorithm here. *)
Global Hint Extern 0 (PCore _) => refine (cmra_pcore _); shelve : typeclass_instances.
Global Hint Extern 0 (Op _) => refine (cmra_op _); shelve : typeclass_instances.
Global Hint Extern 0 (Valid _) => refine (cmra_valid _); shelve : typeclass_instances.
Global Hint Extern 0 (ValidN _) => refine (cmra_validN _); shelve : typeclass_instances.
Coercion cmra_ofeO {SI : sidx} (A : cmra) : ofe := Ofe A (cmra_ofe_mixin A).
Canonical Structure cmra_ofeO.
(** As explained more thoroughly in iris#539, Coq can run into trouble when
[cmra] combinators (such as [optionUR]) are stacked and combined with
coercions like [cmra_ofeO]. To partially address this, we give Coq's
type-checker some directions for unfolding, with the Strategy command.
For these structures, we instruct Coq to eagerly _expand_ all projections,
except for the coercion to type (in this case, [cmra_car]), since that causes
problem with canonical structure inference. Additionally, we make Coq
eagerly expand the coercions that go from one structure to another, like
[cmra_ofeO] in this case. *)
Global Strategy expand [cmra_ofeO cmra_equiv cmra_dist cmra_pcore cmra_op
cmra_valid cmra_validN cmra_ofe_mixin cmra_mixin].
Definition cmra_mixin_of' {SI : sidx} A {Ac : cmra}
(f : Ac → A) : CmraMixin Ac := cmra_mixin Ac.
Notation cmra_mixin_of A :=
ltac:(let H := eval hnf in (cmra_mixin_of' A id) in exact H) (only parsing).
(** Lifting properties from the mixin *)
Section cmra_mixin.
Context {SI : sidx} {A : cmra}.
Implicit Types x y : A.
Global Instance cmra_op_ne (x : A) : NonExpansive (op x).
Proof. apply (mixin_cmra_op_ne _ (cmra_mixin A)). Qed.
Lemma cmra_pcore_ne n x y cx :
x ≡{n}≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡{n}≡ cy.
Proof. apply (mixin_cmra_pcore_ne _ (cmra_mixin A)). Qed.
Global Instance cmra_validN_ne n : Proper (dist n ==> impl) (@validN _ A _ n).
Proof. apply (mixin_cmra_validN_ne _ (cmra_mixin A)). Qed.
Lemma cmra_valid_validN x : ✓ x ↔ ∀ n, ✓{n} x.
Proof. apply (mixin_cmra_valid_validN _ (cmra_mixin A)). Qed.
Lemma cmra_validN_le n n' x : ✓{n} x → n' ≤ n → ✓{n'} x.
Proof. apply (mixin_cmra_validN_le _ (cmra_mixin A)). Qed.
Global Instance cmra_assoc : Assoc (≡) (@op A _).
Proof. apply (mixin_cmra_assoc _ (cmra_mixin A)). Qed.
Global Instance cmra_comm : Comm (≡) (@op A _).
Proof. apply (mixin_cmra_comm _ (cmra_mixin A)). Qed.
Lemma cmra_pcore_l x cx : pcore x = Some cx → cx ⋅ x ≡ x.
Proof. apply (mixin_cmra_pcore_l _ (cmra_mixin A)). Qed.
Lemma cmra_pcore_idemp x cx : pcore x = Some cx → pcore cx ≡ Some cx.
Proof. apply (mixin_cmra_pcore_idemp _ (cmra_mixin A)). Qed.
Lemma cmra_pcore_mono x y cx :
x ≼ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼ cy.
Proof. apply (mixin_cmra_pcore_mono _ (cmra_mixin A)). Qed.
Lemma cmra_validN_op_l n x y : ✓{n} (x ⋅ y) → ✓{n} x.
Proof. apply (mixin_cmra_validN_op_l _ (cmra_mixin A)). Qed.
Lemma cmra_extend n x y1 y2 :
✓{n} x → x ≡{n}≡ y1 ⋅ y2 →
{ z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{n}≡ y1 ∧ z2 ≡{n}≡ y2 } }.
Proof. apply (mixin_cmra_extend _ (cmra_mixin A)). Qed.
End cmra_mixin.
(** * CoreId elements *)
Class CoreId {SI : sidx} {A : cmra} (x : A) := core_id : pcore x ≡ Some x.
Global Arguments core_id {_ _} _ {_}.
Global Hint Mode CoreId - + ! : typeclass_instances.
Global Instance: Params (@CoreId) 2 := {}.
(** * Exclusive elements (i.e., elements that cannot have a frame). *)
Class Exclusive {SI : sidx} {A : cmra} (x : A) :=
exclusive0_l y : ✓{0ᵢ} (x ⋅ y) → False.
Global Arguments exclusive0_l {_ _} _ {_} _ _.
Global Hint Mode Exclusive - + ! : typeclass_instances.
Global Instance: Params (@Exclusive) 2 := {}.
(** * Cancelable elements. *)
Class Cancelable {SI : sidx} {A : cmra} (x : A) :=
cancelableN n y z : ✓{n} (x ⋅ y) → x ⋅ y ≡{n}≡ x ⋅ z → y ≡{n}≡ z.
Global Arguments cancelableN {_ _} _ {_} _ _ _ _.
Global Hint Mode Cancelable - + ! : typeclass_instances.
Global Instance: Params (@Cancelable) 2 := {}.
(** * Identity-free elements. *)
Class IdFree {SI : sidx} {A : cmra} (x : A) :=
id_free0_r y : ✓{0ᵢ} x → x ⋅ y ≡{0ᵢ}≡ x → False.
Global Arguments id_free0_r {_ _} _ {_} _ _.
Global Hint Mode IdFree - + ! : typeclass_instances.
Global Instance: Params (@IdFree) 2 := {}.
(** * CMRAs whose core is total *)
Class CmraTotal {SI : sidx} (A : cmra) :=
cmra_total (x : A) : is_Some (pcore x).
Global Hint Mode CmraTotal - ! : typeclass_instances.
(** The function [core] returns a dummy when used on CMRAs without total
core. We only ever use this for [CmraTotal] CMRAs, but it is more convenient
to not require that proof to be able to call this function. *)
Definition core {A} `{!PCore A} (x : A) : A := default x (pcore x).
Global Instance: Params (@core) 2 := {}.
(** * CMRAs with a unit element *)
Class Unit (A : Type) := ε : A.
Global Hint Mode Unit ! : typeclass_instances.
Global Arguments ε {_ _}.
Record UcmraMixin {SI : sidx} A
`{!Dist A, !Equiv A, !PCore A, !Op A, !Valid A, !Unit A} := {
mixin_ucmra_unit_valid : ✓ (ε : A);
mixin_ucmra_unit_left_id : LeftId (≡@{A}) ε (⋅);
mixin_ucmra_pcore_unit : pcore ε ≡@{option A} Some ε
}.
#[projections(primitive=no)] (* FIXME: making this primitive leads to strange
TC resolution failures in view.v *)
Structure ucmra {SI : sidx} := Ucmra' {
ucmra_car :> Type;
ucmra_equiv : Equiv ucmra_car;
ucmra_dist : Dist ucmra_car;
ucmra_pcore : PCore ucmra_car;
ucmra_op : Op ucmra_car;
ucmra_valid : Valid ucmra_car;
ucmra_validN : ValidN ucmra_car;
ucmra_unit : Unit ucmra_car;
ucmra_ofe_mixin : OfeMixin ucmra_car;
ucmra_cmra_mixin : CmraMixin ucmra_car;
ucmra_mixin : UcmraMixin ucmra_car;
}.
Global Arguments Ucmra' {_} _ {_ _ _ _ _ _ _} _ _ _.
Notation Ucmra A m :=
(Ucmra' A (ofe_mixin_of A%type) (cmra_mixin_of A%type) m) (only parsing).
Global Arguments ucmra_car : simpl never.
Global Arguments ucmra_equiv : simpl never.
Global Arguments ucmra_dist : simpl never.
Global Arguments ucmra_pcore : simpl never.
Global Arguments ucmra_op : simpl never.
Global Arguments ucmra_valid : simpl never.
Global Arguments ucmra_validN : simpl never.
Global Arguments ucmra_ofe_mixin : simpl never.
Global Arguments ucmra_cmra_mixin : simpl never.
Global Arguments ucmra_mixin : simpl never.
Add Printing Constructor ucmra.
(* FIXME(Coq #6294) : we need the new unification algorithm here. *)
Global Hint Extern 0 (Unit _) => refine (ucmra_unit _); shelve : typeclass_instances.
Coercion ucmra_ofeO {SI : sidx} (A : ucmra) : ofe := Ofe A (ucmra_ofe_mixin A).
Canonical Structure ucmra_ofeO.
Coercion ucmra_cmraR {SI : sidx} (A : ucmra) : cmra :=
Cmra' A (ucmra_ofe_mixin A) (ucmra_cmra_mixin A).
Canonical Structure ucmra_cmraR.
(** As for CMRAs above, we instruct Coq to eagerly _expand_ all projections,
except for the coercion to type (in this case, [ucmra_car]), since that causes
problem with canonical structure inference. Additionally, we make Coq
eagerly expand the coercions that go from one structure to another, like
[ucmra_cmraR] and [ucmra_ofeO] in this case. *)
Global Strategy expand [ucmra_cmraR ucmra_ofeO ucmra_equiv ucmra_dist ucmra_pcore
ucmra_op ucmra_valid ucmra_validN ucmra_unit
ucmra_ofe_mixin ucmra_cmra_mixin].
(** Lifting properties from the mixin *)
Section ucmra_mixin.
Context {SI : sidx} {A : ucmra}.
Implicit Types x y : A.
Lemma ucmra_unit_valid : ✓ (ε : A).
Proof. apply (mixin_ucmra_unit_valid _ (ucmra_mixin A)). Qed.
Global Instance ucmra_unit_left_id : LeftId (≡) ε (@op A _).
Proof. apply (mixin_ucmra_unit_left_id _ (ucmra_mixin A)). Qed.
Lemma ucmra_pcore_unit : pcore (ε:A) ≡ Some ε.
Proof. apply (mixin_ucmra_pcore_unit _ (ucmra_mixin A)). Qed.
End ucmra_mixin.
(** * Discrete CMRAs *)
#[projections(primitive=no)] (* FIXME: making this primitive means we cannot use
the projections with eauto any more (see https://github.com/coq/coq/issues/17561) *)
Class CmraDiscrete {SI : sidx} (A : cmra) := {
#[global] cmra_discrete_ofe_discrete :: OfeDiscrete A;
cmra_discrete_valid (x : A) : ✓{0ᵢ} x → ✓ x
}.
Global Hint Mode CmraDiscrete - ! : typeclass_instances.
(** * Morphisms *)
Class CmraMorphism {SI : sidx} {A B : cmra} (f : A → B) := {
#[global] cmra_morphism_ne :: NonExpansive f;
cmra_morphism_validN n x : ✓{n} x → ✓{n} f x;
cmra_morphism_pcore x : f <$> pcore x ≡ pcore (f x);
cmra_morphism_op x y : f (x ⋅ y) ≡ f x ⋅ f y
}.
Global Hint Mode CmraMorphism - - - ! : typeclass_instances.
Global Arguments cmra_morphism_validN {_ _ _} _ {_} _ _ _.
Global Arguments cmra_morphism_pcore {_ _ _} _ {_} _.
Global Arguments cmra_morphism_op {_ _ _} _ {_} _ _.
(** * Properties **)
Section cmra.
Context {SI : sidx} {A : cmra}.
Implicit Types x y z : A.
Implicit Types xs ys zs : list A.
(** ** Setoids *)
Global Instance cmra_pcore_ne' : NonExpansive (@pcore A _).
Proof.
intros n x y Hxy. destruct (pcore x) as [cx|] eqn:?.
{ destruct (cmra_pcore_ne n x y cx) as (cy&->&->); auto. }
destruct (pcore y) as [cy|] eqn:?; auto.
destruct (cmra_pcore_ne n y x cy) as (cx&?&->); simplify_eq/=; auto.
Qed.
Lemma cmra_pcore_proper x y cx :
x ≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡ cy.
Proof.
intros. destruct (cmra_pcore_ne 0ᵢ x y cx) as (cy&?&?); auto.
exists cy; split; [done|apply equiv_dist=> n].
destruct (cmra_pcore_ne n x y cx) as (cy'&?&?); naive_solver.
Qed.
Global Instance cmra_pcore_proper' : Proper ((≡) ==> (≡)) (@pcore A _).
Proof. apply (ne_proper _). Qed.
Global Instance cmra_op_ne' : NonExpansive2 (@op A _).
Proof. intros n x1 x2 Hx y1 y2 Hy. by rewrite Hy (comm _ x1) Hx (comm _ y2). Qed.
Global Instance cmra_op_proper' : Proper ((≡) ==> (≡) ==> (≡)) (@op A _).
Proof. apply (ne_proper_2 _). Qed.
Global Instance cmra_validN_ne' n : Proper (dist n ==> iff) (@validN SI A _ n) | 1.
Proof. by split; apply cmra_validN_ne. Qed.
Global Instance cmra_validN_proper n : Proper ((≡) ==> iff) (@validN SI A _ n) | 1.
Proof. by intros x1 x2 Hx; apply cmra_validN_ne', equiv_dist. Qed.
Global Instance cmra_valid_proper : Proper ((≡) ==> iff) (@valid A _).
Proof.
intros x y Hxy; rewrite !cmra_valid_validN.
by split=> ? n; [rewrite -Hxy|rewrite Hxy].
Qed.
Global Instance cmra_includedN_ne n :
Proper (dist n ==> dist n ==> iff) (@includedN SI A _ _ n) | 1.
Proof.
intros x x' Hx y y' Hy.
by split; intros [z ?]; exists z; [rewrite -Hx -Hy|rewrite Hx Hy].
Qed.
Global Instance cmra_includedN_proper n :
Proper ((≡) ==> (≡) ==> iff) (@includedN SI A _ _ n) | 1.
Proof.
intros x x' Hx y y' Hy; revert Hx Hy; rewrite !equiv_dist=> Hx Hy.
by rewrite (Hx n) (Hy n).
Qed.
Global Instance cmra_included_proper :
Proper ((≡) ==> (≡) ==> iff) (@included A _ _) | 1.
Proof.
intros x x' Hx y y' Hy.
by split; intros [z ?]; exists z; [rewrite -Hx -Hy|rewrite Hx Hy].
Qed.
Global Instance cmra_opM_ne : NonExpansive2 (@opM A _).
Proof. destruct 2; by ofe_subst. Qed.
Global Instance cmra_opM_proper : Proper ((≡) ==> (≡) ==> (≡)) (@opM A _).
Proof. destruct 2; by setoid_subst. Qed.
Global Instance CoreId_proper : Proper ((≡) ==> iff) (@CoreId SI A).
Proof. solve_proper. Qed.
Global Instance Exclusive_proper : Proper ((≡) ==> iff) (@Exclusive SI A).
Proof. intros x y Hxy. rewrite /Exclusive. by setoid_rewrite Hxy. Qed.
Global Instance Cancelable_proper : Proper ((≡) ==> iff) (@Cancelable SI A).
Proof. intros x y Hxy. rewrite /Cancelable. by setoid_rewrite Hxy. Qed.
Global Instance IdFree_proper : Proper ((≡) ==> iff) (@IdFree SI A).
Proof. intros x y Hxy. rewrite /IdFree. by setoid_rewrite Hxy. Qed.
(** ** Op *)
Lemma cmra_op_opM_assoc x y mz : (x ⋅ y) ⋅? mz ≡ x ⋅ (y ⋅? mz).
Proof. destruct mz; by rewrite /= -?assoc. Qed.
(** ** Validity *)
Lemma cmra_validN_lt n n' x : ✓{n} x → n' < n → ✓{n'} x.
Proof. eauto using cmra_validN_le, SIdx.lt_le_incl. Qed.
Lemma cmra_valid_op_l x y : ✓ (x ⋅ y) → ✓ x.
Proof. rewrite !cmra_valid_validN; eauto using cmra_validN_op_l. Qed.
Lemma cmra_validN_op_r n x y : ✓{n} (x ⋅ y) → ✓{n} y.
Proof. rewrite (comm _ x); apply cmra_validN_op_l. Qed.
Lemma cmra_valid_op_r x y : ✓ (x ⋅ y) → ✓ y.
Proof. rewrite !cmra_valid_validN; eauto using cmra_validN_op_r. Qed.
(** ** Core *)
Lemma cmra_pcore_l' x cx : pcore x ≡ Some cx → cx ⋅ x ≡ x.
Proof. intros (cx'&?&<-)%Some_equiv_eq. by apply cmra_pcore_l. Qed.
Lemma cmra_pcore_r x cx : pcore x = Some cx → x ⋅ cx ≡ x.
Proof. intros. rewrite comm. by apply cmra_pcore_l. Qed.
Lemma cmra_pcore_r' x cx : pcore x ≡ Some cx → x ⋅ cx ≡ x.
Proof. intros (cx'&?&<-)%Some_equiv_eq. by apply cmra_pcore_r. Qed.
Lemma cmra_pcore_idemp' x cx : pcore x ≡ Some cx → pcore cx ≡ Some cx.
Proof. intros (cx'&?&<-)%Some_equiv_eq. eauto using cmra_pcore_idemp. Qed.
Lemma cmra_pcore_dup x cx : pcore x = Some cx → cx ≡ cx ⋅ cx.
Proof. intros; symmetry; eauto using cmra_pcore_r', cmra_pcore_idemp. Qed.
Lemma cmra_pcore_dup' x cx : pcore x ≡ Some cx → cx ≡ cx ⋅ cx.
Proof. intros; symmetry; eauto using cmra_pcore_r', cmra_pcore_idemp'. Qed.
Lemma cmra_pcore_validN n x cx : ✓{n} x → pcore x = Some cx → ✓{n} cx.
Proof.
intros Hvx Hx%cmra_pcore_l. move: Hvx; rewrite -Hx. apply cmra_validN_op_l.
Qed.
Lemma cmra_pcore_valid x cx : ✓ x → pcore x = Some cx → ✓ cx.
Proof.
intros Hv Hx%cmra_pcore_l. move: Hv; rewrite -Hx. apply cmra_valid_op_l.
Qed.
(** ** Exclusive elements *)
Lemma exclusiveN_l n x `{!Exclusive x} y : ✓{n} (x ⋅ y) → False.
Proof. intros. by eapply (exclusive0_l x y), cmra_validN_le, SIdx.le_0_l. Qed.
Lemma exclusiveN_r n x `{!Exclusive x} y : ✓{n} (y ⋅ x) → False.
Proof. rewrite comm. by apply exclusiveN_l. Qed.
Lemma exclusive_l x `{!Exclusive x} y : ✓ (x ⋅ y) → False.
Proof. by move /cmra_valid_validN /(_ 0ᵢ) /exclusive0_l. Qed.
Lemma exclusive_r x `{!Exclusive x} y : ✓ (y ⋅ x) → False.
Proof. rewrite comm. by apply exclusive_l. Qed.
Lemma exclusiveN_opM n x `{!Exclusive x} my : ✓{n} (x ⋅? my) → my = None.
Proof. destruct my as [y|]; last done. move=> /(exclusiveN_l _ x) []. Qed.
Lemma exclusive_includedN n x `{!Exclusive x} y : x ≼{n} y → ✓{n} y → False.
Proof. intros [? ->]. by apply exclusiveN_l. Qed.
Lemma exclusive_included x `{!Exclusive x} y : x ≼ y → ✓ y → False.
Proof. intros [? ->]. by apply exclusive_l. Qed.
(** ** Order *)
Lemma cmra_included_includedN n x y : x ≼ y → x ≼{n} y.
Proof. intros [z ->]. by exists z. Qed.
Global Instance cmra_includedN_trans n : Transitive (@includedN SI A _ _ n).
Proof.
intros x y z [z1 Hy] [z2 Hz]; exists (z1 ⋅ z2). by rewrite assoc -Hy -Hz.
Qed.
Global Instance cmra_included_trans: Transitive (@included A _ _).
Proof.
intros x y z [z1 Hy] [z2 Hz]; exists (z1 ⋅ z2). by rewrite assoc -Hy -Hz.
Qed.
Lemma cmra_valid_included x y : ✓ y → x ≼ y → ✓ x.
Proof. intros Hyv [z ?]; setoid_subst; eauto using cmra_valid_op_l. Qed.
Lemma cmra_validN_includedN n x y : ✓{n} y → x ≼{n} y → ✓{n} x.
Proof. intros Hyv [z ?]; ofe_subst y; eauto using cmra_validN_op_l. Qed.
Lemma cmra_validN_included n x y : ✓{n} y → x ≼ y → ✓{n} x.
Proof. intros Hyv [z ?]; setoid_subst; eauto using cmra_validN_op_l. Qed.
Lemma cmra_includedN_le n m x y : x ≼{n} y → m ≤ n → x ≼{m} y.
Proof. by intros [z Hz] H; exists z; eapply dist_le. Qed.
Lemma cmra_includedN_S n x y : x ≼{Sᵢ n} y → x ≼{n} y.
Proof. intros ?. by eapply cmra_includedN_le, SIdx.le_succ_diag_r. Qed.
Lemma cmra_includedN_l n x y : x ≼{n} x ⋅ y.
Proof. by exists y. Qed.
Lemma cmra_included_l x y : x ≼ x ⋅ y.
Proof. by exists y. Qed.
Lemma cmra_includedN_r n x y : y ≼{n} x ⋅ y.
Proof. rewrite (comm op); apply cmra_includedN_l. Qed.
Lemma cmra_included_r x y : y ≼ x ⋅ y.
Proof. rewrite (comm op); apply cmra_included_l. Qed.
Lemma cmra_pcore_mono' x y cx :
x ≼ y → pcore x ≡ Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼ cy.
Proof.
intros ? (cx'&?&Hcx)%Some_equiv_eq.
destruct (cmra_pcore_mono x y cx') as (cy&->&?); auto.
exists cy; by rewrite -Hcx.
Qed.
Lemma cmra_pcore_monoN' n x y cx :
x ≼{n} y → pcore x ≡{n}≡ Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼{n} cy.
Proof.
intros [z Hy] (cx'&?&Hcx)%dist_Some_inv_r'.
destruct (cmra_pcore_mono x (x ⋅ z) cx')
as (cy&Hxy&?); auto using cmra_included_l.
assert (pcore y ≡{n}≡ Some cy) as (cy'&?&Hcy')%dist_Some_inv_r'.
{ by rewrite Hy Hxy. }
exists cy'; split; first done.
rewrite Hcx -Hcy'; auto using cmra_included_includedN.
Qed.
Lemma cmra_included_pcore x cx : pcore x = Some cx → cx ≼ x.
Proof. exists x. by rewrite cmra_pcore_l. Qed.
Lemma cmra_monoN_l n x y z : x ≼{n} y → z ⋅ x ≼{n} z ⋅ y.
Proof. by intros [z1 Hz1]; exists z1; rewrite Hz1 (assoc op). Qed.
Lemma cmra_mono_l x y z : x ≼ y → z ⋅ x ≼ z ⋅ y.
Proof. by intros [z1 Hz1]; exists z1; rewrite Hz1 (assoc op). Qed.
Lemma cmra_monoN_r n x y z : x ≼{n} y → x ⋅ z ≼{n} y ⋅ z.
Proof. by intros; rewrite -!(comm _ z); apply cmra_monoN_l. Qed.
Lemma cmra_mono_r x y z : x ≼ y → x ⋅ z ≼ y ⋅ z.
Proof. by intros; rewrite -!(comm _ z); apply cmra_mono_l. Qed.
Lemma cmra_monoN n x1 x2 y1 y2 : x1 ≼{n} y1 → x2 ≼{n} y2 → x1 ⋅ x2 ≼{n} y1 ⋅ y2.
Proof. intros; etrans; eauto using cmra_monoN_l, cmra_monoN_r. Qed.
Lemma cmra_mono x1 x2 y1 y2 : x1 ≼ y1 → x2 ≼ y2 → x1 ⋅ x2 ≼ y1 ⋅ y2.
Proof. intros; etrans; eauto using cmra_mono_l, cmra_mono_r. Qed.
Global Instance cmra_monoN' n :
Proper (includedN n ==> includedN n ==> includedN n) (@op A _).
Proof. intros x1 x2 Hx y1 y2 Hy. by apply cmra_monoN. Qed.
Global Instance cmra_mono' :
Proper (included ==> included ==> included) (@op A _).
Proof. intros x1 x2 Hx y1 y2 Hy. by apply cmra_mono. Qed.
Lemma cmra_included_dist_l n x1 x2 x1' :
x1 ≼ x2 → x1' ≡{n}≡ x1 → ∃ x2', x1' ≼ x2' ∧ x2' ≡{n}≡ x2.
Proof.
intros [z Hx2] Hx1; exists (x1' ⋅ z); split; auto using cmra_included_l.
by rewrite Hx1 Hx2.
Qed.
(** ** CoreId elements *)
Lemma core_id_dup x `{!CoreId x} : x ≡ x ⋅ x.
Proof. by apply cmra_pcore_dup' with x. Qed.
Lemma core_id_extract x y `{!CoreId x} :
x ≼ y → y ≡ y ⋅ x.
Proof.
intros ?.
destruct (cmra_pcore_mono' x y x) as (cy & Hcy & [x' Hx']); [done|exact: core_id|].
rewrite -(cmra_pcore_r y) //. rewrite Hx' -!assoc. f_equiv.
rewrite [x' ⋅ x]comm assoc -core_id_dup. done.
Qed.
(** ** Total core *)
Section total_core.
Local Set Default Proof Using "Type*".
Context `{!CmraTotal A}.
Lemma cmra_pcore_core x : pcore x = Some (core x).
Proof.
rewrite /core. destruct (cmra_total x) as [cx ->]. done.
Qed.
Lemma cmra_core_l x : core x ⋅ x ≡ x.
Proof.
destruct (cmra_total x) as [cx Hcx]. by rewrite /core /= Hcx cmra_pcore_l.
Qed.
Lemma cmra_core_idemp x : core (core x) ≡ core x.
Proof.
destruct (cmra_total x) as [cx Hcx]. by rewrite /core /= Hcx cmra_pcore_idemp.
Qed.
Lemma cmra_core_mono x y : x ≼ y → core x ≼ core y.
Proof.
intros; destruct (cmra_total x) as [cx Hcx].
destruct (cmra_pcore_mono x y cx) as (cy&Hcy&?); auto.
by rewrite /core /= Hcx Hcy.
Qed.
Global Instance cmra_core_ne : NonExpansive (@core A _).
Proof.
intros n x y Hxy. destruct (cmra_total x) as [cx Hcx].
by rewrite /core /= -Hxy Hcx.
Qed.
Global Instance cmra_core_proper : Proper ((≡) ==> (≡)) (@core A _).
Proof. apply (ne_proper _). Qed.
Lemma cmra_core_r x : x ⋅ core x ≡ x.
Proof. by rewrite (comm _ x) cmra_core_l. Qed.
Lemma cmra_core_dup x : core x ≡ core x ⋅ core x.
Proof. by rewrite -{3}(cmra_core_idemp x) cmra_core_r. Qed.
Lemma cmra_core_validN n x : ✓{n} x → ✓{n} core x.
Proof. rewrite -{1}(cmra_core_l x); apply cmra_validN_op_l. Qed.
Lemma cmra_core_valid x : ✓ x → ✓ core x.
Proof. rewrite -{1}(cmra_core_l x); apply cmra_valid_op_l. Qed.
Lemma core_id_total x : CoreId x ↔ core x ≡ x.
Proof.
split; [intros; by rewrite /core /= (core_id x)|].
rewrite /CoreId /core /=.
destruct (cmra_total x) as [? ->]. by constructor.
Qed.
Lemma core_id_core x `{!CoreId x} : core x ≡ x.
Proof. by apply core_id_total. Qed.
(** Not an instance since TC search cannot solve the premise. *)
Lemma cmra_pcore_core_id x y : pcore x = Some y → CoreId y.
Proof. rewrite /CoreId. eauto using cmra_pcore_idemp. Qed.
Global Instance cmra_core_core_id x : CoreId (core x).
Proof. eapply cmra_pcore_core_id. rewrite cmra_pcore_core. done. Qed.
Lemma cmra_included_core x : core x ≼ x.
Proof. by exists x; rewrite cmra_core_l. Qed.
Global Instance cmra_includedN_preorder n : PreOrder (@includedN SI A _ _ n).
Proof.
split; [|apply _]. by intros x; exists (core x); rewrite cmra_core_r.
Qed.
Global Instance cmra_included_preorder : PreOrder (@included A _ _).
Proof.
split; [|apply _]. by intros x; exists (core x); rewrite cmra_core_r.
Qed.
Lemma cmra_core_monoN n x y : x ≼{n} y → core x ≼{n} core y.
Proof.
intros [z ->].
apply cmra_included_includedN, cmra_core_mono, cmra_included_l.
Qed.
End total_core.
(** ** Discrete *)
Lemma cmra_discrete_included_l x y : Discrete x → ✓{0ᵢ} y → x ≼{0ᵢ} y → x ≼ y.
Proof.
intros ?? [x' ?].
destruct (cmra_extend 0ᵢ y x x') as (z&z'&Hy&Hz&Hz'); auto; simpl in *.
by exists z'; rewrite Hy (discrete_0 x z).
Qed.
Lemma cmra_discrete_included_r x y : Discrete y → x ≼{0ᵢ} y → x ≼ y.
Proof. intros ? [x' ?]. exists x'. by apply (discrete_0 y). Qed.
Lemma cmra_op_discrete x1 x2 :
✓{0ᵢ} (x1 ⋅ x2) → Discrete x1 → Discrete x2 → Discrete (x1 ⋅ x2).
Proof.
intros ??? z Hz.
destruct (cmra_extend 0ᵢ z x1 x2) as (y1&y2&Hz'&?&?); auto; simpl in *.
{ rewrite -?Hz. done. }
by rewrite Hz' (discrete_0 x1 y1) // (discrete_0 x2 y2).
Qed.
(** ** Discrete *)
Lemma cmra_discrete_valid_iff `{!CmraDiscrete A} n x : ✓ x ↔ ✓{n} x.
Proof.
split; first by rewrite cmra_valid_validN.
eauto using cmra_discrete_valid, cmra_validN_le, SIdx.le_0_l.
Qed.
Lemma cmra_discrete_valid_iff_0 `{!CmraDiscrete A} n x : ✓{0ᵢ} x ↔ ✓{n} x.
Proof. by rewrite -!cmra_discrete_valid_iff. Qed.
Lemma cmra_discrete_included_iff `{!OfeDiscrete A} n x y : x ≼ y ↔ x ≼{n} y.
Proof.
split; first by apply cmra_included_includedN.
intros [z ->%(discrete_iff _ _)]; eauto using cmra_included_l.
Qed.
Lemma cmra_discrete_included_iff_0 `{!OfeDiscrete A} n x y : x ≼{0ᵢ} y ↔ x ≼{n} y.
Proof. by rewrite -!cmra_discrete_included_iff. Qed.
(** Cancelable elements *)
Global Instance cancelable_proper : Proper (equiv ==> iff) (@Cancelable SI A).
Proof. unfold Cancelable. intros x x' EQ. by setoid_rewrite EQ. Qed.
Lemma cancelable x `{!Cancelable x} y z : ✓(x ⋅ y) → x ⋅ y ≡ x ⋅ z → y ≡ z.
Proof. rewrite !equiv_dist cmra_valid_validN. intros. by apply (cancelableN x). Qed.
Lemma discrete_cancelable x `{!CmraDiscrete A}:
(∀ y z, ✓(x ⋅ y) → x ⋅ y ≡ x ⋅ z → y ≡ z) → Cancelable x.
Proof. intros ????. rewrite -!discrete_iff -cmra_discrete_valid_iff. auto. Qed.
Global Instance cancelable_op x y :
Cancelable x → Cancelable y → Cancelable (x ⋅ y).
Proof.
intros ?? n z z' ??. apply (cancelableN y), (cancelableN x).
- eapply cmra_validN_op_r. by rewrite assoc.
- by rewrite assoc.
- by rewrite !assoc.
Qed.
Global Instance exclusive_cancelable (x : A) : Exclusive x → Cancelable x.
Proof. intros ? n z z' []%(exclusiveN_l _ x). Qed.
(** Id-free elements *)
Global Instance id_free_ne n : Proper (dist n ==> iff) (@IdFree SI A).
Proof.
intros x x' EQ%(dist_le _ 0ᵢ); [|apply SIdx.le_0_l]. rewrite /IdFree.
split=> y ?; (rewrite -EQ || rewrite EQ); eauto.
Qed.
Global Instance id_free_proper : Proper (equiv ==> iff) (@IdFree SI A).
Proof. by move=> P Q /equiv_dist /(_ 0ᵢ)=> ->. Qed.
Lemma id_freeN_r n n' x `{!IdFree x} y : ✓{n}x → x ⋅ y ≡{n'}≡ x → False.
Proof. eauto using cmra_validN_le, dist_le, SIdx.le_0_l. Qed.
Lemma id_freeN_l n n' x `{!IdFree x} y : ✓{n}x → y ⋅ x ≡{n'}≡ x → False.
Proof. rewrite comm. eauto using id_freeN_r. Qed.
Lemma id_free_r x `{!IdFree x} y : ✓x → x ⋅ y ≡ x → False.
Proof. move=> /cmra_valid_validN ? /equiv_dist. eauto. Qed.
Lemma id_free_l x `{!IdFree x} y : ✓x → y ⋅ x ≡ x → False.
Proof. rewrite comm. eauto using id_free_r. Qed.
Lemma discrete_id_free x `{!CmraDiscrete A}:
(∀ y, ✓ x → x ⋅ y ≡ x → False) → IdFree x.
Proof.
intros Hx y ??. apply (Hx y), (discrete_0 _); eauto using cmra_discrete_valid.
Qed.
Global Instance id_free_op_r x y : IdFree y → Cancelable x → IdFree (x ⋅ y).
Proof.
intros ?? z ? Hid%symmetry. revert Hid. rewrite -assoc=>/(cancelableN x) ?.
eapply (id_free0_r y); [by eapply cmra_validN_op_r |symmetry; eauto].
Qed.
Global Instance id_free_op_l x y : IdFree x → Cancelable y → IdFree (x ⋅ y).
Proof. intros. rewrite comm. apply _. Qed.
Global Instance exclusive_id_free x : Exclusive x → IdFree x.
Proof. intros ? z ? Hid. apply (exclusiveN_l 0ᵢ x z). by rewrite Hid. Qed.
End cmra.
(* We use a [Hint Extern] with [apply:], instead of [Hint Immediate], to invoke
the new unification algorithm. The old unification algorithm sometimes gets
confused by going from [ucmra]'s to [cmra]'s and back. *)
Global Hint Extern 0 (?a ≼ ?a ⋅ _) => apply: cmra_included_l : core.
Global Hint Extern 0 (?a ≼ _ ⋅ ?a) => apply: cmra_included_r : core.
(** * Properties about CMRAs with a unit element **)
Section ucmra.
Context {SI : sidx} {A : ucmra}.
Implicit Types x y z : A.
Lemma ucmra_unit_validN n : ✓{n} (ε:A).
Proof. apply cmra_valid_validN, ucmra_unit_valid. Qed.
Lemma ucmra_unit_leastN n x : ε ≼{n} x.
Proof. by exists x; rewrite left_id. Qed.
Lemma ucmra_unit_least x : ε ≼ x.
Proof. by exists x; rewrite left_id. Qed.
Global Instance ucmra_unit_right_id : RightId (≡) ε (@op A _).
Proof. by intros x; rewrite (comm op) left_id. Qed.
Global Instance ucmra_unit_core_id : CoreId (ε:A).
Proof. apply ucmra_pcore_unit. Qed.
Global Instance cmra_unit_cmra_total : CmraTotal A.
Proof.
intros x. destruct (cmra_pcore_mono' ε x ε) as (cx&->&?); [..|by eauto].
- apply ucmra_unit_least.
- apply (core_id _).
Qed.
Global Instance empty_cancelable : Cancelable (ε:A).
Proof. intros ???. by rewrite !left_id. Qed.
(* For big ops *)
Global Instance cmra_monoid : Monoid (@op A _) := {| monoid_unit := ε |}.
End ucmra.
Global Hint Immediate cmra_unit_cmra_total : core.
Global Hint Extern 0 (ε ≼ _) => apply: ucmra_unit_least : core.
(** * Properties about CMRAs with Leibniz equality *)
Section cmra_leibniz.
Local Set Default Proof Using "Type*".
Context {SI : sidx} {A : cmra} `{!LeibnizEquiv A}.
Implicit Types x y : A.
Global Instance cmra_assoc_L : Assoc (=) (@op A _).
Proof. intros x y z. unfold_leibniz. by rewrite assoc. Qed.
Global Instance cmra_comm_L : Comm (=) (@op A _).
Proof. intros x y. unfold_leibniz. by rewrite comm. Qed.
Lemma cmra_pcore_l_L x cx : pcore x = Some cx → cx ⋅ x = x.
Proof. unfold_leibniz. apply cmra_pcore_l'. Qed.
Lemma cmra_pcore_idemp_L x cx : pcore x = Some cx → pcore cx = Some cx.
Proof. unfold_leibniz. apply cmra_pcore_idemp'. Qed.
Lemma cmra_op_opM_assoc_L x y mz : (x ⋅ y) ⋅? mz = x ⋅ (y ⋅? mz).
Proof. unfold_leibniz. apply cmra_op_opM_assoc. Qed.
(** ** Core *)
Lemma cmra_pcore_r_L x cx : pcore x = Some cx → x ⋅ cx = x.
Proof. unfold_leibniz. apply cmra_pcore_r'. Qed.
Lemma cmra_pcore_dup_L x cx : pcore x = Some cx → cx = cx ⋅ cx.
Proof. unfold_leibniz. apply cmra_pcore_dup'. Qed.
(** ** CoreId elements *)
Lemma core_id_dup_L x `{!CoreId x} : x = x ⋅ x.
Proof. unfold_leibniz. by apply core_id_dup. Qed.
(** ** Total core *)
Section total_core.
Context `{!CmraTotal A}.
Lemma cmra_core_r_L x : x ⋅ core x = x.
Proof. unfold_leibniz. apply cmra_core_r. Qed.
Lemma cmra_core_l_L x : core x ⋅ x = x.
Proof. unfold_leibniz. apply cmra_core_l. Qed.
Lemma cmra_core_idemp_L x : core (core x) = core x.
Proof. unfold_leibniz. apply cmra_core_idemp. Qed.
Lemma cmra_core_dup_L x : core x = core x ⋅ core x.
Proof. unfold_leibniz. apply cmra_core_dup. Qed.
Lemma core_id_total_L x : CoreId x ↔ core x = x.
Proof. unfold_leibniz. apply core_id_total. Qed.
Lemma core_id_core_L x `{!CoreId x} : core x = x.
Proof. by apply core_id_total_L. Qed.
End total_core.
End cmra_leibniz.
Section ucmra_leibniz.
Local Set Default Proof Using "Type*".
Context {SI : sidx} {A : ucmra} `{!LeibnizEquiv A}.
Implicit Types x y z : A.
Global Instance ucmra_unit_left_id_L : LeftId (=) ε (@op A _).
Proof. intros x. unfold_leibniz. by rewrite left_id. Qed.
Global Instance ucmra_unit_right_id_L : RightId (=) ε (@op A _).
Proof. intros x. unfold_leibniz. by rewrite right_id. Qed.
End ucmra_leibniz.
(** * Constructing a CMRA with total core *)
Section cmra_total.
Context {SI : sidx} A `{!Dist A, !Equiv A, !PCore A, !Op A, !Valid A, !ValidN A}.
Context (total : ∀ x : A, is_Some (pcore x)).
Context (op_ne : ∀ x : A, NonExpansive (op x)).
Context (core_ne : NonExpansive (@core A _)).
Context (validN_ne : ∀ n, Proper (dist n ==> impl) (@validN SI A _ n)).
Context (valid_validN : ∀ (x : A), ✓ x ↔ ∀ n, ✓{n} x).
Context (validN_le : ∀ n n' (x : A), ✓{n} x → n' ≤ n → ✓{n'} x).
Context (op_assoc : Assoc (≡) (@op A _)).
Context (op_comm : Comm (≡) (@op A _)).
Context (core_l : ∀ x : A, core x ⋅ x ≡ x).
Context (core_idemp : ∀ x : A, core (core x) ≡ core x).
Context (core_mono : ∀ x y : A, x ≼ y → core x ≼ core y).
Context (validN_op_l : ∀ n (x y : A), ✓{n} (x ⋅ y) → ✓{n} x).
Context (extend : ∀ n (x y1 y2 : A),
✓{n} x → x ≡{n}≡ y1 ⋅ y2 →
{ z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{n}≡ y1 ∧ z2 ≡{n}≡ y2 } }).
Lemma cmra_total_mixin : CmraMixin A.
Proof using Type*.
split; auto.
- intros n x y ? Hcx%core_ne Hx; move: Hcx. rewrite /core /= Hx /=.
case (total y)=> [cy ->]; eauto.
- intros x cx Hcx. move: (core_l x). by rewrite /core /= Hcx.
- intros x cx Hcx. move: (core_idemp x). rewrite /core /= Hcx /=.
case (total cx)=>[ccx ->]; by constructor.
- intros x y cx Hxy%core_mono Hx. move: Hxy.
rewrite /core /= Hx /=. case (total y)=> [cy ->]; eauto.
Qed.
End cmra_total.
(** * Properties about morphisms *)
Global Instance cmra_morphism_id {SI : sidx} {A : cmra} : CmraMorphism (@id A).
Proof.
split => /=.
- apply _.
- done.
- intros. by rewrite option_fmap_id.
- done.
Qed.
Global Instance cmra_morphism_proper {SI : sidx}
{A B : cmra} (f : A → B) `{!CmraMorphism f} :
Proper ((≡) ==> (≡)) f := ne_proper _.
Global Instance cmra_morphism_compose {SI : sidx}
{A B C : cmra} (f : A → B) (g : B → C) :
CmraMorphism f → CmraMorphism g → CmraMorphism (g ∘ f).
Proof.
split.
- apply _.
- move=> n x Hx /=. by apply cmra_morphism_validN, cmra_morphism_validN.
- move=> x /=. by rewrite option_fmap_compose !cmra_morphism_pcore.
- move=> x y /=. by rewrite !cmra_morphism_op.
Qed.
Section cmra_morphism.
Local Set Default Proof Using "Type*".
Context {SI : sidx} {A B : cmra} (f : A → B) `{!CmraMorphism f}.
Lemma cmra_morphism_core x : f (core x) ≡ core (f x).
Proof. unfold core. rewrite -cmra_morphism_pcore. by destruct (pcore x). Qed.
Lemma cmra_morphism_monotone x y : x ≼ y → f x ≼ f y.
Proof. intros [z ->]. exists (f z). by rewrite cmra_morphism_op. Qed.
Lemma cmra_morphism_monotoneN n x y : x ≼{n} y → f x ≼{n} f y.
Proof. intros [z ->]. exists (f z). by rewrite cmra_morphism_op. Qed.
Lemma cmra_morphism_valid x : ✓ x → ✓ f x.
Proof. rewrite !cmra_valid_validN; eauto using cmra_morphism_validN. Qed.
End cmra_morphism.
(** COFE → CMRA Functors *)
Record rFunctor {SI : sidx} := RFunctor {
rFunctor_car : ∀ A `{!Cofe A} B `{!Cofe B}, cmra;
rFunctor_map `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
((A2 -n> A1) * (B1 -n> B2)) → rFunctor_car A1 B1 -n> rFunctor_car A2 B2;
rFunctor_map_ne `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
NonExpansive (@rFunctor_map A1 _ A2 _ B1 _ B2 _);
rFunctor_map_id `{!Cofe A, !Cofe B} (x : rFunctor_car A B) :
rFunctor_map (cid,cid) x ≡ x;
rFunctor_map_compose `{!Cofe A1, !Cofe A2, !Cofe A3, !Cofe B1, !Cofe B2, !Cofe B3}
(f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x :
rFunctor_map (f◎g, g'◎f') x ≡ rFunctor_map (g,g') (rFunctor_map (f,f') x);
rFunctor_mor `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2}
(fg : (A2 -n> A1) * (B1 -n> B2)) :
CmraMorphism (rFunctor_map fg)
}.
Global Existing Instances rFunctor_map_ne rFunctor_mor.
Global Instance: Params (@rFunctor_map) 10 := {}.
Declare Scope rFunctor_scope.
Delimit Scope rFunctor_scope with RF.
Bind Scope rFunctor_scope with rFunctor.
Class rFunctorContractive {SI : sidx} (F : rFunctor) :=
#[global] rFunctor_map_contractive `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} ::
Contractive (@rFunctor_map SI F A1 _ A2 _ B1 _ B2 _).
Global Hint Mode rFunctorContractive - ! : typeclass_instances.
Definition rFunctor_apply {SI : sidx} (F: rFunctor) (A: ofe) `{!Cofe A} : cmra :=
rFunctor_car F A A.
Program Definition rFunctor_to_oFunctor {SI : sidx} (F: rFunctor) : oFunctor := {|
oFunctor_car A _ B _ := rFunctor_car F A B;
oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := rFunctor_map F fg
|}.
Next Obligation.
intros ? F A ? B ? x. simpl in *. apply rFunctor_map_id.
Qed.
Next Obligation.
intros ? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. simpl in *.
apply rFunctor_map_compose.
Qed.
Global Instance rFunctor_to_oFunctor_contractive {SI : sidx} F :
rFunctorContractive F → oFunctorContractive (rFunctor_to_oFunctor F).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg. apply rFunctor_map_contractive. done.
Qed.
Program Definition rFunctor_oFunctor_compose
{SI : sidx} (F1 : rFunctor) (F2 : oFunctor)
`{!∀ `{!Cofe A, !Cofe B}, Cofe (oFunctor_car F2 A B)} : rFunctor := {|
rFunctor_car A _ B _ := rFunctor_car F1 (oFunctor_car F2 B A) (oFunctor_car F2 A B);
rFunctor_map A1 _ A2 _ B1 _ B2 _ 'fg :=
rFunctor_map F1 (oFunctor_map F2 (fg.2,fg.1),oFunctor_map F2 fg)
|}.
Next Obligation.
intros ? F1 F2 ? A1 ? A2 ? B1 ? B2 ? n [f1 g1] [f2 g2] [??]; simpl in *.
apply rFunctor_map_ne; split; apply oFunctor_map_ne; by split.
Qed.
Next Obligation.
intros ? F1 F2 ? A ? B ? x; simpl in *. rewrite -{2}(rFunctor_map_id F1 x).
apply equiv_dist=> n. apply rFunctor_map_ne.
split=> y /=; by rewrite !oFunctor_map_id.
Qed.
Next Obligation.
intros ? F1 F2 ? A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl in *.
rewrite -rFunctor_map_compose. apply equiv_dist=> n. apply rFunctor_map_ne.
split=> y /=; by rewrite !oFunctor_map_compose.
Qed.
Global Instance rFunctor_oFunctor_compose_contractive_1
{SI : sidx} (F1 : rFunctor) (F2 : oFunctor)
`{!∀ `{!Cofe A, !Cofe B}, Cofe (oFunctor_car F2 A B)} :
rFunctorContractive F1 → rFunctorContractive (rFunctor_oFunctor_compose F1 F2).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n [f1 g1] [f2 g2] Hfg; simpl in *.
f_contractive; destruct Hfg; split; simpl in *; apply oFunctor_map_ne; by split.
Qed.
Global Instance rFunctor_oFunctor_compose_contractive_2
{SI : sidx} (F1 : rFunctor) (F2 : oFunctor)
`{!∀ `{!Cofe A, !Cofe B}, Cofe (oFunctor_car F2 A B)} :
oFunctorContractive F2 → rFunctorContractive (rFunctor_oFunctor_compose F1 F2).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n [f1 g1] [f2 g2] Hfg; simpl in *.
f_equiv; split; simpl in *; f_contractive; destruct Hfg; by split.
Qed.
Program Definition constRF {SI : sidx} (B : cmra) : rFunctor :=
{| rFunctor_car A1 _ A2 _ := B; rFunctor_map A1 _ A2 _ B1 _ B2 _ f := cid |}.
Solve Obligations with done.
Coercion constRF : cmra >-> rFunctor.
Global Instance constRF_contractive {SI : sidx} B : rFunctorContractive (constRF B).
Proof. rewrite /rFunctorContractive; apply _. Qed.
(** COFE → UCMRA Functors *)
Record urFunctor {SI : sidx} := URFunctor {
urFunctor_car : ∀ A `{!Cofe A} B `{!Cofe B}, ucmra;
urFunctor_map `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
((A2 -n> A1) * (B1 -n> B2)) → urFunctor_car A1 B1 -n> urFunctor_car A2 B2;
urFunctor_map_ne `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
NonExpansive (@urFunctor_map A1 _ A2 _ B1 _ B2 _);
urFunctor_map_id `{!Cofe A, !Cofe B} (x : urFunctor_car A B) :
urFunctor_map (cid,cid) x ≡ x;
urFunctor_map_compose `{!Cofe A1, !Cofe A2, !Cofe A3, !Cofe B1, !Cofe B2, !Cofe B3}
(f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x :
urFunctor_map (f◎g, g'◎f') x ≡ urFunctor_map (g,g') (urFunctor_map (f,f') x);
urFunctor_mor `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2}
(fg : (A2 -n> A1) * (B1 -n> B2)) :
CmraMorphism (urFunctor_map fg)
}.
Global Existing Instances urFunctor_map_ne urFunctor_mor.
Global Instance: Params (@urFunctor_map) 10 := {}.
Declare Scope urFunctor_scope.
Delimit Scope urFunctor_scope with URF.
Bind Scope urFunctor_scope with urFunctor.
Class urFunctorContractive {SI : sidx} (F : urFunctor) :=
#[global] urFunctor_map_contractive `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} ::
Contractive (@urFunctor_map SI F A1 _ A2 _ B1 _ B2 _).
Global Hint Mode urFunctorContractive - ! : typeclass_instances.
Definition urFunctor_apply {SI : sidx} (F: urFunctor) (A: ofe) `{!Cofe A} : ucmra :=
urFunctor_car F A A.
Program Definition urFunctor_to_rFunctor {SI : sidx} (F: urFunctor) : rFunctor := {|
rFunctor_car A _ B _ := urFunctor_car F A B;
rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := urFunctor_map F fg
|}.
Next Obligation.
intros ? F A ? B ? x. simpl in *. apply urFunctor_map_id.
Qed.
Next Obligation.
intros ? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. simpl in *.
apply urFunctor_map_compose.
Qed.
Global Instance urFunctor_to_rFunctor_contractive {SI : sidx} F :
urFunctorContractive F → rFunctorContractive (urFunctor_to_rFunctor F).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg. apply urFunctor_map_contractive. done.
Qed.
Program Definition urFunctor_oFunctor_compose
{SI : sidx} (F1 : urFunctor) (F2 : oFunctor)
`{!∀ `{!Cofe A, !Cofe B}, Cofe (oFunctor_car F2 A B)} : urFunctor := {|
urFunctor_car A _ B _ := urFunctor_car F1 (oFunctor_car F2 B A) (oFunctor_car F2 A B);
urFunctor_map A1 _ A2 _ B1 _ B2 _ 'fg :=
urFunctor_map F1 (oFunctor_map F2 (fg.2,fg.1),oFunctor_map F2 fg)
|}.
Next Obligation.
intros ? F1 F2 ? A1 ? A2 ? B1 ? B2 ? n [f1 g1] [f2 g2] [??]; simpl in *.
apply urFunctor_map_ne; split; apply oFunctor_map_ne; by split.
Qed.
Next Obligation.
intros ? F1 F2 ? A ? B ? x; simpl in *. rewrite -{2}(urFunctor_map_id F1 x).
apply equiv_dist=> n. apply urFunctor_map_ne.
split=> y /=; by rewrite !oFunctor_map_id.
Qed.
Next Obligation.
intros ? F1 F2 ? A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl in *.
rewrite -urFunctor_map_compose. apply equiv_dist=> n. apply urFunctor_map_ne.
split=> y /=; by rewrite !oFunctor_map_compose.
Qed.
Global Instance urFunctor_oFunctor_compose_contractive_1
{SI : sidx} (F1 : urFunctor) (F2 : oFunctor)
`{!∀ `{!Cofe A, !Cofe B}, Cofe (oFunctor_car F2 A B)} :
urFunctorContractive F1 → urFunctorContractive (urFunctor_oFunctor_compose F1 F2).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n [f1 g1] [f2 g2] Hfg; simpl in *.
f_contractive; destruct Hfg; split; simpl in *; apply oFunctor_map_ne; by split.
Qed.
Global Instance urFunctor_oFunctor_compose_contractive_2
{SI : sidx} (F1 : urFunctor) (F2 : oFunctor)
`{!∀ `{!Cofe A, !Cofe B}, Cofe (oFunctor_car F2 A B)} :
oFunctorContractive F2 → urFunctorContractive (urFunctor_oFunctor_compose F1 F2).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n [f1 g1] [f2 g2] Hfg; simpl in *.
f_equiv; split; simpl in *; f_contractive; destruct Hfg; by split.
Qed.
Program Definition constURF {SI : sidx} (B : ucmra) : urFunctor :=
{| urFunctor_car A1 _ A2 _ := B; urFunctor_map A1 _ A2 _ B1 _ B2 _ f := cid |}.
Solve Obligations with done.
Coercion constURF : ucmra >-> urFunctor.
Global Instance constURF_contractive {SI : sidx} B :
urFunctorContractive (constURF B).
Proof. rewrite /urFunctorContractive; apply _. Qed.
(** * Transporting a CMRA equality *)
Definition cmra_transport {SI : sidx} {A B : cmra} (H : A = B) (x : A) : B :=
eq_rect A id x _ H.
Lemma cmra_transport_trans {SI : sidx} {A B C : cmra} (H1 : A = B) (H2 : B = C) x :
cmra_transport H2 (cmra_transport H1 x) = cmra_transport (eq_trans H1 H2) x.
Proof. by destruct H2. Qed.
Section cmra_transport.
Context {SI : sidx} {A B : cmra} (H : A = B).
Notation T := (cmra_transport H).
Global Instance cmra_transport_ne : NonExpansive T.
Proof. by intros ???; destruct H. Qed.
Global Instance cmra_transport_proper : Proper ((≡) ==> (≡)) T.
Proof. by intros ???; destruct H. Qed.
Lemma cmra_transport_op x y : T (x ⋅ y) = T x ⋅ T y.
Proof. by destruct H. Qed.
Lemma cmra_transport_core x : T (core x) = core (T x).
Proof. by destruct H. Qed.
Lemma cmra_transport_validN n x : ✓{n} T x ↔ ✓{n} x.
Proof. by destruct H. Qed.
Lemma cmra_transport_valid x : ✓ T x ↔ ✓ x.
Proof. by destruct H. Qed.
Global Instance cmra_transport_discrete x : Discrete x → Discrete (T x).
Proof. by destruct H. Qed.
Global Instance cmra_transport_core_id x : CoreId x → CoreId (T x).
Proof. by destruct H. Qed.
End cmra_transport.
(** * Instances *)
(** ** Discrete CMRA *)
Record RAMixin A `{Equiv A, PCore A, Op A, Valid A} := {
(* setoids *)
ra_op_proper (x : A) : Proper ((≡) ==> (≡)) (op x);
ra_core_proper (x y : A) cx :
x ≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡ cy;
ra_validN_proper : Proper ((≡@{A}) ==> impl) valid;
(* monoid *)
ra_assoc : Assoc (≡@{A}) (⋅);
ra_comm : Comm (≡@{A}) (⋅);
ra_pcore_l (x : A) cx : pcore x = Some cx → cx ⋅ x ≡ x;
ra_pcore_idemp (x : A) cx : pcore x = Some cx → pcore cx ≡ Some cx;
ra_pcore_mono (x y : A) cx :
x ≼ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼ cy;
ra_valid_op_l (x y : A) : ✓ (x ⋅ y) → ✓ x
}.
Section discrete.
Local Set Default Proof Using "Type*".
Context {SI : sidx} `{!Equiv A, !PCore A, !Op A, !Valid A}.
Context (Heq : @Equivalence A (≡)).
Context (ra_mix : RAMixin A).
Existing Instances discrete_dist.
Local Instance discrete_validN_instance : ValidN A := λ n x, ✓ x.
Definition discrete_cmra_mixin : CmraMixin A.
Proof.
destruct ra_mix; split; try done.
- intros x; split; first done. by move=> /(_ 0ᵢ).
- intros n x y1 y2 ??; by exists y1, y2.
Qed.
Local Instance discrete_cmra_discrete :
CmraDiscrete (Cmra' A (discrete_ofe_mixin Heq) discrete_cmra_mixin).
Proof. split; first apply _. done. Qed.
End discrete.
(** A smart constructor for the discrete RA over a carrier [A]. It uses
[ofe_discrete_equivalence_of A] to make sure the same [Equivalence] proof is
used as when constructing the OFE. *)
Notation discreteR A ra_mix :=
(Cmra A (discrete_cmra_mixin (discrete_ofe_equivalence_of A%type) ra_mix))
(only parsing).
Section ra_total.
Local Set Default Proof Using "Type*".
Context A `{Equiv A, PCore A, Op A, Valid A}.
Context (total : ∀ x : A, is_Some (pcore x)).
Context (op_proper : ∀ x : A, Proper ((≡) ==> (≡)) (op x)).
Context (core_proper: Proper ((≡) ==> (≡)) (@core A _)).
Context (valid_proper : Proper ((≡) ==> impl) (@valid A _)).
Context (op_assoc : Assoc (≡) (@op A _)).
Context (op_comm : Comm (≡) (@op A _)).
Context (core_l : ∀ x : A, core x ⋅ x ≡ x).
Context (core_idemp : ∀ x : A, core (core x) ≡ core x).
Context (core_mono : ∀ x y : A, x ≼ y → core x ≼ core y).
Context (valid_op_l : ∀ x y : A, ✓ (x ⋅ y) → ✓ x).
Lemma ra_total_mixin : RAMixin A.
Proof.
split; auto.
- intros x y ? Hcx%core_proper Hx; move: Hcx. rewrite /core /= Hx /=.
case (total y)=> [cy ->]; eauto.
- intros x cx Hcx. move: (core_l x). by rewrite /core /= Hcx.
- intros x cx Hcx. move: (core_idemp x). rewrite /core /= Hcx /=.
case (total cx)=>[ccx ->]; by constructor.
- intros x y cx Hxy%core_mono Hx. move: Hxy.
rewrite /core /= Hx /=. case (total y)=> [cy ->]; eauto.
Qed.
End ra_total.
(** ** CMRA for the unit type *)
Section unit.
Context {SI : sidx}.
Local Instance unit_valid_instance : Valid () := λ x, True.
Local Instance unit_validN_instance : ValidN () := λ n x, True.
Local Instance unit_pcore_instance : PCore () := λ x, Some x.
Local Instance unit_op_instance : Op () := λ x y, ().
Lemma unit_cmra_mixin : CmraMixin ().
Proof. apply discrete_cmra_mixin, ra_total_mixin; by eauto. Qed.
Canonical Structure unitR : cmra := Cmra unit unit_cmra_mixin.
Local Instance unit_unit_instance : Unit () := ().
Lemma unit_ucmra_mixin : UcmraMixin ().
Proof. done. Qed.
Canonical Structure unitUR : ucmra := Ucmra unit unit_ucmra_mixin.
Global Instance unit_cmra_discrete : CmraDiscrete unitR.
Proof. done. Qed.
Global Instance unit_core_id (x : ()) : CoreId x.
Proof. by constructor. Qed.
Global Instance unit_cancelable (x : ()) : Cancelable x.
Proof. by constructor. Qed.
End unit.
(** ** CMRA for the empty type *)
Section empty.
Context {SI : sidx}.
Local Instance Empty_set_valid_instance : Valid Empty_set := λ x, False.
Local Instance Empty_set_validN_instance : ValidN Empty_set := λ n x, False.
Local Instance Empty_set_pcore_instance : PCore Empty_set := λ x, Some x.
Local Instance Empty_set_op_instance : Op Empty_set := λ x y, x.
Lemma Empty_set_cmra_mixin : CmraMixin Empty_set.
Proof. apply discrete_cmra_mixin, ra_total_mixin; by (intros [] || done). Qed.
Canonical Structure Empty_setR : cmra := Cmra Empty_set Empty_set_cmra_mixin.
Global Instance Empty_set_cmra_discrete : CmraDiscrete Empty_setR.
Proof. done. Qed.
Global Instance Empty_set_core_id (x : Empty_set) : CoreId x.
Proof. by constructor. Qed.
Global Instance Empty_set_cancelable (x : Empty_set) : Cancelable x.
Proof. by constructor. Qed.
End empty.
(** ** Product *)
Section prod.
Context {SI : sidx} {A B : cmra}.
Local Arguments pcore _ _ !_ /.
Local Arguments cmra_pcore _ !_/.
Local Instance prod_op_instance : Op (A * B) := λ x y, (x.1 ⋅ y.1, x.2 ⋅ y.2).
Local Instance prod_pcore_instance : PCore (A * B) := λ x,
c1 ← pcore (x.1); c2 ← pcore (x.2); Some (c1, c2).
Local Arguments prod_pcore_instance !_ /.
Local Instance prod_valid_instance : Valid (A * B) := λ x, ✓ x.1 ∧ ✓ x.2.
Local Instance prod_validN_instance : ValidN (A * B) := λ n x, ✓{n} x.1 ∧ ✓{n} x.2.
Lemma prod_pcore_Some (x cx : A * B) :
pcore x = Some cx ↔ pcore (x.1) = Some (cx.1) ∧ pcore (x.2) = Some (cx.2).
Proof. destruct x, cx; by intuition simplify_option_eq. Qed.
Lemma prod_pcore_Some' (x cx : A * B) :
pcore x ≡ Some cx ↔ pcore (x.1) ≡ Some (cx.1) ∧ pcore (x.2) ≡ Some (cx.2).
Proof.
split; [by intros (cx'&[-> ->]%prod_pcore_Some&<-)%Some_equiv_eq|].
rewrite {3}/pcore /prod_pcore_instance. (* TODO: use setoid rewrite *)
intros [Hx1 Hx2]; inversion_clear Hx1; simpl; inversion_clear Hx2.
by constructor.
Qed.
Lemma prod_included (x y : A * B) : x ≼ y ↔ x.1 ≼ y.1 ∧ x.2 ≼ y.2.
Proof.
split; [intros [z Hz]; split; [exists (z.1)|exists (z.2)]; apply Hz|].
intros [[z1 Hz1] [z2 Hz2]]; exists (z1,z2); split; auto.
Qed.
Lemma prod_includedN (x y : A * B) n : x ≼{n} y ↔ x.1 ≼{n} y.1 ∧ x.2 ≼{n} y.2.
Proof.
split; [intros [z Hz]; split; [exists (z.1)|exists (z.2)]; apply Hz|].
intros [[z1 Hz1] [z2 Hz2]]; exists (z1,z2); split; auto.
Qed.
Definition prod_cmra_mixin : CmraMixin (A * B).
Proof.
split; try apply _.
- by intros n x y1 y2 [Hy1 Hy2]; split; rewrite /= ?Hy1 ?Hy2.
- intros n x y cx; setoid_rewrite prod_pcore_Some=> -[??] [??].
destruct (cmra_pcore_ne n (x.1) (y.1) (cx.1)) as (z1&->&?); auto.
destruct (cmra_pcore_ne n (x.2) (y.2) (cx.2)) as (z2&->&?); auto.
exists (z1,z2); repeat constructor; auto.
- by intros n y1 y2 [Hy1 Hy2] [??]; split; rewrite /= -?Hy1 -?Hy2.
- intros x; split.
+ intros [??] n; split; by apply cmra_valid_validN.
+ intros Hxy; split; apply cmra_valid_validN=> n; apply Hxy.
- intros n m x [??]; split; by eapply cmra_validN_le.
- by split; rewrite /= assoc.
- by split; rewrite /= comm.
- intros x y [??]%prod_pcore_Some;
constructor; simpl; eauto using cmra_pcore_l.
- intros x y; rewrite prod_pcore_Some prod_pcore_Some'.
naive_solver eauto using cmra_pcore_idemp.
- intros x y cx; rewrite prod_included prod_pcore_Some=> -[??] [??].
destruct (cmra_pcore_mono (x.1) (y.1) (cx.1)) as (z1&?&?); auto.
destruct (cmra_pcore_mono (x.2) (y.2) (cx.2)) as (z2&?&?); auto.
exists (z1,z2). by rewrite prod_included prod_pcore_Some.
- intros n x y [??]; split; simpl in *; eauto using cmra_validN_op_l.
- intros n x y1 y2 [??] [??]; simpl in *.
destruct (cmra_extend n (x.1) (y1.1) (y2.1)) as (z11&z12&?&?&?); auto.
destruct (cmra_extend n (x.2) (y1.2) (y2.2)) as (z21&z22&?&?&?); auto.
by exists (z11,z21), (z12,z22).
Qed.
Canonical Structure prodR := Cmra (prod A B) prod_cmra_mixin.
Lemma pair_op (a a' : A) (b b' : B) : (a ⋅ a', b ⋅ b') = (a, b) ⋅ (a', b').
Proof. done. Qed.
Lemma pair_valid (a : A) (b : B) : ✓ (a, b) ↔ ✓ a ∧ ✓ b.
Proof. done. Qed.
Lemma pair_validN (a : A) (b : B) n : ✓{n} (a, b) ↔ ✓{n} a ∧ ✓{n} b.
Proof. done. Qed.
Lemma pair_included (a a' : A) (b b' : B) :
(a, b) ≼ (a', b') ↔ a ≼ a' ∧ b ≼ b'.
Proof. apply prod_included. Qed.
Lemma pair_includedN (a a' : A) (b b' : B) n :
(a, b) ≼{n} (a', b') ↔ a ≼{n} a' ∧ b ≼{n} b'.
Proof. apply prod_includedN. Qed.
Lemma pair_pcore (a : A) (b : B) :
pcore (a, b) = c1 ← pcore a; c2 ← pcore b; Some (c1, c2).
Proof. done. Qed.
Lemma pair_core `{!CmraTotal A, !CmraTotal B} (a : A) (b : B) :
core (a, b) = (core a, core b).
Proof.
rewrite /core {1}/pcore /=.
rewrite (cmra_pcore_core a) /= (cmra_pcore_core b). done.
Qed.
Global Instance prod_cmra_total : CmraTotal A → CmraTotal B → CmraTotal prodR.
Proof.
intros H1 H2 [a b]. destruct (H1 a) as [ca ?], (H2 b) as [cb ?].
exists (ca,cb); by simplify_option_eq.
Qed.
Global Instance prod_cmra_discrete :
CmraDiscrete A → CmraDiscrete B → CmraDiscrete prodR.
Proof. split; [apply _|]. by intros ? []; split; apply cmra_discrete_valid. Qed.
(* FIXME(Coq #6294): This is not an instance because we need it to use the new
unification. *)
Lemma pair_core_id x y :
CoreId x → CoreId y → CoreId (x,y).
Proof. by rewrite /CoreId prod_pcore_Some'. Qed.
Global Instance pair_exclusive_l x y : Exclusive x → Exclusive (x,y).
Proof. by intros ?[][?%exclusive0_l]. Qed.
Global Instance pair_exclusive_r x y : Exclusive y → Exclusive (x,y).
Proof. by intros ?[][??%exclusive0_l]. Qed.
Global Instance pair_cancelable x y :
Cancelable x → Cancelable y → Cancelable (x,y).
Proof. intros ???[][][][]. constructor; simpl in *; by eapply cancelableN. Qed.
Global Instance pair_id_free_l x y : IdFree x → IdFree (x,y).
Proof. move=> Hx [a b] [? _] [/=? _]. apply (Hx a); eauto. Qed.
Global Instance pair_id_free_r x y : IdFree y → IdFree (x,y).
Proof. move=> Hy [a b] [_ ?] [_ /=?]. apply (Hy b); eauto. Qed.
End prod.
(* Registering as [Hint Extern] with new unification. *)
Global Hint Extern 4 (CoreId _) =>
notypeclasses refine (pair_core_id _ _ _ _) : typeclass_instances.
Global Arguments prodR {_} _ _.
Section prod_unit.
Context {SI : sidx} {A B : ucmra}.
Local Instance prod_unit_instance `{Unit A, Unit B} : Unit (A * B) := (ε, ε).
Lemma prod_ucmra_mixin : UcmraMixin (A * B).
Proof.
split.
- split; apply ucmra_unit_valid.
- by split; rewrite /=left_id.
- rewrite prod_pcore_Some'; split; apply (core_id _).
Qed.
Canonical Structure prodUR := Ucmra (prod A B) prod_ucmra_mixin.
Lemma pair_split (a : A) (b : B) : (a, b) ≡ (a, ε) ⋅ (ε, b).
Proof. by rewrite -pair_op left_id right_id. Qed.
Lemma pair_split_L `{!LeibnizEquiv A, !LeibnizEquiv B} (x : A) (y : B) :
(x, y) = (x, ε) ⋅ (ε, y).
Proof. unfold_leibniz. apply pair_split. Qed.
Lemma pair_op_1 (a a': A) : (a ⋅ a', ε) ≡@{A*B} (a, ε) ⋅ (a', ε).
Proof. by rewrite -pair_op ucmra_unit_left_id. Qed.
Lemma pair_op_1_L `{!LeibnizEquiv A, !LeibnizEquiv B} (a a': A) :
(a ⋅ a', ε) =@{A*B} (a, ε) ⋅ (a', ε).
Proof. unfold_leibniz. apply pair_op_1. Qed.
Lemma pair_op_2 (b b': B) : (ε, b ⋅ b') ≡@{A*B} (ε, b) ⋅ (ε, b').
Proof. by rewrite -pair_op ucmra_unit_left_id. Qed.
Lemma pair_op_2_L `{!LeibnizEquiv A, !LeibnizEquiv B} (b b': B) :
(ε, b ⋅ b') =@{A*B} (ε, b) ⋅ (ε, b').
Proof. unfold_leibniz. apply pair_op_2. Qed.
End prod_unit.
Global Arguments prodUR {_} _ _.
Global Instance prod_map_cmra_morphism
{SI : sidx} {A A' B B' : cmra} (f : A → A') (g : B → B') :
CmraMorphism f → CmraMorphism g → CmraMorphism (prod_map f g).
Proof.
split; first apply _.
- by intros n x [??]; split; simpl; apply cmra_morphism_validN.
- intros [x1 x2]. rewrite /= !pair_pcore /=.
pose proof (Hf := cmra_morphism_pcore f (x1)).
destruct (pcore (f (x1))), (pcore (x1)); inv Hf=>//=.
pose proof (Hg := cmra_morphism_pcore g (x2)).
destruct (pcore (g (x2))), (pcore (x2)); inv Hg=>//=.
by setoid_subst.
- intros. by rewrite /prod_map /= !cmra_morphism_op.
Qed.
Program Definition prodRF {SI : sidx} (F1 F2 : rFunctor) : rFunctor := {|
rFunctor_car A _ B _ := prodR (rFunctor_car F1 A B) (rFunctor_car F2 A B);
rFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
prodO_map (rFunctor_map F1 fg) (rFunctor_map F2 fg)
|}.
Next Obligation.
intros ? F1 F2 A1 ? A2 ? B1 ? B2 ? n ???.
by apply prodO_map_ne; apply rFunctor_map_ne.
Qed.
Next Obligation. by intros ? F1 F2 A ? B ? [??]; rewrite /= !rFunctor_map_id. Qed.
Next Obligation.
intros ? F1 F2 A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' [??]; simpl.
by rewrite !rFunctor_map_compose.
Qed.
Notation "F1 * F2" := (prodRF F1%RF F2%RF) : rFunctor_scope.
Global Instance prodRF_contractive {SI : sidx} F1 F2 :
rFunctorContractive F1 → rFunctorContractive F2 →
rFunctorContractive (prodRF F1 F2).
Proof.
intros ?? A1 ? A2 ? B1 ? B2 ? n ???;
by apply prodO_map_ne; apply rFunctor_map_contractive.
Qed.
Program Definition prodURF {SI : sidx} (F1 F2 : urFunctor) : urFunctor := {|
urFunctor_car A _ B _ := prodUR (urFunctor_car F1 A B) (urFunctor_car F2 A B);
urFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
prodO_map (urFunctor_map F1 fg) (urFunctor_map F2 fg)
|}.
Next Obligation.
intros ? F1 F2 A1 ? A2 ? B1 ? B2 ? n ???.
by apply prodO_map_ne; apply urFunctor_map_ne.
Qed.
Next Obligation. by intros ? F1 F2 A ? B ? [??]; rewrite /= !urFunctor_map_id. Qed.
Next Obligation.
intros ? F1 F2 A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' [??]; simpl.
by rewrite !urFunctor_map_compose.
Qed.
Notation "F1 * F2" := (prodURF F1%URF F2%URF) : urFunctor_scope.
Global Instance prodURF_contractive {SI : sidx} F1 F2 :
urFunctorContractive F1 → urFunctorContractive F2 →
urFunctorContractive (prodURF F1 F2).
Proof.
intros ?? A1 ? A2 ? B1 ? B2 ? n ???;
by apply prodO_map_ne; apply urFunctor_map_contractive.
Qed.
(** ** CMRA for the option type *)
Section option.
Context {SI : sidx} {A : cmra}.
Implicit Types a b : A.
Implicit Types ma mb : option A.
Local Arguments core _ _ !_ /.
Local Arguments pcore _ _ !_ /.
Local Instance option_valid_instance : Valid (option A) := λ ma,
match ma with Some a => ✓ a | None => True end.
Local Instance option_validN_instance : ValidN (option A) := λ n ma,
match ma with Some a => ✓{n} a | None => True end.
Local Instance option_pcore_instance : PCore (option A) := λ ma,
Some (ma ≫= pcore).
Local Arguments option_pcore_instance !_ /.
Local Instance option_op_instance : Op (option A) :=
union_with (λ a b, Some (a ⋅ b)).
Definition Some_valid a : ✓ Some a ↔ ✓ a := reflexivity _.
Definition Some_validN a n : ✓{n} Some a ↔ ✓{n} a := reflexivity _.
Definition Some_op a b : Some (a ⋅ b) = Some a ⋅ Some b := eq_refl.
Lemma Some_core `{!CmraTotal A} a : Some (core a) = core (Some a).
Proof. rewrite /core /=. by destruct (cmra_total a) as [? ->]. Qed.
Lemma pcore_Some a : pcore (Some a) = Some (pcore a).
Proof. done. Qed.
Lemma Some_op_opM a ma : Some a ⋅ ma = Some (a ⋅? ma).
Proof. by destruct ma. Qed.
Lemma option_included ma mb :
ma ≼ mb ↔ ma = None ∨ ∃ a b, ma = Some a ∧ mb = Some b ∧ (a ≡ b ∨ a ≼ b).
Proof.
split.
- intros [mc Hmc].
destruct ma as [a|]; [right|by left].
destruct mb as [b|]; [exists a, b|destruct mc; inversion_clear Hmc].
destruct mc as [c|]; inversion_clear Hmc; split_and?; auto;
setoid_subst; eauto.
- intros [->|(a&b&->&->&[Hc|[c Hc]])].
+ exists mb. by destruct mb.
+ exists None; by constructor.
+ exists (Some c); by constructor.
Qed.
Lemma option_included_total `{!CmraTotal A} ma mb :
ma ≼ mb ↔ ma = None ∨ ∃ a b, ma = Some a ∧ mb = Some b ∧ a ≼ b.
Proof.
rewrite option_included. split; last naive_solver.
intros [->|(a&b&->&->&[Hab|?])]; [by eauto| |by eauto 10].
right. exists a, b. by rewrite {3}Hab.
Qed.
Lemma option_includedN n ma mb :
ma ≼{n} mb ↔ ma = None ∨
∃ x y, ma = Some x ∧ mb = Some y ∧ (x ≡{n}≡ y ∨ x ≼{n} y).
Proof.
split.
- intros [mc Hmc].
destruct ma as [a|]; [right|by left].
destruct mb as [b|]; [exists a, b|destruct mc; inversion_clear Hmc].
destruct mc as [c|]; inversion_clear Hmc; split_and?; auto;
ofe_subst; eauto using cmra_includedN_l.
- intros [->|(a&y&->&->&[Hc|[c Hc]])].
+ exists mb. by destruct mb.
+ exists None; by constructor.
+ exists (Some c); by constructor.
Qed.
Lemma option_includedN_total `{!CmraTotal A} n ma mb :
ma ≼{n} mb ↔ ma = None ∨ ∃ a b, ma = Some a ∧ mb = Some b ∧ a ≼{n} b.
Proof.
rewrite option_includedN. split; last naive_solver.
intros [->|(a&b&->&->&[Hab|?])]; [by eauto| |by eauto 10].
right. exists a, b. by rewrite {3}Hab.
Qed.
(* See below for more [included] lemmas. *)
Lemma option_cmra_mixin : CmraMixin (option A).
Proof.
apply cmra_total_mixin.
- eauto.
- by intros [a|] n; destruct 1; constructor; ofe_subst.
- destruct 1; by ofe_subst.
- by destruct 1; rewrite /validN /option_validN_instance //=; ofe_subst.
- intros [a|]; [apply cmra_valid_validN|done].
- intros n m [a|];
unfold validN, option_validN_instance; eauto using cmra_validN_le.
- intros [a|] [b|] [c|]; constructor; rewrite ?assoc; auto.
- intros [a|] [b|]; constructor; rewrite 1?comm; auto.
- intros [a|]; simpl; auto.
destruct (pcore a) as [ca|] eqn:?; constructor; eauto using cmra_pcore_l.
- intros [a|]; simpl; auto.
destruct (pcore a) as [ca|] eqn:?; simpl; eauto using cmra_pcore_idemp.
- intros ma mb; setoid_rewrite option_included.
intros [->|(a&b&->&->&[?|?])]; simpl; eauto.
+ destruct (pcore a) as [ca|] eqn:?; eauto.
destruct (cmra_pcore_proper a b ca) as (?&?&?); eauto 10.
+ destruct (pcore a) as [ca|] eqn:?; eauto.
destruct (cmra_pcore_mono a b ca) as (?&?&?); eauto 10.
- intros n [a|] [b|]; rewrite /validN /option_validN_instance /=;
eauto using cmra_validN_op_l.
- intros n ma mb1 mb2.
destruct ma as [a|], mb1 as [b1|], mb2 as [b2|]; intros Hx Hx';
(try by exfalso; inversion Hx'); (try (apply (inj Some) in Hx')).
+ destruct (cmra_extend n a b1 b2) as (c1&c2&?&?&?); auto.
by exists (Some c1), (Some c2); repeat constructor.
+ by exists (Some a), None; repeat constructor.
+ by exists None, (Some a); repeat constructor.
+ exists None, None; repeat constructor.
Qed.
Canonical Structure optionR := Cmra (option A) option_cmra_mixin.
Global Instance option_cmra_discrete : CmraDiscrete A → CmraDiscrete optionR.
Proof. split; [apply _|]. by intros [a|]; [apply (cmra_discrete_valid a)|]. Qed.
Local Instance option_unit_instance : Unit (option A) := None.
Lemma option_ucmra_mixin : UcmraMixin optionR.
Proof. split; [done| |done]. by intros []. Qed.
Canonical Structure optionUR := Ucmra (option A) option_ucmra_mixin.
(** Misc *)
Lemma op_None ma mb : ma ⋅ mb = None ↔ ma = None ∧ mb = None.
Proof. destruct ma, mb; naive_solver. Qed.
Lemma op_is_Some ma mb : is_Some (ma ⋅ mb) ↔ is_Some ma ∨ is_Some mb.
Proof. rewrite -!not_eq_None_Some op_None. destruct ma, mb; naive_solver. Qed.
(* When the goal is already of the form [None ⋅ x], the [LeftId] instance for
[ε] does not fire. *)
Global Instance op_None_left_id : LeftId (=) None (@op (option A) _).
Proof. intros [a|]; done. Qed.
Global Instance op_None_right_id : RightId (=) None (@op (option A) _).
Proof. intros [a|]; done. Qed.
Lemma cmra_opM_opM_assoc a mb mc : a ⋅? mb ⋅? mc ≡ a ⋅? (mb ⋅ mc).
Proof. destruct mb, mc; by rewrite /= -?assoc. Qed.
Lemma cmra_opM_opM_assoc_L `{!LeibnizEquiv A} a mb mc :
a ⋅? mb ⋅? mc = a ⋅? (mb ⋅ mc).
Proof. unfold_leibniz. apply cmra_opM_opM_assoc. Qed.
Lemma cmra_opM_opM_swap a mb mc : a ⋅? mb ⋅? mc ≡ a ⋅? mc ⋅? mb.
Proof. by rewrite !cmra_opM_opM_assoc (comm _ mb). Qed.
Lemma cmra_opM_opM_swap_L `{!LeibnizEquiv A} a mb mc :
a ⋅? mb ⋅? mc = a ⋅? mc ⋅? mb.
Proof. by rewrite !cmra_opM_opM_assoc_L (comm_L _ mb). Qed.
Lemma cmra_opM_fmap_Some ma1 ma2 : ma1 ⋅? (Some <$> ma2) = ma1 ⋅ ma2.
Proof. by destruct ma1, ma2. Qed.
Global Instance Some_core_id a : CoreId a → CoreId (Some a).
Proof. by constructor. Qed.
Global Instance option_core_id ma : (∀ x : A, CoreId x) → CoreId ma.
Proof. intros. destruct ma; apply _. Qed.
Lemma exclusiveN_Some_l n a `{!Exclusive a} mb :
✓{n} (Some a ⋅ mb) → mb = None.
Proof. destruct mb; last done. move=> /(exclusiveN_l _ a) []. Qed.
Lemma exclusiveN_Some_r n a `{!Exclusive a} mb :
✓{n} (mb ⋅ Some a) → mb = None.
Proof. rewrite comm. by apply exclusiveN_Some_l. Qed.
Lemma exclusive_Some_l a `{!Exclusive a} mb : ✓ (Some a ⋅ mb) → mb = None.
Proof. destruct mb; last done. move=> /(exclusive_l a) []. Qed.
Lemma exclusive_Some_r a `{!Exclusive a} mb : ✓ (mb ⋅ Some a) → mb = None.
Proof. rewrite comm. by apply exclusive_Some_l. Qed.
Lemma Some_includedN n a b : Some a ≼{n} Some b ↔ a ≡{n}≡ b ∨ a ≼{n} b.
Proof. rewrite option_includedN; naive_solver. Qed.
Lemma Some_includedN_1 n a b : Some a ≼{n} Some b → a ≡{n}≡ b ∨ a ≼{n} b.
Proof. rewrite Some_includedN. auto. Qed.
Lemma Some_includedN_2 n a b : a ≡{n}≡ b ∨ a ≼{n} b → Some a ≼{n} Some b.
Proof. rewrite Some_includedN. auto. Qed.
Lemma Some_includedN_mono n a b : a ≼{n} b → Some a ≼{n} Some b.
Proof. rewrite Some_includedN. auto. Qed.
Lemma Some_includedN_refl n a b : a ≡{n}≡ b → Some a ≼{n} Some b.
Proof. rewrite Some_includedN. auto. Qed.
Lemma Some_includedN_is_Some n x mb : Some x ≼{n} mb → is_Some mb.
Proof. rewrite option_includedN. naive_solver. Qed.
Lemma Some_included a b : Some a ≼ Some b ↔ a ≡ b ∨ a ≼ b.
Proof. rewrite option_included; naive_solver. Qed.
Lemma Some_included_1 a b : Some a ≼ Some b → a ≡ b ∨ a ≼ b.
Proof. rewrite Some_included. auto. Qed.
Lemma Some_included_2 a b : a ≡ b ∨ a ≼ b → Some a ≼ Some b.
Proof. rewrite Some_included. auto. Qed.
Lemma Some_included_mono a b : a ≼ b → Some a ≼ Some b.
Proof. rewrite Some_included. auto. Qed.
Lemma Some_included_refl a b : a ≡ b → Some a ≼ Some b.
Proof. rewrite Some_included. auto. Qed.
Lemma Some_included_is_Some x mb : Some x ≼ mb → is_Some mb.
Proof. rewrite option_included. naive_solver. Qed.
Lemma Some_includedN_opM n a b : Some a ≼{n} Some b ↔ ∃ mc, b ≡{n}≡ a ⋅? mc.
Proof.
rewrite /includedN. f_equiv=> mc. by rewrite -(inj_iff Some b) Some_op_opM.
Qed.
Lemma Some_included_opM a b : Some a ≼ Some b ↔ ∃ mc, b ≡ a ⋅? mc.
Proof.
rewrite /included. f_equiv=> mc. by rewrite -(inj_iff Some b) Some_op_opM.
Qed.
Lemma cmra_validN_Some_includedN n a b : ✓{n} a → Some b ≼{n} Some a → ✓{n} b.
Proof. apply: (cmra_validN_includedN _ (Some _) (Some _)). Qed.
Lemma cmra_valid_Some_included a b : ✓ a → Some b ≼ Some a → ✓ b.
Proof. apply: (cmra_valid_included (Some _) (Some _)). Qed.
Lemma Some_includedN_total `{!CmraTotal A} n a b : Some a ≼{n} Some b ↔ a ≼{n} b.
Proof. rewrite Some_includedN. split; [|by eauto]. by intros [->|?]. Qed.
Lemma Some_included_total `{!CmraTotal A} a b : Some a ≼ Some b ↔ a ≼ b.
Proof. rewrite Some_included. split; [|by eauto]. by intros [->|?]. Qed.
Lemma Some_includedN_exclusive n a `{!Exclusive a} b :
Some a ≼{n} Some b → ✓{n} b → a ≡{n}≡ b.
Proof. move=> /Some_includedN [//|/exclusive_includedN]; tauto. Qed.
Lemma Some_included_exclusive a `{!Exclusive a} b :
Some a ≼ Some b → ✓ b → a ≡ b.
Proof. move=> /Some_included [//|/exclusive_included]; tauto. Qed.
Lemma is_Some_includedN n ma mb : ma ≼{n} mb → is_Some ma → is_Some mb.
Proof. rewrite -!not_eq_None_Some option_includedN. naive_solver. Qed.
Lemma is_Some_included ma mb : ma ≼ mb → is_Some ma → is_Some mb.
Proof. rewrite -!not_eq_None_Some option_included. naive_solver. Qed.
Global Instance cancelable_Some a :
IdFree a → Cancelable a → Cancelable (Some a).
Proof.
intros Hirr ? n [b|] [c|] ? EQ; inversion_clear EQ.
- constructor. by apply (cancelableN a).
- destruct (Hirr b); [|eauto using dist_le, SIdx.le_0_l].
by eapply (cmra_validN_op_l 0ᵢ a b), (cmra_validN_le n), SIdx.le_0_l.
- destruct (Hirr c); [|symmetry; eauto using dist_le, SIdx.le_0_l].
by eapply (cmra_validN_le n), SIdx.le_0_l.
- done.
Qed.
Global Instance option_cancelable (ma : option A) :
(∀ a : A, IdFree a) → (∀ a : A, Cancelable a) → Cancelable ma.
Proof. destruct ma; apply _. Qed.
End option.
Global Arguments optionR {_} _.
Global Arguments optionUR {_} _.
Section option_prod.
Context {SI : sidx} {A B : cmra}.
Implicit Types a : A.
Implicit Types b : B.
Lemma Some_pair_includedN n a1 a2 b1 b2 :
Some (a1,b1) ≼{n} Some (a2,b2) → Some a1 ≼{n} Some a2 ∧ Some b1 ≼{n} Some b2.
Proof. rewrite !Some_includedN. intros [[??]|[??]%prod_includedN]; eauto. Qed.
Lemma Some_pair_includedN_l n a1 a2 b1 b2 :
Some (a1,b1) ≼{n} Some (a2,b2) → Some a1 ≼{n} Some a2.
Proof. intros. eapply Some_pair_includedN. done. Qed.
Lemma Some_pair_includedN_r n a1 a2 b1 b2 :
Some (a1,b1) ≼{n} Some (a2,b2) → Some b1 ≼{n} Some b2.
Proof. intros. eapply Some_pair_includedN. done. Qed.
Lemma Some_pair_includedN_total_1 `{!CmraTotal A} n a1 a2 b1 b2 :
Some (a1,b1) ≼{n} Some (a2,b2) → a1 ≼{n} a2 ∧ Some b1 ≼{n} Some b2.
Proof. intros ?%Some_pair_includedN. by rewrite -(Some_includedN_total _ a1). Qed.
Lemma Some_pair_includedN_total_2 `{!CmraTotal B} n a1 a2 b1 b2 :
Some (a1,b1) ≼{n} Some (a2,b2) → Some a1 ≼{n} Some a2 ∧ b1 ≼{n} b2.
Proof. intros ?%Some_pair_includedN. by rewrite -(Some_includedN_total _ b1). Qed.
Lemma Some_pair_included a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → Some a1 ≼ Some a2 ∧ Some b1 ≼ Some b2.
Proof. rewrite !Some_included. intros [[??]|[??]%prod_included]; eauto. Qed.
Lemma Some_pair_included_l a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → Some a1 ≼ Some a2.
Proof. intros. eapply Some_pair_included. done. Qed.
Lemma Some_pair_included_r a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → Some b1 ≼ Some b2.
Proof. intros. eapply Some_pair_included. done. Qed.
Lemma Some_pair_included_total_1 `{!CmraTotal A} a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → a1 ≼ a2 ∧ Some b1 ≼ Some b2.
Proof. intros ?%Some_pair_included. by rewrite -(Some_included_total a1). Qed.
Lemma Some_pair_included_total_2 `{!CmraTotal B} a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → Some a1 ≼ Some a2 ∧ b1 ≼ b2.
Proof. intros ?%Some_pair_included. by rewrite -(Some_included_total b1). Qed.
End option_prod.
Lemma option_fmap_mono {SI : sidx} {A B : cmra} (f : A → B) (ma mb : option A) :
Proper ((≡) ==> (≡)) f →
(∀ a b, a ≼ b → f a ≼ f b) →
ma ≼ mb → f <$> ma ≼ f <$> mb.
Proof.
intros ??. rewrite !option_included; intros [->|(a&b&->&->&?)]; naive_solver.
Qed.
Global Instance option_fmap_cmra_morphism {SI : sidx}
{A B : cmra} (f: A → B) `{!CmraMorphism f} :
CmraMorphism (fmap f : option A → option B).
Proof.
split; first apply _.
- intros n [a|] ?; rewrite /cmra_validN //=. by apply (cmra_morphism_validN f).
- move=> [a|] //. by apply Some_proper, cmra_morphism_pcore.
- move=> [a|] [b|] //=. by rewrite (cmra_morphism_op f).
Qed.
Program Definition optionURF {SI : sidx} (F : rFunctor) : urFunctor := {|
urFunctor_car A _ B _ := optionUR (rFunctor_car F A B);
urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := optionO_map (rFunctor_map F fg)
|}.
Next Obligation.
intros ? F A1 ? A2 ? B1 ? B2 ? n f g Hfg.
by apply optionO_map_ne, rFunctor_map_ne.
Qed.
Next Obligation.
intros ? F A ? B ? x. rewrite /= -{2}(option_fmap_id x).
apply option_fmap_equiv_ext=>y; apply rFunctor_map_id.
Qed.
Next Obligation.
intros ? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x.
rewrite /= -option_fmap_compose.
apply option_fmap_equiv_ext=>y; apply rFunctor_map_compose.
Qed.
Global Instance optionURF_contractive {SI : sidx} F :
rFunctorContractive F → urFunctorContractive (optionURF F).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg.
by apply optionO_map_ne, rFunctor_map_contractive.
Qed.
Program Definition optionRF {SI : sidx} (F : rFunctor) : rFunctor := {|
rFunctor_car A _ B _ := optionR (rFunctor_car F A B);
rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := optionO_map (rFunctor_map F fg)
|}.
Solve Obligations with apply @optionURF.
Global Instance optionRF_contractive {SI : sidx} F :
rFunctorContractive F → rFunctorContractive (optionRF F).
Proof. apply optionURF_contractive. Qed.
(* Dependently-typed functions over a discrete domain *)
Section discrete_fun_cmra.
Context {SI : sidx} {A: Type} {B : A → ucmra}.
Implicit Types f g : discrete_fun B.
Local Instance discrete_fun_op_instance : Op (discrete_fun B) := λ f g x,
f x ⋅ g x.
Local Instance discrete_fun_pcore_instance : PCore (discrete_fun B) := λ f,
Some (λ x, core (f x)).
Local Instance discrete_fun_valid_instance : Valid (discrete_fun B) := λ f,
∀ x, ✓ f x.
Local Instance discrete_fun_validN_instance : ValidN (discrete_fun B) := λ n f,
∀ x, ✓{n} f x.
Definition discrete_fun_lookup_op f g x : (f ⋅ g) x = f x ⋅ g x := eq_refl.
Definition discrete_fun_lookup_core f x : (core f) x = core (f x) := eq_refl.
Lemma discrete_fun_included_spec_1 (f g : discrete_fun B) x : f ≼ g → f x ≼ g x.
Proof.
by intros [h Hh]; exists (h x); rewrite /op /discrete_fun_op_instance (Hh x).
Qed.
Lemma discrete_fun_included_spec `{Finite A} (f g : discrete_fun B) :
f ≼ g ↔ ∀ x, f x ≼ g x.
Proof.
split; [by intros; apply discrete_fun_included_spec_1|].
intros [h ?]%finite_choice; by exists h.
Qed.
Lemma discrete_fun_cmra_mixin : CmraMixin (discrete_fun B).
Proof.
apply cmra_total_mixin.
- eauto.
- intros n f1 f2 f3 Hf x. by rewrite discrete_fun_lookup_op (Hf x).
- intros n f1 f2 Hf x. by rewrite discrete_fun_lookup_core (Hf x).
- intros n f1 f2 Hf ? x. by rewrite -(Hf x).
- intros g; split.
+ intros Hg n i; apply cmra_valid_validN, Hg.
+ intros Hg i; apply cmra_valid_validN=> n; apply Hg.
- intros n n' f Hf ? x. eauto using cmra_validN_le.
- intros f1 f2 f3 x. by rewrite discrete_fun_lookup_op assoc.
- intros f1 f2 x. by rewrite discrete_fun_lookup_op comm.
- intros f x.
by rewrite discrete_fun_lookup_op discrete_fun_lookup_core cmra_core_l.
- intros f x. by rewrite discrete_fun_lookup_core cmra_core_idemp.
- intros f1 f2 Hf12. exists (core f2)=>x. rewrite discrete_fun_lookup_op.
apply (discrete_fun_included_spec_1 _ _ x), (cmra_core_mono (f1 x)) in Hf12.
rewrite !discrete_fun_lookup_core. destruct Hf12 as [? ->].
rewrite assoc -cmra_core_dup //.
- intros n f1 f2 Hf x. apply cmra_validN_op_l with (f2 x), Hf.
- intros n f f1 f2 Hf Hf12.
assert (FUN := λ x, cmra_extend n (f x) (f1 x) (f2 x) (Hf x) (Hf12 x)).
exists (λ x, projT1 (FUN x)), (λ x, proj1_sig (projT2 (FUN x))).
split; [|split]=>x; [rewrite discrete_fun_lookup_op| |];
by destruct (FUN x) as (?&?&?&?&?).
Qed.
Canonical Structure discrete_funR :=
Cmra (discrete_fun B) discrete_fun_cmra_mixin.
Local Instance discrete_fun_unit_instance : Unit (discrete_fun B) := λ x, ε.
Definition discrete_fun_lookup_empty x : ε x = ε := eq_refl.
Lemma discrete_fun_ucmra_mixin : UcmraMixin (discrete_fun B).
Proof.
split.
- intros x. apply ucmra_unit_valid.
- intros f x. by rewrite discrete_fun_lookup_op left_id.
- constructor=> x. apply core_id_core, _.
Qed.
Canonical Structure discrete_funUR :=
Ucmra (discrete_fun B) discrete_fun_ucmra_mixin.
Global Instance discrete_fun_unit_discrete :
(∀ i, Discrete (ε : B i)) → Discrete (ε : discrete_fun B).
Proof. intros ? f Hf x. by apply: discrete. Qed.
End discrete_fun_cmra.
Global Arguments discrete_funR {_ _} _.
Global Arguments discrete_funUR {_ _} _.
Global Instance discrete_fun_map_cmra_morphism
{SI : sidx} {A} {B1 B2 : A → ucmra} (f : ∀ x, B1 x → B2 x) :
(∀ x, CmraMorphism (f x)) → CmraMorphism (discrete_fun_map f).
Proof.
split; first apply _.
- intros n g Hg x. rewrite /discrete_fun_map.
apply (cmra_morphism_validN (f _)), Hg.
- intros. apply Some_proper=>i. apply (cmra_morphism_core (f i)).
- intros g1 g2 i.
by rewrite /discrete_fun_map discrete_fun_lookup_op cmra_morphism_op.
Qed.
Program Definition discrete_funURF
{SI : sidx} {C} (F : C → urFunctor) : urFunctor := {|
urFunctor_car A _ B _ := discrete_funUR (λ c, urFunctor_car (F c) A B);
urFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
discrete_funO_map (λ c, urFunctor_map (F c) fg)
|}.
Next Obligation.
intros ? C F A1 ? A2 ? B1 ? B2 ? n ?? g.
by apply discrete_funO_map_ne=>?; apply urFunctor_map_ne.
Qed.
Next Obligation.
intros ? C F A ? B ? g; simpl. rewrite -{2}(discrete_fun_map_id g).
apply discrete_fun_map_ext=> y; apply urFunctor_map_id.
Qed.
Next Obligation.
intros ? C F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f1 f2 f1' f2' g.
rewrite /=-discrete_fun_map_compose.
apply discrete_fun_map_ext=>y; apply urFunctor_map_compose.
Qed.
Global Instance discrete_funURF_contractive {SI : sidx} {C} (F : C → urFunctor) :
(∀ c, urFunctorContractive (F c)) → urFunctorContractive (discrete_funURF F).
Proof.
intros ? A1 ? A2 ? B1 ? B2 ? n ?? g.
by apply discrete_funO_map_ne=> c; apply urFunctor_map_contractive.
Qed.
(** * Constructing a camera [B] through a mapping into [A]
The mapping may restrict the domain (i.e., we have an injection from [B] to [A],
not a bijection) and validity. These two restrictions work on opposite "ends" of
[A] according to [≼]: domain restriction must prove that when an element is in
the domain, so is its composition with other elements; validity restriction must
prove that if the composition of two elements is valid, then so are both of the
elements. The "domain" is the image of [g] in [A], or equivalently the part of
[A] where [f] returns [Some]. *)
Lemma inj_cmra_mixin_restrict_validity {SI : sidx} {A : cmra} {B : ofe}
`{!PCore B, !Op B, !Valid B, !ValidN B}
(f : A → option B) (g : B → A)
(* [g] is proper/non-expansive and injective w.r.t. OFE equality *)
(g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2)
(* [g] is surjective into the part of [A] where [is_Some ∘ f] holds
(and [f] its inverse) *)
(gf_dist : ∀ (x : A) (y : B) n, f x ≡{n}≡ Some y ↔ g y ≡{n}≡ x)
(* [g] commutes with [pcore] (on the part where it is defined) and [op] *)
(g_pcore_dist : ∀ (y cy : B) n,
pcore y ≡{n}≡ Some cy ↔ pcore (g y) ≡{n}≡ Some (g cy))
(g_op : ∀ (y1 y2 : B), g (y1 ⋅ y2) ≡ g y1 ⋅ g y2)
(* [g] also commutes with [opM] when the right-hand side is produced by [f],
and cancels the [f]. In particular this axiom implies that when taking an
element in the domain ([g y]), its composition with *any* [x : A] is still in
the domain, and [f] computes the preimage properly.
Note that just requiring "the composition of two elements from the domain
is in the domain" is insufficient for this lemma to hold. [g_op] already shows
that this is the case, but the issue is that in [pcore_mono] we obtain a
[g y1 ≼ g y2], and the existentially quantified "remainder" in the [≼] has no
reason to be in the domain, so [g_op] is too weak to turn this into some
relation between [y1] and [y2] in [B]. At the same time, [g_opM_f] does not
impl [g_op] since we need [g_op] to prove that [⋅] in [B] respects [≡].
Therefore both [g_op] and [g_opM_f] are required for this lemma to work. *)
(g_opM_f : ∀ (x : A) (y : B), g (y ⋅? f x) ≡ g y ⋅ x)
(* The validity predicate on [B] restricts the one on [A] *)
(g_validN : ∀ n (y : B), ✓{n} y → ✓{n} (g y))
(* The validity predicate on [B] satisfies the laws of validity *)
(valid_validN_ne : ∀ n, Proper (dist n ==> impl) (validN (A:=B) n))
(valid_rvalidN : ∀ y : B, ✓ y ↔ ∀ n, ✓{n} y)
(validN_le : ∀ n n' (y : B), ✓{n} y → n' ≤ n → ✓{n'} y)
(validN_op_l : ∀ n (y1 y2 : B), ✓{n} (y1 ⋅ y2) → ✓{n} y1) :
CmraMixin B.
Proof.
(* Some general derived facts that will be useful later. *)
assert (g_equiv : ∀ y1 y2, y1 ≡ y2 ↔ g y1 ≡ g y2).
{ intros ??. rewrite !equiv_dist. naive_solver. }
assert (g_pcore : ∀ (y cy : B),
pcore y ≡ Some cy ↔ pcore (g y) ≡ Some (g cy)).
{ intros. rewrite !equiv_dist. naive_solver. }
assert (gf : ∀ x y, f x ≡ Some y ↔ g y ≡ x).
{ intros. rewrite !equiv_dist. naive_solver. }
assert (fg : ∀ y, f (g y) ≡ Some y).
{ intros. apply gf. done. }
assert (g_ne : NonExpansive g).
{ intros n ???. apply g_dist. done. }
(* Some of the CMRA properties are useful in proving the others. *)
assert (b_pcore_l' : ∀ y cy : B, pcore y ≡ Some cy → cy ⋅ y ≡ y).
{ intros y cy Hy. apply g_equiv. rewrite g_op. apply cmra_pcore_l'.
apply g_pcore. done. }
assert (b_pcore_idemp : ∀ y cy : B, pcore y ≡ Some cy → pcore cy ≡ Some cy).
{ intros y cy Hy. eapply g_pcore, cmra_pcore_idemp', g_pcore. done. }
(* Now prove all the mixin laws. *)
split.
- intros y n z1 z2 Hz%g_dist. apply g_dist. by rewrite !g_op Hz.
- intros n y1 y2 cy Hy%g_dist Hy1.
assert (g <$> pcore y2 ≡{n}≡ Some (g cy))
as (cx & (cy'&->&->)%fmap_Some_1 & ?%g_dist)%dist_Some_inv_r'; [|by eauto].
assert (Hgcy : pcore (g y1) ≡ Some (g cy)).
{ apply g_pcore. rewrite Hy1. done. }
rewrite equiv_dist in Hgcy. specialize (Hgcy n).
rewrite Hy in Hgcy. apply g_pcore_dist in Hgcy. rewrite Hgcy. done.
- done.
- done.
- done.
- intros y1 y2 y3. apply g_equiv. by rewrite !g_op assoc.
- intros y1 y2. apply g_equiv. by rewrite !g_op comm.
- intros y cy Hcy. apply b_pcore_l'. by rewrite Hcy.
- intros y cy Hcy. eapply b_pcore_idemp. by rewrite -Hcy.
- intros y1 y2 cy [z Hy2] Hy1.
destruct (cmra_pcore_mono' (g y1) (g y2) (g cy)) as (cx&Hcgy2&[x Hcx]).
{ exists (g z). rewrite -g_op. by apply g_equiv. }
{ apply g_pcore. rewrite Hy1 //. }
apply (reflexive_eq (R:=equiv)) in Hcgy2.
rewrite -g_opM_f in Hcx. rewrite Hcx in Hcgy2.
apply g_pcore in Hcgy2.
apply Some_equiv_eq in Hcgy2 as [cy' [-> Hcy']].
eexists. split; first done.
destruct (f x) as [y|].
+ exists y. done.
+ exists cy. apply (reflexive_eq (R:=equiv)), b_pcore_idemp, b_pcore_l' in Hy1.
rewrite Hy1 //.
- done.
- intros n y z1 z2 ?%g_validN ?.
destruct (cmra_extend n (g y) (g z1) (g z2)) as (x1&x2&Hgy&Hx1&Hx2).
{ done. }
{ rewrite -g_op. by apply g_dist. }
symmetry in Hx1, Hx2.
apply gf_dist in Hx1, Hx2.
destruct (f x1) as [y1|] eqn:Hy1; last first.
{ exfalso. inversion Hx1. }
destruct (f x2) as [y2|] eqn:Hy2; last first.
{ exfalso. inversion Hx2. }
exists y1, y2. split_and!.
+ apply g_equiv. rewrite Hgy g_op.
f_equiv; symmetry; apply gf; rewrite ?Hy1 ?Hy2 //.
+ apply g_dist. apply (inj Some) in Hx1. rewrite Hx1 //.
+ apply g_dist. apply (inj Some) in Hx2. rewrite Hx2 //.
Qed.
(** Constructing a CMRA through an isomorphism that may restrict validity. *)
Lemma iso_cmra_mixin_restrict_validity {SI : sidx} {A : cmra} {B : ofe}
`{!PCore B, !Op B, !Valid B, !ValidN B}
(f : A → B) (g : B → A)
(* [g] is proper/non-expansive and injective w.r.t. setoid and OFE equality *)
(g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2)
(* [g] is surjective (and [f] its inverse) *)
(gf : ∀ x : A, g (f x) ≡ x)
(* [g] commutes with [pcore] and [op] *)
(g_pcore : ∀ y : B, pcore (g y) ≡ g <$> pcore y)
(g_op : ∀ y1 y2, g (y1 ⋅ y2) ≡ g y1 ⋅ g y2)
(* The validity predicate on [B] restricts the one on [A] *)
(g_validN : ∀ n y, ✓{n} y → ✓{n} (g y))
(* The validity predicate on [B] satisfies the laws of validity *)
(valid_validN_ne : ∀ n, Proper (dist n ==> impl) (validN (A:=B) n))
(valid_rvalidN : ∀ y : B, ✓ y ↔ ∀ n, ✓{n} y)
(validN_le: ∀ n m (y : B), ✓{n} y → m ≤ n → ✓{m} y)
(validN_op_l : ∀ n (y1 y2 : B), ✓{n} (y1 ⋅ y2) → ✓{n} y1) :
CmraMixin B.
Proof.
assert (g_ne : NonExpansive g).
{ intros n ???. apply g_dist. done. }
assert (g_equiv : ∀ y1 y2, y1 ≡ y2 ↔ g y1 ≡ g y2).
{ intros ??.
split; intros ?; apply equiv_dist; intros; apply g_dist, equiv_dist; done. }
apply (inj_cmra_mixin_restrict_validity (λ x, Some (f x)) g); try done.
- intros. split.
+ intros Hy%(inj Some). rewrite -Hy gf //.
+ intros ?. f_equiv. apply g_dist. rewrite gf. done.
- intros. rewrite g_pcore. split.
+ intros ->. done.
+ intros (? & -> & ->%g_dist)%fmap_Some_dist. done.
- intros ??. simpl. rewrite g_op gf //.
Qed.
(** * Constructing a camera through an isomorphism *)
Lemma iso_cmra_mixin {SI : sidx} {A : cmra} {B : ofe}
`{!PCore B, !Op B, !Valid B, !ValidN B}
(f : A → B) (g : B → A)
(* [g] is proper/non-expansive and injective w.r.t. OFE equality *)
(g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2)
(* [g] is surjective (and [f] its inverse) *)
(gf : ∀ x : A, g (f x) ≡ x)
(* [g] commutes with [pcore], [op], [valid], and [validN] *)
(g_pcore : ∀ y : B, pcore (g y) ≡ g <$> pcore y)
(g_op : ∀ y1 y2, g (y1 ⋅ y2) ≡ g y1 ⋅ g y2)
(g_valid : ∀ y, ✓ (g y) ↔ ✓ y)
(g_validN : ∀ n y, ✓{n} (g y) ↔ ✓{n} y) :
CmraMixin B.
Proof.
apply (iso_cmra_mixin_restrict_validity f g); auto.
- by intros n y ?%g_validN.
- intros n y1 y2 Hy%g_dist Hy1. by rewrite -g_validN -Hy g_validN.
- intros y. rewrite -g_valid cmra_valid_validN. naive_solver.
- intros n m y. rewrite -!g_validN. apply cmra_validN_le.
- intros n y1 y2. rewrite -!g_validN g_op. apply cmra_validN_op_l.
Qed.